Require Import VST.floyd.proofauto.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.FiniteGraph.
Require Export CertiGraph.graph.undirected_graph.

Section EdgeListModel.

Coercion pg_lg: LabeledGraph >-> PreGraph.
Coercion lg_gg: GeneralGraph >-> LabeledGraph.

Local Open Scope logic.
Local Open Scope Z_scope.

#[export] Instance Z_EqDec : EqDec Z eq := Z.eq_dec.

Definition is_null_Z: DecidablePred Z := existT (fun P : Z -> Prop => forall a : Z, {P a} + {~ P a}) (fun x : Z => x < 0) (fun a : Z => Z_lt_dec a 0).

(* Concretizing the EdgelistGraph with array-specific types.
 |  V  |    E    |    DV   |  DE |  DG  | soundness |
 |-----|---------|---------|-----|------|-----------|
 |  Z  |  Z * Z  |   unit  |  Z  | unit |  Finite   |
*)

Definition VType : Type := Z. (*0...V-1*)
Definition EType : Type := VType * VType.
Definition LE : Type := Z. (*weight*)
Definition LV: Type := unit. (*I don't think we need this*)
Definition LG: Type := unit.

#[export] Instance V_EqDec: EqDec VType eq.
Proof. hnf. apply Z.eq_dec. Qed.

#[export] Instance E_EqDec: EqDec EType eq.
Proof.
  hnf. intros [x] [y].
  destruct (equiv_dec x y).
  - hnf in e. destruct (Z.eq_dec v v0); subst.
    + left; reflexivity.
    + right. intro. apply n. inversion H. reflexivity.
  - right; intro; apply c; inversion H; reflexivity.
Defined.

Context {size : Z}.
Context {sizebound: 0 <= size <= Int.max_signed}.

Definition EdgeListLG := LabeledGraph VType EType LV LE LG.

Class SoundEdgeList (g: EdgeListLG) := {
    sb: 0 <= size <= Int.max_signed;
    vv: forall v, vvalid g v <-> 0 <= v < size;
    ev: forall e, evalid g e -> (vvalid g (src g e) /\ vvalid g (dst g e));
    wv: forall e, evalid g e -> Int.min_signed <= elabel g e <= Int.max_signed;
    sf: forall e, evalid g e -> src g e = fst e;
    ds: forall e, evalid g e -> dst g e = snd e;
    fin: FiniteGraph g;
  }.

Definition EdgeListGG := (GeneralGraph VType EType LV LE LG (fun g => SoundEdgeList g)).

Definition EdgeListGG_EdgeListLG
           (g: EdgeListGG) : EdgeListLG := lg_gg g.
Local Coercion EdgeListGG_EdgeListLG: EdgeListGG >-> EdgeListLG.
Local Identity Coercion EdgeListLG_LabeledGraph: EdgeListLG >-> LabeledGraph.

Definition vertex_valid (g: EdgeListGG) :=
  @vv g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Definition edge_valid (g: EdgeListGG) :=
  @ev g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Definition weight_valid (g: EdgeListGG) :=
  @wv g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Definition src_fst (g : EdgeListGG) :=
  @sf g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Definition dst_snd (g: EdgeListGG) :=
  @ds g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Definition size_bound (g: EdgeListGG) :=
  @sb g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Definition finite (g: EdgeListGG) :=
  @fin g ((@sound_gg _ _ _ _ _ _ _ _ g)).

Corollary size_representable:
  Int.min_signed <= size <= Int.max_signed.
Proof.
pose proof Int.min_signed_neg. lia.
Qed.

Corollary vertex_bound:
  forall (g: EdgeListGG) v, vvalid g v -> 0 <= v < Int.max_signed.
Proof.
intros. apply (vertex_valid g) in H. lia.
Qed.

Corollary vertex_representable:
  forall (g: EdgeListGG) v, vvalid g v -> Int.min_signed <= v < Int.max_signed.
Proof.
intros. apply (vertex_valid g) in H.
pose proof Int.min_signed_neg. lia.
Qed.

#[export] Instance finGraph (g: EdgeListGG): FiniteGraph g := @fin g (@sound_gg _ _ _ _ _ _ _ _ g).

Lemma evalid_strong_evalid:
  forall (g: EdgeListGG) e, evalid g e -> strong_evalid g e.
Proof.
intros. split. auto. apply edge_valid. apply H.
Qed.

Lemma evalid_uv_vvalid:
  forall (g: EdgeListGG) u v, evalid g (u,v) -> vvalid g u /\ vvalid g v.
Proof.
intros. apply evalid_strong_evalid in H. destruct H. destruct H0.
rewrite src_fst in H0 by auto. rewrite dst_snd in H1 by auto.
split. apply H0. apply H1.
Qed.

Definition numV (g: EdgeListGG) : Z := Zlength (VList g).
Definition numE (g: EdgeListGG) : Z := Zlength (EList g).
(*
Lemma numV_size:
  forall (g: EdgeListGG), numV g = size.
Proof.
intros. unfold numV.
*)
Lemma numE_pos: forall g, 0 <= numE g.
Proof. intros. unfold numE. apply Zlength_nonneg. Qed.

Definition edge_to_wedge (g: EdgeListLG) e : LE * EType := (elabel g e, e).

Definition graph_to_wedgelist (g: EdgeListGG) : list (LE * EType) :=
  map (edge_to_wedge g) (EList g).

Lemma g2wedgelist_numE:
  forall g, Zlength (graph_to_wedgelist g) = numE g.
Proof.
  intros. unfold numE, graph_to_wedgelist. rewrite Zlength_map. trivial.
Qed.

Lemma NoDup_g2wedgelist:
  forall g, NoDup (graph_to_wedgelist g).
Proof.
intros. apply FinFun.Injective_map_NoDup.
unfold FinFun.Injective; intros. inversion H. auto. apply NoDup_EList.
Qed.

Lemma g2wedgelist_evalid:
  forall g w, In w (graph_to_wedgelist g) -> evalid g (snd w).
Proof.
intros. apply list_in_map_inv in H. destruct H; destruct H.
apply EList_evalid in H0. unfold edge_to_wedge in H. inversion H. simpl. auto.
Qed.

Lemma g2wedgelist_repable:
  forall g w, In w (graph_to_wedgelist g) ->
    Int.min_signed <= fst w <= Int.max_signed /\
    Int.min_signed <= fst (snd w) <= Int.max_signed /\
    Int.min_signed <= snd (snd w) <= Int.max_signed.
Proof.
intros. unfold graph_to_wedgelist in H. apply list_in_map_inv in H.
unfold edge_to_wedge in H. destruct H; destruct H. apply EList_evalid in H0.
subst w; simpl. split. apply weight_valid; auto.
rewrite <- (src_fst g), <- (dst_snd g) by auto.
apply evalid_strong_evalid in H0. destruct H0. destruct H0.
rewrite vertex_valid in H0, H1.
set (i:=Int.min_signed); compute in i; subst i.
split; lia.
Qed.

(*****************************PARTIAL LGRAPH AND MSF**********************)
(*These should be abstracted, but we can deal with it after the kruskal proof is done*)

Lemma sound_fits_upath_transfer:
forall p l (g1 g2: EdgeListGG),
(forall v, vvalid g1 v <-> vvalid g2 v) ->
(forall e, In e l -> evalid g2 e) ->
fits_upath g1 l p -> fits_upath g2 l p.
Proof.
intros. apply (fits_upath_transfer'' p l g1 g2); intros.
apply (valid_upath_vvalid g1 p) in H2. apply H; auto.
apply valid_upath_exists_list_edges'. exists l; auto. apply H0; auto.
repeat rewrite src_fst; auto. apply (fits_upath_evalid g1 p l); auto.
repeat rewrite dst_snd; auto. apply (fits_upath_evalid g1 p l); auto.
auto.
Qed.

(***********MSF for edge lists***********)

Definition sum_LE (g: EdgeListGG) : LE :=
  fold_left Z.add (DEList g) 0.

Definition minimum_spanning_forest (t g: EdgeListGG) :=
 labeled_spanning_uforest t g /\
  forall (t': EdgeListGG), labeled_spanning_uforest t' g ->
    Z.le (sum_DE Z.add t 0) (sum_DE Z.add t' 0).

(*The following are to let us reason about lists instead of graphs*)
Lemma sum_LE_equiv:
  forall (g: EdgeListGG) (l: list EType),
  Permutation (EList g) l -> sum_DE Z.add g 0 = fold_left Z.add (map (elabel g) l) 0.
Proof.
unfold sum_LE, DEList; intros. apply fold_left_comm. intros; lia.
apply Permutation_map. auto.
Qed.

(******Back to forests*****)

Lemma forest_bridge1:
  forall (g: EdgeListGG) u v, uforest' g ->
    evalid g (u,v) -> bridge g (u,v) u v.
Proof.
unfold bridge; intros.
apply (forest_edge' p l g). auto. apply evalid_strong_evalid; auto.
rewrite src_fst; auto. rewrite dst_snd; auto. auto.
Qed.

(**********Edgeless graph with V vertices*************)
(*Built off empty WEdgelessGraph*)
(*Skipping an arbitrary list of vertices, because we need NoDup, and our design forbids the skipping of vertices anyway *)

Definition Zseq (z: Z) : list Z := map Z.of_nat (seq 0%nat (Z.to_nat z)).

Lemma Zseq_NoDup:
  forall z, NoDup (Zseq z).
Proof.
unfold Zseq; intros. destruct z; simpl; try apply NoDup_nil.
apply FinFun.Injective_map_NoDup.
unfold FinFun.Injective. apply Nat2Z.inj.
apply seq_NoDup.
Qed.

Lemma Zseq_In:
  forall z x, In x (Zseq z) <-> 0 <= x < z.
Proof.
intros; unfold Zseq; simpl; split; intros.
+ destruct x; destruct z; try inversion H. lia.
  apply Coqlib.list_in_map_inv in H. destruct H. destruct H. rewrite in_seq in H0. lia.
  apply Coqlib.list_in_map_inv in H. destruct H. destruct H.
  assert (Z.neg p < 0) by (apply Pos2Z.neg_is_neg). assert (0 <= Z.of_nat x) by (apply Nat2Z.is_nonneg). lia.
+ destruct x; destruct z; try lia.
  apply (in_map Z.of_nat (seq 0 (Z.to_nat (Z.pos p))) 0%nat). rewrite in_seq.
  simpl. lia. rewrite <- positive_nat_Z.
  apply (in_map Z.of_nat (seq 0 (Z.to_nat (Z.pos p0))) (Pos.to_nat p)). rewrite in_seq. lia.
Qed.

Corollary Zseq_Zlength:
  forall z, 0 <= z -> Zlength (Zseq z) = z.
Proof.
intros. unfold Zseq. rewrite (Zlength_map nat Z Z.of_nat (seq 0 (Z.to_nat z))).
rewrite Zlength_correct. rewrite seq_length.
apply Z2Nat.id. lia.
Qed.

Section Edgeless_Graph.

Definition edgeless_LG: EdgeListLG :=
@Build_LabeledGraph VType EType V_EqDec E_EqDec LV LE LG
  (@Build_PreGraph VType EType V_EqDec E_EqDec (fun v => 0 <= v < size) (fun e => False) fst snd)
  (fun v => tt) (fun e => 0) tt.

#[export] Instance Sound_edgeless_LG:
  SoundEdgeList edgeless_LG.
Proof.
constructor.
+auto.
+intros; simpl; split; auto.
+intros. simpl in H. contradiction.
+intros. simpl in H. contradiction.
+intros. simpl in H. contradiction.
+intros. simpl in H. contradiction.
+constructor; unfold EnumEnsembles.Enumerable.
exists (Zseq size); split. apply Zseq_NoDup.
unfold edgeless_LG. simpl. intros. apply Zseq_In.
exists nil. simpl. split. apply NoDup_nil. intros; split; intros; auto.
Qed.

Definition edgeless_GG: EdgeListGG :=
  @Build_GeneralGraph VType EType V_EqDec E_EqDec LV LE LG SoundEdgeList
    (EdgeListLG_LabeledGraph edgeless_LG) Sound_edgeless_LG.

Lemma edgeless_GG_vvalid:
  forall k, 0 <= k < size <-> vvalid edgeless_GG k.
Proof.
simpl. intros; split; intros; auto.
Qed.

Lemma edgeless_GG_Permutation:
  Permutation (VList edgeless_GG) (Zseq size).
Proof.
intros. apply NoDup_Permutation. apply NoDup_VList. apply Zseq_NoDup.
intros; rewrite Zseq_In. unfold VList; destruct finiteV; simpl.
destruct a. rewrite H0. rewrite edgeless_GG_vvalid. split; auto.
Qed.

Lemma edgeless_GG_numV:
  forall v, 0 <= v -> numV edgeless_GG = size.
Proof.
unfold numV. intros.
assert (Zlength (VList edgeless_GG) = Zlength (Zseq size)).
apply Permutation_Zlength. apply edgeless_GG_Permutation.
rewrite H0. rewrite Zseq_Zlength. auto. lia.
Qed.

Lemma edgeless_GG_evalid:
  forall e, ~ evalid edgeless_GG e.
Proof.
intros. unfold edgeless_GG; simpl. auto.
Qed.

Lemma edgeless_GG_EList:
  EList edgeless_GG = nil.
Proof.
  unfold edgeless_GG, EList.
  destruct finiteE. simpl in *.
  destruct a.
  destruct x; [trivial | exfalso].
  assert (In e (e::x)) by (apply in_eq).
  apply (H0 e). apply H1.
Qed.

Corollary edgeless_GG_numE:
  numE edgeless_GG = 0.
Proof.
unfold numE. rewrite edgeless_GG_EList. apply Zlength_nil.
Qed.

Corollary graph_to_wedgelist_edgeless_GG:
  graph_to_wedgelist edgeless_GG = nil.
Proof.
unfold graph_to_wedgelist; intros. rewrite edgeless_GG_EList. auto.
Qed.

Lemma uforest'_edgeless_GG:
  uforest' edgeless_GG.
Proof.
split; intros.
(*no self-loops*)
apply edgeless_GG_evalid in H; contradiction.
split; intros.
(*only one edge between two vertices*)
destruct H. destruct H. destruct H.
apply edgeless_GG_evalid in H; contradiction.
(*no rubbish edges*)
split; intros.
apply edgeless_GG_evalid in H; contradiction.
(*main forest definition*)
unfold unique_simple_upath; intros. destruct H0 as [? [? ?]].
destruct p1. inversion H3. destruct p1.
inversion H3. inversion H4. subst u; subst v.
destruct H2 as [? [? ?]]. destruct p2. inversion H5.
destruct p2. inversion H5. subst v. auto.
destruct H2. destruct H2. destruct H2. destruct H2. simpl in H2. contradiction.
destruct H0. destruct H0. destruct H0. destruct H0. simpl in H0. contradiction.
Qed.

End Edgeless_Graph.

(***********ADDING A SINGLE EDGE************)

Section EdgeListGG_add.

Context {g: EdgeListGG}.
Context {u v: VType} {w: LE}.
Context {ubound: 0 <= u < size}.
Context {vbound: 0 <= v < size}.
Context {wbound: Int.min_signed <= w <= Int.max_signed}.

(**Adding is necessary for the kruskal algorithm**)
Definition EdgeListLG_adde :=
  labeledgraph_add_edge g (u,v) u v w.

#[export] Instance Sound_EdgeListLG_adde:
  SoundEdgeList EdgeListLG_adde.
Proof.
constructor.
+auto.
+intros; simpl; rewrite vertex_valid. split; auto.
+intros. simpl in H. unfold addValidFunc in H. simpl. unfold updateEdgeFunc. unfold equiv_dec.
destruct H. destruct (E_EqDec (u,v) e). hnf in e0. subst e.
pose proof (edge_valid g (u,v) H). rewrite src_fst, dst_snd in H0 by auto. apply H0. apply edge_valid; auto.
subst e. destruct (E_EqDec (u,v) (u,v)). repeat rewrite vertex_valid. split; auto.
unfold complement, equiv in c. contradiction.
+simpl; unfold addValidFunc, update_elabel, equiv_dec; intros.
destruct H. destruct (E_EqDec (u,v) e). auto. apply weight_valid; auto.
subst e. destruct (E_EqDec (u,v) (u,v)). auto. unfold complement, equiv in c; contradiction.
+simpl; unfold addValidFunc, updateEdgeFunc, equiv_dec; intros.
destruct H. destruct E_EqDec. unfold equiv in e0. subst e. auto. apply src_fst; auto.
subst e. destruct E_EqDec. auto. unfold complement, equiv in c; contradiction.
+simpl; unfold addValidFunc, updateEdgeFunc, equiv_dec; intros.
destruct H. destruct E_EqDec. unfold equiv in e0. subst e. auto. apply dst_snd; auto.
subst e. destruct E_EqDec. auto. unfold complement, equiv in c; contradiction.
+constructor; unfold EnumEnsembles.Enumerable; simpl.
exists (VList g). split. apply NoDup_VList. apply VList_vvalid.
(*edge*)
unfold addValidFunc. destruct (in_dec E_EqDec (u,v) (EList g)).
(*case e already inside*)
exists (EList g). split. apply NoDup_EList. intros; split; intros. left. apply EList_evalid in H; auto.
destruct H. apply EList_evalid; auto. rewrite H; auto.
(*case e not inside*)
exists ((u,v)::(EList g)). split. apply NoDup_cons. auto. apply NoDup_EList.
intros; split; intros.
destruct H. right; rewrite H; auto. left; rewrite <- EList_evalid; apply H.
destruct H. rewrite <- EList_evalid in H. apply in_cons. apply H.
rewrite H. simpl. left; auto.
Qed.

Definition EdgeListGG_adde: EdgeListGG :=
  @Build_GeneralGraph VType EType V_EqDec E_EqDec LV LE LG SoundEdgeList
    (EdgeListLG_LabeledGraph EdgeListLG_adde)
    Sound_EdgeListLG_adde.

Corollary adde_numV:
  numV EdgeListGG_adde = numV g.
Proof.
intros. unfold EdgeListGG_adde. unfold numV. simpl. unfold VList.
destruct finiteV. destruct finiteV. simpl. simpl in a.
destruct a. destruct a0. assert (Permutation x x0). apply NoDup_Permutation; auto.
intros. rewrite H0. rewrite H2. split; auto.
apply Permutation_Zlength. auto.
Qed.

(*should add an EList1 where e is already in g, but it's not necessary atm*)
Lemma adde_EList1_new:
  ~ evalid g (u,v) -> Permutation ((u,v)::(EList g)) (EList EdgeListGG_adde).
Proof.
intros.
unfold EdgeListGG_adde. simpl. unfold pregraph_add_edge.
set (l:=(u,v)::EList g). unfold EList. destruct finiteE. simpl.
destruct a. unfold addValidFunc in H1. simpl in H1.
apply NoDup_Permutation. unfold l. apply NoDup_cons. rewrite EList_evalid. auto. apply NoDup_EList. auto.
intros; split; intros. apply H1. destruct H2. right; auto. left. rewrite <- EList_evalid. apply H2.
apply H1 in H2. unfold l. destruct H2.
right. apply EList_evalid. auto.
left. auto.
Qed.

Lemma adde_EList2:
  forall e', In e' (EList g) -> In e' (EList EdgeListGG_adde).
Proof.
intros. unfold EList. destruct finiteE. simpl. destruct a.
unfold EdgeListGG_adde in H1. simpl in H1. unfold addValidFunc in H1. apply H1.
left. apply EList_evalid in H. apply H.
Qed.

Lemma adde_elabel1:
  elabel EdgeListGG_adde (u,v) = w.
Proof.
simpl. unfold update_elabel. unfold equiv_dec. destruct E_EqDec. auto.
unfold complement in c. unfold equiv in c. contradiction.
Qed.

Lemma adde_evalid_or:
  forall e', evalid EdgeListGG_adde e' -> (evalid g e' \/ e' = (u,v)).
Proof. unfold EdgeListGG_adde; simpl; unfold addValidFunc. intros. apply H. Qed.

Lemma adde_EList_rev:
  forall l, ~ evalid g (u,v) ->
    Permutation ((u,v)::l) (EList EdgeListGG_adde) ->
    Permutation l (EList g).
Proof.
intros. apply NoDup_Permutation.
apply NoDup_Perm_EList in H0. apply NoDup_cons_1 in H0; auto.
apply NoDup_EList.
intros; split; intros. assert (In x (EList EdgeListGG_adde)).
apply (Permutation_in (l:=(u,v)::l)). auto. right; auto.
apply EList_evalid in H2. apply adde_evalid_or in H2. destruct H2.
rewrite EList_evalid; auto.
subst x. assert (NoDup ((u,v)::l)). apply NoDup_Perm_EList in H0; auto.
apply NoDup_cons_2 in H2. contradiction.
destruct (E_EqDec x (u,v)). unfold equiv in e. subst x. apply EList_evalid in H1; contradiction.
unfold complement, equiv in c.
apply adde_EList2 in H1.
apply (Permutation_in (l':=(u,v)::l)) in H1. destruct H1. symmetry in H1; contradiction. auto.
apply Permutation_sym; auto.
Qed.

Lemma adde_g2wedgelist_1:
  In (w, (u,v)) (graph_to_wedgelist EdgeListGG_adde).
Proof.
intros. unfold graph_to_wedgelist. unfold edge_to_wedge.
replace (w, (u,v)) with (edge_to_wedge EdgeListGG_adde (u,v)).
apply in_map. apply EList_evalid. apply add_edge_evalid.
unfold edge_to_wedge. rewrite adde_elabel1. auto.
Qed.

Corollary adde_g2wedgelist_2:
  forall e', (u,v)<>e' -> evalid g e' -> In (elabel g e', e') (graph_to_wedgelist EdgeListGG_adde).
Proof.
intros. unfold graph_to_wedgelist. replace (elabel g e', e') with (edge_to_wedge EdgeListGG_adde e').
apply in_map. apply EList_evalid. apply add_edge_preserves_evalid; auto.
unfold edge_to_wedge; simpl. unfold update_elabel.
unfold equiv_dec. destruct E_EqDec. contradiction. auto.
Qed.

Lemma adde_numE:
  ~ evalid g (u,v) -> numE EdgeListGG_adde = numE g + 1.
Proof.
intros. unfold numE.
pose proof (adde_EList1_new H).
replace (Zlength (EList EdgeListGG_adde)) with (Zlength ((u,v)::EList g)).
apply Zlength_cons. apply Permutation_Zlength; auto.
Qed.

End EdgeListGG_add.

(*****************************REMOVE EDGES****************************)

Section EdgeListGG_eremove.

Context {g: EdgeListGG}.
Context {e: EType}.
Context {e_evalid: evalid g e}. (*Idk if remove_edge cares, but it matters for all uses here*)

Definition EdgeListLG_eremove :=
  @Build_LabeledGraph VType EType V_EqDec E_EqDec LV LE LG (pregraph_remove_edge g e)
  (vlabel g)
  (*(fun e0 => if eq_dec e0 e then ? else elabel g e )*) (elabel g)
  (glabel g).

(*there is a clash with pregraph_remove_edge_finite*)
#[export] Instance Sound_EdgeListLG_eremove :
  SoundEdgeList EdgeListLG_eremove.
Proof.
constructor.
+auto.
+simpl; intros; rewrite vertex_valid. split; auto.
+simpl; unfold removeValidFunc; intros. destruct H.
apply evalid_strong_evalid in H. apply H.
+simpl; unfold removeValidFunc; intros. destruct H.
apply weight_valid in H; auto.
+simpl; unfold removeValidFunc; intros. destruct H.
apply src_fst; auto.
+simpl; unfold removeValidFunc; intros. destruct H.
apply dst_snd; auto.
+constructor; unfold EnumEnsembles.Enumerable; simpl.
exists (VList g). split. apply NoDup_VList. apply VList_vvalid.
(*edge*)
unfold removeValidFunc.
destruct (in_dec E_EqDec e (EList g)).
(*case e already inside*)
exists (remove E_EqDec e (EList (g))). split.
apply nodup_remove_nodup. apply NoDup_EList.
intros. rewrite remove_In_iff. rewrite EList_evalid. split; auto.
(*case e not inside*)
exists (EList g). split. apply NoDup_EList.
intros; split; intros. split. apply EList_evalid in H; auto.
unfold not; intros; subst x. contradiction.
destruct H. apply EList_evalid. auto.
Qed.

Definition EdgeListGG_eremove: EdgeListGG :=
  @Build_GeneralGraph VType EType V_EqDec E_EqDec LV LE LG SoundEdgeList
    (EdgeListLG_LabeledGraph EdgeListLG_eremove)
    Sound_EdgeListLG_eremove.

Lemma eremove_vvalid:
  forall v, vvalid EdgeListGG_eremove v <-> vvalid g v.
Proof.
simpl. intros; split; auto.
Qed.

(*Don't bother with defining what happens when e isn't inside*)
Lemma eremove_evalid1:
  ~ evalid EdgeListGG_eremove e.
Proof.
simpl. unfold removeValidFunc, not; intros. destruct H. contradiction.
Qed.

Lemma eremove_EList_rev:
  forall l, Permutation l (EList EdgeListGG_eremove) -> Permutation (e::l) (EList g).
Proof.
intros. assert (~ In e (EList EdgeListGG_eremove)).
rewrite EList_evalid. apply eremove_evalid1.
assert (~ In e l). unfold not; intros.
apply (Permutation_in (l':= (EList EdgeListGG_eremove))) in H1. contradiction. auto.
apply NoDup_Permutation. apply NoDup_cons; auto. apply NoDup_Perm_EList in H; auto.
apply NoDup_EList.
intros; split; intros. apply EList_evalid. destruct H2. subst x. auto.
apply (Permutation_in (l':= (EList EdgeListGG_eremove))) in H2; auto.
rewrite EList_evalid in H2. simpl in H2. unfold removeValidFunc in H2. apply H2.
destruct (E_EqDec x e). unfold equiv in e0. subst x. left; auto.
unfold complement, equiv in c. right.
assert (evalid EdgeListGG_eremove x).
apply remove_edge_evalid. split. apply EList_evalid in H2; auto. auto.
rewrite <- EList_evalid in H3.
apply (Permutation_in (l:= (EList EdgeListGG_eremove))). apply Permutation_sym; auto. apply H3.
Qed.

Lemma eremove_uforest':
  uforest' g -> uforest' EdgeListGG_eremove /\ ~ connected EdgeListGG_eremove (src g e) (dst g e).
Proof.
intros.
destruct e as (u,v) eqn:X. rewrite src_fst, dst_snd; auto.
pose proof eremove_evalid1.
assert (Hvvalid: forall v1 : VType, vvalid EdgeListGG_eremove v1 <-> vvalid g v1).
  simpl; intros; split; auto.
split.
{ split. intros. simpl. apply H. apply H1.
split. intros. unfold adj_edge, strong_evalid in H1; simpl in H1.
  unfold removeValidFunc in H1. destruct H1. destruct H1. destruct H2.
  destruct H. destruct H5. apply (H5 u0 v0).
  split; split.
  split. apply H1. apply H1. apply H3.
  split. apply H2. apply H2. apply H4.
split. intros. apply evalid_strong_evalid; auto.
unfold unique_simple_upath; intros.
assert (exists l, fits_upath EdgeListGG_eremove l p1). apply valid_upath_exists_list_edges. apply H2.
destruct H5 as [l1 ?].
assert (exists l, fits_upath EdgeListGG_eremove l p2). apply valid_upath_exists_list_edges. apply H4.
destruct H6 as [l2 ?].
destruct (in_dec E_EqDec e l1).
apply (fits_upath_evalid EdgeListGG_eremove p1) in i; auto. contradiction.
destruct (in_dec E_EqDec e l2).
apply (fits_upath_evalid EdgeListGG_eremove p2) in i; auto. contradiction.
apply (fits_upath_transfer' p1 l1 _ g) in H5; auto.
apply (fits_upath_transfer' p2 l2 _ g) in H6; auto.
assert (valid_upath g p1). apply valid_upath_exists_list_edges'. exists l1. auto.
assert (valid_upath g p2). apply valid_upath_exists_list_edges'. exists l2. auto.
assert (unique_simple_upath g). apply H. unfold unique_simple_upath in H9.
destruct H1. destruct H3. destruct H2. destruct H4.
apply (H9 u0 v0 p1 p2). split; auto. split; auto. split; auto. split; auto.
intros. apply (fits_upath_evalid _ _ _ _ H6) in H7. apply H7.
intros. apply (fits_upath_evalid _ _ _ _ H5) in H7. apply H7.
}
{
unfold not, connected; intros.
destruct H1 as [p ?].
assert (exists l, fits_upath EdgeListGG_eremove l p). apply valid_upath_exists_list_edges. apply H1.
destruct H2 as [l ?].
assert (fits_upath g l p). apply (sound_fits_upath_transfer p l EdgeListGG_eremove g); auto.
intros. apply (fits_upath_evalid _ _ _ _ H2) in H3. apply H3.
assert (connected_by_path g p u v). split.
apply valid_upath_exists_list_edges'. exists l; auto. destruct H1. auto.
pose proof (forest_bridge1 g u v H e_evalid).
assert (In (u,v) l). unfold bridge in H5. apply (H5 p l); auto.
apply (fits_upath_evalid _ _ _ _ H2) in H6. rewrite X in *. contradiction.
}
Qed.

End EdgeListGG_eremove.

(******************SORTING****************)

(*Sigh, this is really silly, but I need a sort for this specific "struct"*)
Fixpoint insert (g:EdgeListGG) (i:EType) (l: list EType) :=
  match l with
  | nil => i::nil
  | h::t => if (elabel g i <=? elabel g h) then i::h::t else h :: insert g i t
 end.

Fixpoint sort (g: EdgeListGG) (l: list EType) :=
  match l with
  | nil => nil
  | h::t => insert g h (sort g t)
end.

Inductive sorted (g: EdgeListGG): list EType -> Prop :=
| sorted_nil:
    sorted g nil
| sorted_1: forall x,
    sorted g (x::nil)
| sorted_cons: forall x y l,
     (elabel g x) <= (elabel g y) -> sorted g (y::l) -> sorted g (x::y::l).

Lemma insert_perm: forall (g: EdgeListGG) x l, Permutation (x::l) (insert g x l).
Proof.
induction l. simpl. apply Permutation_refl.
simpl. destruct (Z.leb (elabel g x) (elabel g a)). apply Permutation_refl.
apply (Permutation_trans (l':=a::x::l)). apply perm_swap.
apply perm_skip. apply IHl.
Qed.

Theorem sort_perm: forall (g: EdgeListGG) l, Permutation l (sort g l).
Proof.
induction l. simpl. apply Permutation_refl.
simpl. apply (Permutation_trans (l':=a::(sort g l))).
apply perm_skip. apply IHl.
apply insert_perm.
Qed.

Lemma insert_sorted:
  forall g a l, sorted g l -> sorted g (insert g a l).
Proof.
intros. induction H.
simpl. apply sorted_1.
simpl. destruct (Z.leb (elabel g a) (elabel g x)) eqn:ax.
apply sorted_cons. apply Z.leb_le. auto. apply sorted_1.
apply Z.leb_gt in ax. apply sorted_cons. lia. apply sorted_1.
simpl.
destruct (Z.leb (elabel g a) (elabel g x)) eqn:ax.
apply sorted_cons. apply Z.leb_le. auto. apply sorted_cons; auto.
apply Z.leb_gt in ax. simpl in IHsorted. destruct (Z.leb (elabel g a) (elabel g y)) eqn:ay.
apply sorted_cons. lia. apply Z.leb_le in ay. apply sorted_cons; auto.
apply Z.leb_gt in ay. apply sorted_cons. lia. apply IHsorted.
Qed.

Theorem sort_sorted: forall (g:EdgeListGG) (l: list EType), sorted g (sort g l).
Proof.
induction l; intros. apply sorted_nil.
destruct l. simpl. apply sorted_1.
simpl in IHl. simpl. apply insert_sorted. auto.
Qed.

Definition sorted' (g: EdgeListGG) (l: list EType) :=
 forall i j, 0 <= i < j -> j < Zlength l -> Z.le (elabel g (Znth i l)) (elabel g (Znth j l)).

Lemma sorted_sorted':
  forall g l, sorted g l -> sorted' g l.
Proof.
intros. unfold sorted'. induction H.
intros. rewrite Zlength_nil in H0. lia.
intros. rewrite Zlength_cons, Zlength_nil in H0. lia.
intros. destruct (Z.lt_trichotomy i 0). lia. destruct H3.
subst i. rewrite Znth_0_cons. rewrite Znth_pos_cons by lia.
destruct (Z.lt_trichotomy (j-1) 0). lia. destruct H3.
rewrite H3. rewrite Znth_0_cons. auto.
specialize IHsorted with 0 (j-1). rewrite Znth_0_cons in IHsorted.
apply (Z.le_trans (elabel g x) (elabel g y)). auto. apply IHsorted. lia.
rewrite Zlength_cons in H2. lia.
rewrite (Znth_pos_cons i) by lia. rewrite (Znth_pos_cons j) by lia. apply IHsorted.
lia. rewrite Zlength_cons in H2. lia.
Qed.

End EdgeListModel.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Common subexpression elimination over RTL.  This optimization
  proceeds by value numbering over extended basic blocks. *)

Require Import Coqlib.
Require Import Maps.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import RTLtyping.
Require Import Kildall.
Require Import CombineOp.

(** * Value numbering *)

(** The idea behind value numbering algorithms is to associate
  abstract identifiers (``value numbers'') to the contents of registers
  at various program points, and record equations between these
  identifiers.  For instance, consider the instruction
  [r1 = add(r2, r3)] and assume that [r2] and [r3] are mapped
  to abstract identifiers [x] and [y] respectively at the program
  point just before this instruction.  At the program point just after,
  we can add the equation [z = add(x, y)] and associate [r1] with [z],
  where [z] is a fresh abstract identifier.  However, if we already
  knew an equation [u = add(x, y)], we can preferably add no equation
  and just associate [r1] with [u].  If there exists a register [r4]
  mapped with [u] at this point, we can then replace the instruction
  [r1 = add(r2, r3)] by a move instruction [r1 = r4], therefore eliminating
  a common subexpression and reusing the result of an earlier addition.

  Abstract identifiers / value numbers are represented by positive integers.
  Equations are of the form [valnum = rhs], where the right-hand sides
  [rhs] are either arithmetic operations or memory loads. *)

(*
Definition valnum := positive.

Inductive rhs : Type :=
  | Op: operation -> list valnum -> rhs
  | Load: memory_chunk -> addressing -> list valnum -> rhs.
*)

Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.

Definition eq_list_valnum (x y: list valnum) : {x=y}+{x<>y}.
Proof.
  decide equality. apply eq_valnum.
Qed.

Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
Proof.
  generalize Int.eq_dec; intro.
  generalize Float.eq_dec; intro.
  generalize eq_operation; intro.
  generalize eq_addressing; intro.
  assert (forall (x y: memory_chunk), {x=y}+{x<>y}). decide equality.
  generalize eq_valnum; intro.
  generalize eq_list_valnum; intro.
  decide equality.
Qed.

(** A value numbering is a collection of equations between value numbers
  plus a partial map from registers to value numbers.  Additionally,
  we maintain the next unused value number, so as to easily generate
  fresh value numbers. *)

Record numbering : Type := mknumbering {
  num_next: valnum;                  (**r first unused value number *)
  num_eqs: list (valnum * rhs);       (**r valid equations *)
  num_reg: PTree.t valnum;           (**r mapping register to valnum *)
  num_val: PMap.t (list reg)         (**r reverse mapping valnum to regs containing it *)
}.

Definition empty_numbering :=
  mknumbering 1%positive nil (PTree.empty valnum) (PMap.init nil).

(** [valnum_reg n r] returns the value number for the contents of
  register [r].  If none exists, a fresh value number is returned
  and associated with register [r].  The possibly updated numbering
  is also returned.  [valnum_regs] is similar, but for a list of
  registers. *)

Definition valnum_reg (n: numbering) (r: reg) : numbering * valnum :=
  match PTree.get r n.(num_reg) with
  | Some v => (n, v)
  | None   =>
      let v := n.(num_next) in
      (mknumbering (Psucc v)
                   n.(num_eqs)
                   (PTree.set r v n.(num_reg))
                   (PMap.set v (r :: nil) n.(num_val)),
       v)
  end.

Fixpoint valnum_regs (n: numbering) (rl: list reg)
                     {struct rl} : numbering * list valnum :=
  match rl with
  | nil =>
      (n, nil)
  | r1 :: rs =>
      let (n1, v1) := valnum_reg n r1 in
      let (ns, vs) := valnum_regs n1 rs in
      (ns, v1 :: vs)
  end.

(** [find_valnum_rhs rhs eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some value number [vn].
  If found, [Some vn] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_rhs (r: rhs) (eqs: list (valnum * rhs))
                         {struct eqs} : option valnum :=
  match eqs with
  | nil => None
  | (v, r') :: eqs1 =>
      if eq_rhs r r' then Some v else find_valnum_rhs r eqs1
  end.

(** [find_valnum_num vn eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some equation [rhs].
  If found, [Some rhs] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_num (v: valnum) (eqs: list (valnum * rhs))
                         {struct eqs} : option rhs :=
  match eqs with
  | nil => None
  | (v', r') :: eqs1 =>
      if peq v v' then Some r' else find_valnum_num v eqs1
  end.

(** Update the [num_val] mapping prior to a redefinition of register [r]. *)

Definition forget_reg (n: numbering) (rd: reg) : PMap.t (list reg) :=
  match PTree.get rd n.(num_reg) with
  | None => n.(num_val)
  | Some v => PMap.set v (List.remove peq rd (PMap.get v n.(num_val))) n.(num_val)
  end.

Definition update_reg (n: numbering) (rd: reg) (vn: valnum) : PMap.t (list reg) :=
  let nv := forget_reg n rd in PMap.set vn (rd :: PMap.get vn nv) nv.

(** [add_rhs n rd rhs] updates the value numbering [n] to reflect
  the computation of the operation or load represented by [rhs]
  and the storing of the result in register [rd].  If an equation
  [vn = rhs] is known, register [rd] is set to [vn].  Otherwise,
  a fresh value number [vn] is generated and associated with [rd],
  and the equation [vn = rhs] is added. *)

Definition add_rhs (n: numbering) (rd: reg) (rh: rhs) : numbering :=
  match find_valnum_rhs rh n.(num_eqs) with
  | Some vres =>
      mknumbering n.(num_next) n.(num_eqs)
                  (PTree.set rd vres n.(num_reg))
                  (update_reg n rd vres)
  | None =>
      mknumbering (Psucc n.(num_next))
                  ((n.(num_next), rh) :: n.(num_eqs))
                  (PTree.set rd n.(num_next) n.(num_reg))
                  (update_reg n rd n.(num_next))
  end.

(** [add_op n rd op rs] specializes [add_rhs] for the case of an
  arithmetic operation.  The right-hand side corresponding to [op]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs].

  If [op] is a move instruction, we simply assign the value number of
  the source register to the destination register, since we know that
  the source and destination registers have exactly the same value.
  This enables more common subexpressions to be recognized. For instance:
<<
     z = add(x, y);  u = x; v = add(u, y);
>>
  Since [u] and [x] have the same value number, the second [add]
  is recognized as computing the same result as the first [add],
  and therefore [u] and [z] have the same value number. *)

Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) :=
  match is_move_operation op rs with
  | Some r =>
      let (n1, v) := valnum_reg n r in
      mknumbering n1.(num_next) n1.(num_eqs)
                 (PTree.set rd v n1.(num_reg)) (update_reg n1 rd v)
  | None =>
      let (n1, vs) := valnum_regs n rs in
      add_rhs n1 rd (Op op vs)
  end.

(** [add_load n rd chunk addr rs] specializes [add_rhs] for the case of a
  memory load.  The right-hand side corresponding to [chunk], [addr]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs]. *)

Definition add_load (n: numbering) (rd: reg)
                    (chunk: memory_chunk) (addr: addressing)
                    (rs: list reg) :=
  let (n1, vs) := valnum_regs n rs in
  add_rhs n1 rd (Load chunk addr vs).

(** [add_unknown n rd] returns a numbering where [rd] is mapped to a
   fresh value number, and no equations are added.  This is useful
   to model instructions with unpredictable results such as [Ibuiltin]. *)

Definition add_unknown (n: numbering) (rd: reg) :=
  mknumbering (Psucc n.(num_next))
              n.(num_eqs)
              (PTree.set rd n.(num_next) n.(num_reg))
              (forget_reg n rd).

(** [kill_equations pred n] remove all equations satisfying predicate [pred]. *)

Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list (valnum * rhs)) : list (valnum * rhs) :=
  match eqs with
  | nil => nil
  | eq :: rem => if pred (snd eq) then kill_eqs pred rem else eq :: kill_eqs pred rem
  end.

Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering :=
  mknumbering n.(num_next)
              (kill_eqs pred n.(num_eqs))
              n.(num_reg) n.(num_val).

(** [kill_loads n] removes all equations involving memory loads,
  as well as those involving memory-dependent operators.
  It is used to reflect the effect of a builtin operation, which can
  change memory in unpredictable ways and potentially invalidate all such equations. *)

Definition filter_loads (r: rhs) : bool :=
  match r with
  | Op op _ => op_depends_on_memory op
  | Load _ _ _ => true
  end.

Definition kill_loads (n: numbering) : numbering :=
  kill_equations filter_loads n.

(** [reg_valnum n vn] returns a register that is mapped to value number
    [vn], or [None] if no such register exists. *)

Definition reg_valnum (n: numbering) (vn: valnum) : option reg :=
  match PMap.get vn n.(num_val) with
  | nil => None
  | r :: rs => Some r
  end.

Fixpoint regs_valnums (n: numbering) (vl: list valnum) : option (list reg) :=
  match vl with
  | nil => Some nil
  | v1 :: vs =>
      match reg_valnum n v1, regs_valnums n vs with
      | Some r1, Some rs => Some (r1 :: rs)
      | _, _ => None
      end
  end.

(** [add_store n chunk addr rargs rsrc] updates the numbering [n] to reflect
  the effect of a store instruction [Istore chunk addr rargs rsrc].
  Equations involving the memory state are removed from [n], unless we
  can prove that the store does not invalidate them.
  Then, an equations [rsrc = Load chunk addr rargs] is added to reflect
  the known content of the stored memory area, but only if [chunk] is
  a "full-size" quantity ([Mint32] or [Mfloat64]). *)

Require Import AliasAnalysisConclusion.

Definition disjoint_sets chunk chunk' store_set_o load_set_o :=
  match store_set_o, load_set_o with
    | None, _ | _, None => false
    | Some store_set, Some load_set => disjoint_chunks_dec_bool chunk chunk' store_set load_set
  end.

Definition filter_after_store (chunk: memory_chunk) (addr: addressing) (vl: list valnum)
  store_set_o rmap n (r: rhs) : bool :=
  match r with
  | Op op vl' => op_depends_on_memory op
  | Load chunk' addr' vl' =>
      negb (
        (* true if we can prove disjointness *)
        (eq_list_valnum vl vl' && addressing_separated chunk addr chunk' addr')
        || (
          match regs_valnums n vl' with
          | None => false
          | Some rargs' =>
            let load_set_o := AliasAnalysis.addr_image addr' rargs' rmap in
            disjoint_sets chunk chunk' store_set_o (AliasAnalysis.addr_image addr' rargs' rmap)
          end
        )
      )
  end.

Definition add_store rmap (n: numbering) (chunk: memory_chunk) (addr: addressing)
                                   (rargs: list reg) (rsrc: reg) : numbering :=
  let (n1, vargs) := valnum_regs n rargs in
  let addr_set := AliasAnalysis.addr_image addr rargs rmap in
  let n2 := kill_equations (filter_after_store chunk addr vargs addr_set rmap n) n1 in
  match chunk with
  | Mint32 | Mfloat64 => add_rhs n2 rsrc (Load chunk addr vargs)
  | _ => n2
  end.

(** [find_rhs] return a register that already holds the result of the given arithmetic
    operation or memory load, according to the given numbering.
    [None] is returned if no such register exists. *)

Definition find_rhs (n: numbering) (rh: rhs) : option reg :=
  match find_valnum_rhs rh n.(num_eqs) with
  | None => None
  | Some vres => reg_valnum n vres
  end.

(** Experimental: take advantage of known equations to select more efficient
  forms of operations, addressing modes, and conditions. *)

Section REDUCE.

Variable A: Type.
Variable f: (valnum -> option rhs) -> A -> list valnum -> option (A * list valnum).
Variable n: numbering.

Fixpoint reduce_rec (niter: nat) (op: A) (args: list valnum) : option(A * list reg) :=
  match niter with
  | O => None
  | S niter' =>
      match f (fun v => find_valnum_num v n.(num_eqs)) op args with
      | None => None
      | Some(op', args') =>
          match reduce_rec niter' op' args' with
          | None =>
              match regs_valnums n args' with Some rl => Some(op', rl) | None => None end
          | Some _ as res =>
              res
          end
      end
  end.

Definition reduce (op: A) (rl: list reg) (vl: list valnum) : A * list reg :=
  match reduce_rec 4%nat op vl with
  | None     => (op, rl)
  | Some res => res
  end.

End REDUCE.

(** * The static analysis *)

(** We now define a notion of satisfiability of a numbering.  This semantic
  notion plays a central role in the correctness proof (see [CSEproof]),
  but is defined here because we need it to define the ordering over
  numberings used in the static analysis.

  A numbering is satisfiable in a given register environment and memory
  state if there exists a valuation, mapping value numbers to actual values,
  that validates both the equations and the association of registers
  to value numbers. *)

Definition equation_holds
     (valuation: valnum -> val)
     (ge: genv) (sp: val) (m: mem)
     (vres: valnum) (rh: rhs) : Prop :=
  match rh with
  | Op op vl =>
      eval_operation ge sp op (List.map valuation vl) m =
      Some (valuation vres)
  | Load chunk addr vl =>
      exists a,
      eval_addressing ge sp addr (List.map valuation vl) = Some a /\
      Mem.loadv chunk m a = Some (valuation vres)
  end.

Definition numbering_holds
   (valuation: valnum -> val)
   (ge: genv) (sp: val) (rs: regset) (m: mem) (n: numbering) : Prop :=
     (forall vn rh,
       In (vn, rh) n.(num_eqs) ->
       equation_holds valuation ge sp m vn rh)
  /\ (forall r vn,
       PTree.get r n.(num_reg) = Some vn -> rs#r = valuation vn).

Definition numbering_satisfiable
   (ge: genv) (sp: val) (rs: regset) (m: mem) (n: numbering) : Prop :=
  exists valuation, numbering_holds valuation ge sp rs m n.

Lemma empty_numbering_satisfiable:
  forall ge sp rs m, numbering_satisfiable ge sp rs m empty_numbering.
Proof.
  intros; red.
  exists (fun (vn: valnum) => Vundef). split; simpl; intros.
  elim H.
  rewrite PTree.gempty in H. discriminate.
Qed.

(** We now equip the type [numbering] with a partial order and a greatest
  element.  The partial order is based on entailment: [n1] is greater
  than [n2] if [n1] is satisfiable whenever [n2] is.  The greatest element
  is, of course, the empty numbering (no equations). *)

Module Numbering.
  Definition t := numbering.
  Definition ge (n1 n2: numbering) : Prop :=
    forall ge sp rs m,
    numbering_satisfiable ge sp rs m n2 ->
    numbering_satisfiable ge sp rs m n1.
  Definition top := empty_numbering.
  Lemma top_ge: forall x, ge top x.
  Proof.
    intros; red; intros. unfold top. apply empty_numbering_satisfiable.
  Qed.
  Lemma refl_ge: forall x, ge x x.
  Proof.
    intros; red; auto.
  Qed.
End Numbering.

(** We reuse the solver for forward dataflow inequations based on
  propagation over extended basic blocks defined in library [Kildall]. *)

Module Solver := BBlock_solver(Numbering).

(** The transfer function for the dataflow analysis returns the numbering
  ``after'' execution of the instruction at [pc], as a function of the
  numbering ``before''.  For [Iop] and [Iload] instructions, we add
  equations or reuse existing value numbers as described for
  [add_op] and [add_load].  For [Istore] instructions, we forget
  all equations involving memory loads.  For [Icall] instructions,
  we could simply associate a fresh, unconstrained by equations value number
  to the result register.  However, it is often undesirable to eliminate
  common subexpressions across a function call (there is a risk of
  increasing too much the register pressure across the call), so we
  just forget all equations and start afresh with an empty numbering.
  Finally, the remaining instructions modify neither registers nor
  the memory, so we keep the numbering unchanged. *)

Require AliasAnalysis.

Definition transfer (f: function) alias (pc: node) (before: numbering) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Inop s =>
          before
      | Iop op args res s =>
          add_op before res op args
      | Iload chunk addr args dst s =>
          add_load before dst chunk addr args
      | Istore chunk addr args src s =>
          add_store (fst (AliasAnalysis.coerce_solver (alias#pc))) before chunk addr args src
      | Icall sig ros args res s =>
          empty_numbering
      | Itailcall sig ros args =>
          empty_numbering
      | Ibuiltin ef args res s =>
          add_unknown (kill_loads before) res
      | Icond cond args ifso ifnot =>
          before
      | Ijumptable arg tbl =>
          before
      | Ireturn optarg =>
          before
      end
  end.

(** The static analysis solves the dataflow inequations implied
  by the [transfer] function using the ``extended basic block'' solver,
  which produces sub-optimal solutions quickly.  The result is
  a mapping from program points to numberings. *)

Definition analyze (f: RTL.function): option (PMap.t numbering) :=
  Solver.fixpoint
  (successors f)
  (transfer f (AliasAnalysis.safe_funanalysis f))
  f.(fn_entrypoint).

(** * Code transformation *)

(** The code transformation is performed instruction by instruction.
  [Iload] instructions and non-trivial [Iop] instructions are turned
  into move instructions if their result is already available in a
  register, as indicated by the numbering inferred at that program point.

  Some operations are so cheap to compute that it is generally not
  worth reusing their results.  These operations are detected by the
  function [is_trivial_op] in module [Op]. *)

Definition transf_instr (n: numbering) (instr: instruction) :=
  match instr with
  | Iop op args res s =>
      if is_trivial_op op then instr else
        let (n1, vl) := valnum_regs n args in
        match find_rhs n1 (Op op vl) with
        | Some r =>
            Iop Omove (r :: nil) res s
        | None =>
            let (op', args') := reduce _ combine_op n1 op args vl in
            Iop op' args' res s
        end
  | Iload chunk addr args dst s =>
      let (n1, vl) := valnum_regs n args in
      match find_rhs n1 (Load chunk addr vl) with
      | Some r =>
          Iop Omove (r :: nil) dst s
      | None =>
          let (addr', args') := reduce _ combine_addr n1 addr args vl in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (n1, vl) := valnum_regs n args in
      let (addr', args') := reduce _ combine_addr n1 addr args vl in
      Istore chunk addr' args' src s
  | Icond cond args s1 s2 =>
      let (n1, vl) := valnum_regs n args in
      let (cond', args') := reduce _ combine_cond n1 cond args vl in
      Icond cond' args' s1 s2
  | _ =>
      instr
  end.

Definition transf_code (approxs: PMap.t numbering) (instrs: code) : code :=
  PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs.

Definition transf_function (f: function) : res function :=
  match type_function f with
  | Error msg => Error msg
  | OK tyenv =>
      match analyze f with
      | None => Error (msg "CSE failure")
      | Some approxs =>
          OK(mkfunction
               f.(fn_sig)
               f.(fn_params)
               f.(fn_stacksize)
               (transf_code approxs f.(fn_code))
               f.(fn_entrypoint))
      end
  end.

Definition transf_fundef (f: fundef) : res fundef :=
  AST.transf_partial_fundef transf_function f.

Definition transf_program (p: program) : res program :=
  transform_partial_program transf_fundef p.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(** * NMake_gen *)

(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)

(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)

Require Import BigNumPrelude ZArith Ndigits CyclicAxioms
 DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic
 Wf_nat StreamMemo.

Module Make (W0:CyclicType) <: NAbstract.

 (** * The word types *)

 Local Notation w0 := W0.t.
 Definition w1 := zn2z w0.
 Definition w2 := zn2z w1.
 Definition w3 := zn2z w2.
 Definition w4 := zn2z w3.
 Definition w5 := zn2z w4.
 Definition w6 := zn2z w5.

 (** * The operation type classes for the word types *)

 Local Notation w0_op := W0.ops.
 Instance w1_op : ZnZ.Ops w1 := mk_zn2z_ops w0_op.
 Instance w2_op : ZnZ.Ops w2 := mk_zn2z_ops w1_op.
 Instance w3_op : ZnZ.Ops w3 := mk_zn2z_ops w2_op.
 Instance w4_op : ZnZ.Ops w4 := mk_zn2z_ops_karatsuba w3_op.
 Instance w5_op : ZnZ.Ops w5 := mk_zn2z_ops_karatsuba w4_op.
 Instance w6_op : ZnZ.Ops w6 := mk_zn2z_ops_karatsuba w5_op.
 Instance w7_op : ZnZ.Ops (word w6 1) := mk_zn2z_ops_karatsuba w6_op.
 Instance w8_op : ZnZ.Ops (word w6 2) := mk_zn2z_ops_karatsuba w7_op.
 Instance w9_op : ZnZ.Ops (word w6 3) := mk_zn2z_ops_karatsuba w8_op.

 Section Make_op.
  Variable mk : forall w', ZnZ.Ops w' -> ZnZ.Ops (zn2z w').

  Fixpoint make_op_aux (n:nat) : ZnZ.Ops (word w6 (S n)):=
   match n return ZnZ.Ops (word w6 (S n)) with
   | O => w7_op
   | S n1 =>
     match n1 return ZnZ.Ops (word w6 (S (S n1))) with
     | O => w8_op
     | S n2 =>
       match n2 return ZnZ.Ops (word w6 (S (S (S n2)))) with
       | O => w9_op
       | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))
       end
     end
   end.

 End Make_op.

 Definition omake_op := make_op_aux mk_zn2z_ops_karatsuba.

 Definition make_op_list := dmemo_list _ omake_op.

 Instance make_op n : ZnZ.Ops (word w6 (S n))
  := dmemo_get _ omake_op n make_op_list.

 Ltac unfold_ops := unfold omake_op, make_op_aux, w9_op, w8_op.

 Lemma make_op_omake: forall n, make_op n = omake_op n.
 Proof.
 intros n; unfold make_op, make_op_list.
 refine (dmemo_get_correct _ _ _).
 Qed.

 Theorem make_op_S: forall n,
   make_op (S n) = mk_zn2z_ops_karatsuba (make_op n).
 Proof.
 intros n. do 2 rewrite make_op_omake.
 revert n. fix IHn 1.
 do 3 (destruct n; [unfold_ops; reflexivity|]).
 simpl mk_zn2z_ops_karatsuba. simpl word in *.
 rewrite <- (IHn n). auto.
 Qed.

 (** * The main type [t], isomorphic with [exists n, word w0 n] *)

 Inductive t' :=
  | N0 : w0 -> t'
  | N1 : w1 -> t'
  | N2 : w2 -> t'
  | N3 : w3 -> t'
  | N4 : w4 -> t'
  | N5 : w5 -> t'
  | N6 : w6 -> t'
  | Nn : forall n, word w6 (S n) -> t'.

 Definition t := t'.

 (** * A generic toolbox for building and deconstructing [t] *)

 Local Notation SizePlus n := (S (S (S (S (S (S n)))))).
 Local Notation Size := (SizePlus O).

 Tactic Notation (at level 3) "do_size" tactic3(t) := do 7 t.

 Definition dom_t n := match n with
  | 0 => w0
  | 1 => w1
  | 2 => w2
  | 3 => w3
  | 4 => w4
  | 5 => w5
  | 6 => w6
  | SizePlus n => word w6 n
 end.

 Instance dom_op n : ZnZ.Ops (dom_t n) | 10.
 Proof.
  do_size (destruct n; [simpl;auto with *|]).
  unfold dom_t. auto with *.
 Defined.

 Definition iter_t {A:Type}(f : forall n, dom_t n -> A) : t -> A :=
  let f0 := f 0 in
  let f1 := f 1 in
  let f2 := f 2 in
  let f3 := f 3 in
  let f4 := f 4 in
  let f5 := f 5 in
  let f6 := f 6 in
  let fn n := f (SizePlus (S n)) in
  fun x => match x with
   | N0 wx => f0 wx
   | N1 wx => f1 wx
   | N2 wx => f2 wx
   | N3 wx => f3 wx
   | N4 wx => f4 wx
   | N5 wx => f5 wx
   | N6 wx => f6 wx
   | Nn n wx => fn n wx
  end.

 Definition mk_t (n:nat) : dom_t n -> t :=
  match n as n' return dom_t n' -> t with
   | 0 => N0
   | 1 => N1
   | 2 => N2
   | 3 => N3
   | 4 => N4
   | 5 => N5
   | 6 => N6
   | SizePlus (S n) => Nn n
  end.

 Definition level := iter_t (fun n _ => n).

 Inductive View_t : t -> Prop :=
  Mk_t : forall n (x : dom_t n), View_t (mk_t n x).

 Lemma destr_t : forall x, View_t x.
 Proof.
 intros x. generalize (Mk_t (level x)). destruct x; simpl; auto.
 Defined.

 Lemma iter_mk_t : forall A (f:forall n, dom_t n -> A),
 forall n x, iter_t f (mk_t n x) = f n x.
 Proof.
 do_size (destruct n; try reflexivity).
 Qed.

 (** * Projection to ZArith *)

 Definition to_Z : t -> Z :=
  Eval lazy beta iota delta [iter_t dom_t dom_op] in
  iter_t (fun _ x => ZnZ.to_Z x).

 Notation "[ x ]" := (to_Z x).

 Theorem spec_mk_t : forall n (x:dom_t n), [mk_t n x] = ZnZ.to_Z x.
 Proof.
 intros. change to_Z with (iter_t (fun _ x => ZnZ.to_Z x)).
 rewrite iter_mk_t; auto.
 Qed.

 (** * Regular make op, without memoization or karatsuba

     This will normally never be used for actual computations,
     but only for specification purpose when using
     [word (dom_t n) m] intermediate values. *)

 Fixpoint nmake_op (ww:Type) (ww_op: ZnZ.Ops ww) (n: nat) :
       ZnZ.Ops (word ww n) :=
  match n return ZnZ.Ops (word ww n) with
   O => ww_op
  | S n1 => mk_zn2z_ops (nmake_op ww ww_op n1)
  end.

 Definition eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m).

 Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x,
   nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x).
 Proof.
 auto.
 Qed.

 Theorem digits_nmake_S :forall n ww (w_op: ZnZ.Ops ww),
    ZnZ.digits (nmake_op _ w_op (S n)) =
    xO (ZnZ.digits (nmake_op _ w_op n)).
 Proof.
 auto.
 Qed.

 Theorem digits_nmake : forall n ww (w_op: ZnZ.Ops ww),
    ZnZ.digits (nmake_op _ w_op n) = Pos.shiftl_nat (ZnZ.digits w_op) n.
 Proof.
 induction n. auto.
 intros ww ww_op. rewrite Pshiftl_nat_S, <- IHn; auto.
 Qed.

 Theorem nmake_double: forall n ww (w_op: ZnZ.Ops ww),
    ZnZ.to_Z (Ops:=nmake_op _ w_op n) =
    @DoubleBase.double_to_Z _ (ZnZ.digits w_op) (ZnZ.to_Z (Ops:=w_op)) n.
 Proof.
 intros n; elim n; auto; clear n.
 intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z.
 rewrite <- Hrec; auto.
 unfold DoubleBase.double_wB; rewrite <- digits_nmake; auto.
 Qed.

 Theorem nmake_WW: forall ww ww_op n xh xl,
  (ZnZ.to_Z (Ops:=nmake_op ww ww_op (S n)) (WW xh xl) =
   ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xh *
    base (ZnZ.digits (nmake_op ww ww_op n)) +
   ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xl)%Z.
 Proof.
 auto.
 Qed.

 (** * The specification proofs for the word operators *)

 Typeclasses Opaque w1 w2 w3 w4 w5 w6.

 Instance w0_spec: ZnZ.Specs w0_op := W0.specs.
 Instance w1_spec: ZnZ.Specs w1_op := mk_zn2z_specs w0_spec.
 Instance w2_spec: ZnZ.Specs w2_op := mk_zn2z_specs w1_spec.
 Instance w3_spec: ZnZ.Specs w3_op := mk_zn2z_specs w2_spec.
 Instance w4_spec: ZnZ.Specs w4_op := mk_zn2z_specs_karatsuba w3_spec.
 Instance w5_spec: ZnZ.Specs w5_op := mk_zn2z_specs_karatsuba w4_spec.
 Instance w6_spec: ZnZ.Specs w6_op := mk_zn2z_specs_karatsuba w5_spec.
 Instance w7_spec: ZnZ.Specs w7_op := mk_zn2z_specs_karatsuba w6_spec.

 Instance wn_spec (n:nat) : ZnZ.Specs (make_op n).
 Proof.
  induction n.
  rewrite make_op_omake; simpl; auto with *.
  rewrite make_op_S. exact (mk_zn2z_specs_karatsuba IHn).
 Qed.

 Instance dom_spec n : ZnZ.Specs (dom_op n) | 10.
 Proof.
  do_size (destruct n; auto with *). apply wn_spec.
 Qed.

 Let make_op_WW : forall n x y,
   (ZnZ.to_Z (Ops:=make_op (S n)) (WW x y) =
    ZnZ.to_Z (Ops:=make_op n) x * base (ZnZ.digits (make_op n))
     + ZnZ.to_Z (Ops:=make_op n) y)%Z.
 Proof.
 intros n x y; rewrite make_op_S; auto.
 Qed.

 (** * Zero *)

 Definition zero0 : w0 := ZnZ.zero.

 Definition zeron n : dom_t n :=
  match n with
   | O => zero0
   | SizePlus (S n) => W0
   | _ => W0
  end.

 Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%Z.
 Proof.
   do_size (destruct n;
            [match goal with
             |- @eq Z (_ (zeron ?n)) _ =>
               apply (ZnZ.spec_0 (Specs:=dom_spec n))
             end|]).
  destruct n; auto. simpl. rewrite make_op_S. fold word.
  apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))).
 Qed.

 (** * Digits *)

 Lemma digits_make_op_0 : forall n,
  ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op Size)) (S n).
 Proof.
 induction n.
 auto.
 replace (ZnZ.digits (make_op (S n))) with (xO (ZnZ.digits (make_op n))).
  rewrite IHn; auto.
 rewrite make_op_S; auto.
 Qed.

 Lemma digits_make_op : forall n,
  ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) (SizePlus (S n)).
 Proof.
 intros. rewrite digits_make_op_0.
 replace (SizePlus (S n)) with (S n + Size) by (rewrite <- plus_comm; auto).
 rewrite Pshiftl_nat_plus. auto.
 Qed.

 Lemma digits_dom_op : forall n,
  ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) n.
 Proof.
 do_size (destruct n; try reflexivity).
 exact (digits_make_op n).
 Qed.

 Lemma digits_dom_op_nmake : forall n m,
  ZnZ.digits (dom_op (m+n)) = ZnZ.digits (nmake_op _ (dom_op n) m).
 Proof.
 intros. rewrite digits_nmake, 2 digits_dom_op. apply Pshiftl_nat_plus.
 Qed.

 (** * Conversion between [zn2z (dom_t n)] and [dom_t (S n)].

     These two types are provably equal, but not convertible,
     hence we need some work. We now avoid using generic casts
     (i.e. rewrite via proof of equalities in types), since
     proving things with them is a mess.
 *)

 Definition succ_t n : zn2z (dom_t n) -> dom_t (S n) :=
  match n with
   | SizePlus (S _) => fun x => x
   | _ => fun x => x
  end.

 Lemma spec_succ_t : forall n x,
  ZnZ.to_Z (succ_t n x) =
  zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.
 Proof.
 do_size (destruct n ; [reflexivity|]).
 intros. simpl. rewrite make_op_S. simpl. auto.
 Qed.

 Definition pred_t n : dom_t (S n) -> zn2z (dom_t n) :=
  match n with
   | SizePlus (S _) => fun x => x
   | _ => fun x => x
  end.

 Lemma succ_pred_t : forall n x, succ_t n (pred_t n x) = x.
 Proof.
 do_size (destruct n ; [reflexivity|]). reflexivity.
 Qed.

 (** We can hence project from [zn2z (dom_t n)] to [t] : *)

 Definition mk_t_S n (x : zn2z (dom_t n)) : t :=
  mk_t (S n) (succ_t n x).

 Lemma spec_mk_t_S : forall n x,
  [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.
 Proof.
 intros. unfold mk_t_S. rewrite spec_mk_t. apply spec_succ_t.
 Qed.

 Lemma mk_t_S_level : forall n x, level (mk_t_S n x) = S n.
 Proof.
 intros. unfold mk_t_S, level. rewrite iter_mk_t; auto.
 Qed.

 (** * Conversion from [word (dom_t n) m] to [dom_t (m+n)].

     Things are more complex here. We start with a naive version
     that breaks zn2z-trees and reconstruct them. Doing this is
     quite unfortunate, but I don't know how to fully avoid that.
     (cast someday ?). Then we build an optimized version where
     all basic cases (n<=6 or m<=7) are nicely handled.
 *)

 Definition zn2z_map {A} {B} (f:A->B) (x:zn2z A) : zn2z B :=
  match x with
   | W0 => W0
   | WW h l => WW (f h) (f l)
  end.

 Lemma zn2z_map_id : forall A f (x:zn2z A), (forall u, f u = u) ->
   zn2z_map f x = x.
 Proof.
  destruct x; auto; intros.
  simpl; f_equal; auto.
 Qed.

 (** The naive version *)

 Fixpoint plus_t n m : word (dom_t n) m -> dom_t (m+n) :=
  match m as m' return word (dom_t n) m' -> dom_t (m'+n) with
   | O => fun x => x
   | S m => fun x => succ_t _ (zn2z_map (plus_t n m) x)
  end.

 Theorem spec_plus_t : forall n m (x:word (dom_t n) m),
  ZnZ.to_Z (plus_t n m x) = eval n m x.
 Proof.
 unfold eval.
 induction m.
 simpl; auto.
 intros.
 simpl plus_t; simpl plus. rewrite spec_succ_t.
 destruct x.
 simpl; auto.
 fold word in w, w0.
 simpl. rewrite 2 IHm. f_equal. f_equal. f_equal.
 apply digits_dom_op_nmake.
 Qed.

 Definition mk_t_w n m (x:word (dom_t n) m) : t :=
   mk_t (m+n) (plus_t n m x).

 Theorem spec_mk_t_w : forall n m (x:word (dom_t n) m),
  [mk_t_w n m x] = eval n m x.
 Proof.
 intros. unfold mk_t_w. rewrite spec_mk_t. apply spec_plus_t.
 Qed.

 (** The optimized version.

     NB: the last particular case for m could depend on n,
     but it's simplier to just expand everywhere up to m=7
     (cf [mk_t_w'] later).
 *)

 Definition plus_t' n : forall m, word (dom_t n) m -> dom_t (m+n) :=
   match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with
     | SizePlus (S n') as n => plus_t n
     | _ as n =>
         fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with
                    | SizePlus (S (S m')) as m => plus_t n m
                    | _ => fun x => x
                  end
   end.

 Lemma plus_t_equiv : forall n m x,
  plus_t' n m x = plus_t n m x.
 Proof.
  (do_size try destruct n); try reflexivity;
   (do_size try destruct m); try destruct m; try reflexivity;
     simpl; symmetry; repeat (intros; apply zn2z_map_id; trivial).
 Qed.

 Lemma spec_plus_t' : forall n m x,
  ZnZ.to_Z (plus_t' n m x) = eval n m x.
 Proof.
 intros; rewrite plus_t_equiv. apply spec_plus_t.
 Qed.

 (** Particular cases [Nk x] = eval i j x with specific k,i,j
     can be solved by the following tactic *)

 Ltac solve_eval :=
  intros; rewrite <- spec_plus_t'; unfold to_Z; simpl dom_op; reflexivity.

 (** The last particular case that remains useful *)

 Lemma spec_eval_size : forall n x, [Nn n x] = eval Size (S n) x.
 Proof.
 induction n.
 solve_eval.
 destruct x as [ | xh xl ].
  simpl. unfold eval. rewrite make_op_S. rewrite nmake_op_S. auto.
 simpl word in xh, xl |- *.
 unfold to_Z in *. rewrite make_op_WW.
 unfold eval in *. rewrite nmake_WW.
 f_equal; auto.
 f_equal; auto.
 f_equal.
 rewrite <- digits_dom_op_nmake. rewrite plus_comm; auto.
 Qed.

 (** An optimized [mk_t_w].

     We could say mk_t_w' := mk_t _ (plus_t' n m x)
     (TODO: WHY NOT, BTW ??).
     Instead we directly define functions for all intersting [n],
     reverting to naive [mk_t_w] at places that should normally
     never be used (see [mul] and [div_gt]).
 *)

 Definition mk_t_0w m := Eval cbv beta zeta iota delta [ mk_t plus ] in
  match m return word w0 (S m) -> t with
    | (S (S (S (S (S (S (S _))))))) as p => mk_t_w 0 (S p)
    | p => mk_t (1+p)
  end.

 Definition mk_t_1w m := Eval cbv beta zeta iota delta [ mk_t plus ] in
  match m return word w1 (S m) -> t with
    | (S (S (S (S (S (S _)))))) as p => mk_t_w 1 (S p)
    | p => mk_t (2+p)
  end.

 Definition mk_t_2w m := Eval cbv beta zeta iota delta [ mk_t plus ] in
  match m return word w2 (S m) -> t with
    | (S (S (S (S (S _))))) as p => mk_t_w 2 (S p)
    | p => mk_t (3+p)
  end.

 Definition mk_t_3w m := Eval cbv beta zeta iota delta [ mk_t plus ] in
  match m return word w3 (S m) -> t with
    | (S (S (S (S _)))) as p => mk_t_w 3 (S p)
    | p => mk_t (4+p)
  end.

 Definition mk_t_4w m := Eval cbv beta zeta iota delta [ mk_t plus ] in
  match m return word w4 (S m) -> t with
    | (S (S (S _))) as p => mk_t_w 4 (S p)
    | p => mk_t (5+p)
  end.

 Definition mk_t_5w m := Eval cbv beta zeta iota delta [ mk_t plus ] in
  match m return word w5 (S m) -> t with
    | (S (S _)) as p => mk_t_w 5 (S p)
    | p => mk_t (6+p)
  end.

 Definition mk_t_w' n : forall m, word (dom_t n) (S m) -> t :=
  match n return (forall m, word (dom_t n) (S m) -> t) with
    | 0 => mk_t_0w
    | 1 => mk_t_1w
    | 2 => mk_t_2w
    | 3 => mk_t_3w
    | 4 => mk_t_4w
    | 5 => mk_t_5w
    | Size => Nn
    | _ as n' => fun m => mk_t_w n' (S m)
  end.

 Ltac solve_spec_mk_t_w' :=
  rewrite <- spec_plus_t';
  match goal with _ : word (dom_t ?n) ?m |- _ => apply (spec_mk_t (n+m)) end.

 Theorem spec_mk_t_w' :
  forall n m x, [mk_t_w' n m x] = eval n (S m) x.
 Proof.
 intros.
 repeat (apply spec_mk_t_w || (destruct n;
  [repeat (apply spec_mk_t_w || (destruct m; [solve_spec_mk_t_w'|]))|])).
 apply spec_eval_size.
 Qed.

 (** * Extend : injecting [dom_t n] into [word (dom_t n) (S m)] *)

 Definition extend n m (x:dom_t n) : word (dom_t n) (S m) :=
  DoubleBase.extend_aux m (WW (zeron n) x).

 Lemma spec_extend : forall n m x,
  [mk_t n x] = eval n (S m) (extend n m x).
 Proof.
 intros. unfold eval, extend.
 rewrite spec_mk_t.
 assert (H : forall (x:dom_t n),
              (ZnZ.to_Z (zeron n) * base (ZnZ.digits (dom_op n)) + ZnZ.to_Z x =
              ZnZ.to_Z x)%Z).
  clear; intros; rewrite spec_zeron; auto.
 rewrite <- (@DoubleBase.spec_extend _
              (WW (zeron n)) (ZnZ.digits (dom_op n)) ZnZ.to_Z H m x).
 simpl. rewrite digits_nmake, <- nmake_double. auto.
 Qed.

 (** A particular case of extend, used in [same_level]:
     [extend_size] is [extend Size] *)

 Definition extend_size := DoubleBase.extend (WW (W0:dom_t Size)).

 Lemma spec_extend_size : forall n x, [mk_t Size x] = [Nn n (extend_size n x)].
 Proof.
 intros. rewrite spec_eval_size. apply (spec_extend Size n).
 Qed.

 (** Misc results about extensions *)

 Let spec_extend_WW : forall n x,
  [Nn (S n) (WW W0 x)] = [Nn n x].
 Proof.
 intros n x.
 set (N:=SizePlus (S n)).
 change ([Nn (S n) (extend N 0 x)]=[mk_t N x]).
 rewrite (spec_extend N 0).
 solve_eval.
 Qed.

 Let spec_extend_tr: forall m n w,
 [Nn (m + n) (extend_tr w m)] = [Nn n w].
 Proof.
 induction m; auto.
 intros n x; simpl extend_tr.
 simpl plus; rewrite spec_extend_WW; auto.
 Qed.

 Let spec_cast_l: forall n m x1,
 [Nn n x1] =
 [Nn (Max.max n m) (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))].
 Proof.
 intros n m x1; case (diff_r n m); simpl castm.
 rewrite spec_extend_tr; auto.
 Qed.

 Let spec_cast_r: forall n m x1,
 [Nn m x1] =
 [Nn (Max.max n m) (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))].
 Proof.
 intros n m x1; case (diff_l n m); simpl castm.
 rewrite spec_extend_tr; auto.
 Qed.

 Ltac unfold_lets :=
  match goal with
   | h : _ |- _ => unfold h; clear h; unfold_lets
   | _ => idtac
  end.

 (** * [same_level]

     Generic binary operator construction, by extending the smaller
     argument to the level of the other.
 *)

 Section SameLevel.

  Variable res: Type.
  Variable P : Z -> Z -> res -> Prop.
  Variable f : forall n, dom_t n -> dom_t n -> res.
  Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y).

  Let f0 : w0 -> w0 -> res := f 0.
  Let f1 : w1 -> w1 -> res := f 1.
  Let f2 : w2 -> w2 -> res := f 2.
  Let f3 : w3 -> w3 -> res := f 3.
  Let f4 : w4 -> w4 -> res := f 4.
  Let f5 : w5 -> w5 -> res := f 5.
  Let f6 : w6 -> w6 -> res := f 6.
  Let fn n := f (SizePlus (S n)).

  Let Pf' :
   forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y).
  Proof.
  intros. subst. rewrite 2 spec_mk_t. apply Pf.
  Qed.

  Notation same_level_folded := (fun x y => match x, y with
  | N0 wx, N0 wy => f0 wx wy
  | N0 wx, N1 wy => f1 (extend 0 0 wx) wy
  | N0 wx, N2 wy => f2 (extend 0 1 wx) wy
  | N0 wx, N3 wy => f3 (extend 0 2 wx) wy
  | N0 wx, N4 wy => f4 (extend 0 3 wx) wy
  | N0 wx, N5 wy => f5 (extend 0 4 wx) wy
  | N0 wx, N6 wy => f6 (extend 0 5 wx) wy
  | N0 wx, Nn m wy => fn m (extend_size m (extend 0 5 wx)) wy
  | N1 wx, N0 wy => f1 wx (extend 0 0 wy)
  | N1 wx, N1 wy => f1 wx wy
  | N1 wx, N2 wy => f2 (extend 1 0 wx) wy
  | N1 wx, N3 wy => f3 (extend 1 1 wx) wy
  | N1 wx, N4 wy => f4 (extend 1 2 wx) wy
  | N1 wx, N5 wy => f5 (extend 1 3 wx) wy
  | N1 wx, N6 wy => f6 (extend 1 4 wx) wy
  | N1 wx, Nn m wy => fn m (extend_size m (extend 1 4 wx)) wy
  | N2 wx, N0 wy => f2 wx (extend 0 1 wy)
  | N2 wx, N1 wy => f2 wx (extend 1 0 wy)
  | N2 wx, N2 wy => f2 wx wy
  | N2 wx, N3 wy => f3 (extend 2 0 wx) wy
  | N2 wx, N4 wy => f4 (extend 2 1 wx) wy
  | N2 wx, N5 wy => f5 (extend 2 2 wx) wy
  | N2 wx, N6 wy => f6 (extend 2 3 wx) wy
  | N2 wx, Nn m wy => fn m (extend_size m (extend 2 3 wx)) wy
  | N3 wx, N0 wy => f3 wx (extend 0 2 wy)
  | N3 wx, N1 wy => f3 wx (extend 1 1 wy)
  | N3 wx, N2 wy => f3 wx (extend 2 0 wy)
  | N3 wx, N3 wy => f3 wx wy
  | N3 wx, N4 wy => f4 (extend 3 0 wx) wy
  | N3 wx, N5 wy => f5 (extend 3 1 wx) wy
  | N3 wx, N6 wy => f6 (extend 3 2 wx) wy
  | N3 wx, Nn m wy => fn m (extend_size m (extend 3 2 wx)) wy
  | N4 wx, N0 wy => f4 wx (extend 0 3 wy)
  | N4 wx, N1 wy => f4 wx (extend 1 2 wy)
  | N4 wx, N2 wy => f4 wx (extend 2 1 wy)
  | N4 wx, N3 wy => f4 wx (extend 3 0 wy)
  | N4 wx, N4 wy => f4 wx wy
  | N4 wx, N5 wy => f5 (extend 4 0 wx) wy
  | N4 wx, N6 wy => f6 (extend 4 1 wx) wy
  | N4 wx, Nn m wy => fn m (extend_size m (extend 4 1 wx)) wy
  | N5 wx, N0 wy => f5 wx (extend 0 4 wy)
  | N5 wx, N1 wy => f5 wx (extend 1 3 wy)
  | N5 wx, N2 wy => f5 wx (extend 2 2 wy)
  | N5 wx, N3 wy => f5 wx (extend 3 1 wy)
  | N5 wx, N4 wy => f5 wx (extend 4 0 wy)
  | N5 wx, N5 wy => f5 wx wy
  | N5 wx, N6 wy => f6 (extend 5 0 wx) wy
  | N5 wx, Nn m wy => fn m (extend_size m (extend 5 0 wx)) wy
  | N6 wx, N0 wy => f6 wx (extend 0 5 wy)
  | N6 wx, N1 wy => f6 wx (extend 1 4 wy)
  | N6 wx, N2 wy => f6 wx (extend 2 3 wy)
  | N6 wx, N3 wy => f6 wx (extend 3 2 wy)
  | N6 wx, N4 wy => f6 wx (extend 4 1 wy)
  | N6 wx, N5 wy => f6 wx (extend 5 0 wy)
  | N6 wx, N6 wy => f6 wx wy
  | N6 wx, Nn m wy => fn m (extend_size m wx) wy
  | Nn n wx, N0 wy => fn n wx (extend_size n (extend 0 5 wy))
  | Nn n wx, N1 wy => fn n wx (extend_size n (extend 1 4 wy))
  | Nn n wx, N2 wy => fn n wx (extend_size n (extend 2 3 wy))
  | Nn n wx, N3 wy => fn n wx (extend_size n (extend 3 2 wy))
  | Nn n wx, N4 wy => fn n wx (extend_size n (extend 4 1 wy))
  | Nn n wx, N5 wy => fn n wx (extend_size n (extend 5 0 wy))
  | Nn n wx, N6 wy => fn n wx (extend_size n wy)
  | Nn n wx, Nn m wy =>
    let mn := Max.max n m in
    let d := diff n m in
     fn mn
       (castm (diff_r n m) (extend_tr wx (snd d)))
       (castm (diff_l n m) (extend_tr wy (fst d)))
  end).

  Definition same_level := Eval lazy beta iota delta
   [ DoubleBase.extend DoubleBase.extend_aux extend zeron ]
  in same_level_folded.

  Lemma spec_same_level_0: forall x y, P [x] [y] (same_level x y).
  Proof.
  change same_level with same_level_folded. unfold_lets.
  destruct x, y; apply Pf'; simpl mk_t; rewrite <- ?spec_extend_size;
  match goal with
   | |- context [ extend ?n ?m _ ] => apply (spec_extend n m)
   | |- context [ castm _ _ ] => apply spec_cast_l || apply spec_cast_r
   | _ => reflexivity
  end.
  Qed.

 End SameLevel.

 Arguments same_level [res] f x y.

 Theorem spec_same_level_dep :
  forall res
   (P : nat -> Z -> Z -> res -> Prop)
   (Pantimon : forall n m z z' r, n <= m -> P m z z' r -> P n z z' r)
   (f : forall n, dom_t n -> dom_t n -> res)
   (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)),
   forall x y, P (level x) [x] [y] (same_level f x y).
 Proof.
 intros res P Pantimon f Pf.
 set (f' := fun n x y => (n, f n x y)).
 set (P' := fun z z' r => P (fst r) z z' (snd r)).
 assert (FST : forall x y, level x <= fst (same_level f' x y))
  by (destruct x, y; simpl; omega with * ).
 assert (SND : forall x y, same_level f x y = snd (same_level f' x y))
  by (destruct x, y; reflexivity).
 intros. eapply Pantimon; [eapply FST|].
 rewrite SND. eapply (@spec_same_level_0 _ P' f'); eauto.
 Qed.

 (** * [iter]

     Generic binary operator construction, by splitting the larger
     argument in blocks and applying the smaller argument to them.
 *)

 Section Iter.

  Variable res: Type.
  Variable P: Z -> Z -> res -> Prop.

  Variable f : forall n, dom_t n -> dom_t n -> res.
  Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y).

  Variable fd : forall n m, dom_t n -> word (dom_t n) (S m) -> res.
  Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res.
  Variable Pfd : forall n m x y, P (ZnZ.to_Z x) (eval n (S m) y) (fd n m x y).
  Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y).

  Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res.
  Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y).

  Let Pf' :
   forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y).
  Proof.
  intros. subst. rewrite 2 spec_mk_t. apply Pf.
  Qed.

  Let Pfd' : forall n m x y u v, u = [mk_t n x] -> v = eval n (S m) y ->
   P u v (fd n m x y).
  Proof.
  intros. subst. rewrite spec_mk_t. apply Pfd.
  Qed.

  Let Pfg' : forall n m x y u v, u = eval n (S m) x -> v = [mk_t n y] ->
   P u v (fg n m x y).
  Proof.
  intros. subst. rewrite spec_mk_t. apply Pfg.
  Qed.

  Let f0 := f 0.
  Let f1 := f 1.
  Let f2 := f 2.
  Let f3 := f 3.
  Let f4 := f 4.
  Let f5 := f 5.
  Let f6 := f 6.
  Let f0n := fd 0.
  Let fn0 := fg 0.
  Let f1n := fd 1.
  Let fn1 := fg 1.
  Let f2n := fd 2.
  Let fn2 := fg 2.
  Let f3n := fd 3.
  Let fn3 := fg 3.
  Let f4n := fd 4.
  Let fn4 := fg 4.
  Let f5n := fd 5.
  Let fn5 := fg 5.
  Let f6n := fd 6.
  Let fn6 := fg 6.
  Notation iter_folded := (fun x y => match x, y with
  | N0 wx, N0 wy => f0 wx wy
  | N0 wx, N1 wy => f0n 0 wx wy
  | N0 wx, N2 wy => f0n 1 wx wy
  | N0 wx, N3 wy => f0n 2 wx wy
  | N0 wx, N4 wy => f0n 3 wx wy
  | N0 wx, N5 wy => f0n 4 wx wy
  | N0 wx, N6 wy => f0n 5 wx wy
  | N0 wx, Nn m wy => f6n m (extend 0 5 wx) wy
  | N1 wx, N0 wy => fn0 0 wx wy
  | N1 wx, N1 wy => f1 wx wy
  | N1 wx, N2 wy => f1n 0 wx wy
  | N1 wx, N3 wy => f1n 1 wx wy
  | N1 wx, N4 wy => f1n 2 wx wy
  | N1 wx, N5 wy => f1n 3 wx wy
  | N1 wx, N6 wy => f1n 4 wx wy
  | N1 wx, Nn m wy => f6n m (extend 1 4 wx) wy
  | N2 wx, N0 wy => fn0 1 wx wy
  | N2 wx, N1 wy => fn1 0 wx wy
  | N2 wx, N2 wy => f2 wx wy
  | N2 wx, N3 wy => f2n 0 wx wy
  | N2 wx, N4 wy => f2n 1 wx wy
  | N2 wx, N5 wy => f2n 2 wx wy
  | N2 wx, N6 wy => f2n 3 wx wy
  | N2 wx, Nn m wy => f6n m (extend 2 3 wx) wy
  | N3 wx, N0 wy => fn0 2 wx wy
  | N3 wx, N1 wy => fn1 1 wx wy
  | N3 wx, N2 wy => fn2 0 wx wy
  | N3 wx, N3 wy => f3 wx wy
  | N3 wx, N4 wy => f3n 0 wx wy
  | N3 wx, N5 wy => f3n 1 wx wy
  | N3 wx, N6 wy => f3n 2 wx wy
  | N3 wx, Nn m wy => f6n m (extend 3 2 wx) wy
  | N4 wx, N0 wy => fn0 3 wx wy
  | N4 wx, N1 wy => fn1 2 wx wy
  | N4 wx, N2 wy => fn2 1 wx wy
  | N4 wx, N3 wy => fn3 0 wx wy
  | N4 wx, N4 wy => f4 wx wy
  | N4 wx, N5 wy => f4n 0 wx wy
  | N4 wx, N6 wy => f4n 1 wx wy
  | N4 wx, Nn m wy => f6n m (extend 4 1 wx) wy
  | N5 wx, N0 wy => fn0 4 wx wy
  | N5 wx, N1 wy => fn1 3 wx wy
  | N5 wx, N2 wy => fn2 2 wx wy
  | N5 wx, N3 wy => fn3 1 wx wy
  | N5 wx, N4 wy => fn4 0 wx wy
  | N5 wx, N5 wy => f5 wx wy
  | N5 wx, N6 wy => f5n 0 wx wy
  | N5 wx, Nn m wy => f6n m (extend 5 0 wx) wy
  | N6 wx, N0 wy => fn0 5 wx wy
  | N6 wx, N1 wy => fn1 4 wx wy
  | N6 wx, N2 wy => fn2 3 wx wy
  | N6 wx, N3 wy => fn3 2 wx wy
  | N6 wx, N4 wy => fn4 1 wx wy
  | N6 wx, N5 wy => fn5 0 wx wy
  | N6 wx, N6 wy => f6 wx wy
  | N6 wx, Nn m wy => f6n m wx wy
  | Nn n wx, N0 wy => fn6 n wx (extend 0 5 wy)
  | Nn n wx, N1 wy => fn6 n wx (extend 1 4 wy)
  | Nn n wx, N2 wy => fn6 n wx (extend 2 3 wy)
  | Nn n wx, N3 wy => fn6 n wx (extend 3 2 wy)
  | Nn n wx, N4 wy => fn6 n wx (extend 4 1 wy)
  | Nn n wx, N5 wy => fn6 n wx (extend 5 0 wy)
  | Nn n wx, N6 wy => fn6 n wx wy
  | Nn n wx, Nn m wy => fnm n m wx wy
  end).

  Definition iter := Eval lazy beta iota delta
   [extend DoubleBase.extend DoubleBase.extend_aux zeron]
   in iter_folded.

  Lemma spec_iter: forall x y, P [x] [y] (iter x y).
  Proof.
  change iter with iter_folded; unfold_lets.
  destruct x; destruct y; apply Pf' || apply Pfd' || apply Pfg' || apply Pfnm;
  simpl mk_t;
  match goal with
   | |- ?x = ?x => reflexivity
   | |- [Nn _ _] = _ => apply spec_eval_size
   | |- context [extend ?n ?m _] => apply (spec_extend n m)
   | _ => idtac
  end;
  unfold to_Z; rewrite <- spec_plus_t'; simpl dom_op; reflexivity.
  Qed.

  End Iter.

  Definition switch
  (P:nat->Type)(f0:P 0)(f1:P 1)(f2:P 2)(f3:P 3)(f4:P 4)(f5:P 5)(f6:P 6)
  (fn:forall n, P n) n :=
  match n return P n with
   | 0 => f0
   | 1 => f1
   | 2 => f2
   | 3 => f3
   | 4 => f4
   | 5 => f5
   | 6 => f6
   | n => fn n
  end.

  Lemma spec_switch : forall P (f:forall n, P n) n,
   switch P (f 0) (f 1) (f 2) (f 3) (f 4) (f 5) (f 6) f n = f n.
  Proof.
  repeat (destruct n; try reflexivity).
  Qed.

  (** * [iter_sym]

    A variant of [iter] for symmetric functions, or pseudo-symmetric
    functions (when f y x can be deduced from f x y).
  *)

  Section IterSym.

  Variable res: Type.
  Variable P: Z -> Z -> res -> Prop.

  Variable f : forall n, dom_t n -> dom_t n -> res.
  Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y).

  Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res.
  Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y).

  Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res.
  Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y).

  Variable opp: res -> res.
  Variable Popp : forall u v r, P u v r -> P v u (opp r).

  Let f0 := f 0.
  Let f1 := f 1.
  Let f2 := f 2.
  Let f3 := f 3.
  Let f4 := f 4.
  Let f5 := f 5.
  Let f6 := f 6.
  Let fn0 := fg 0.
  Let fn1 := fg 1.
  Let fn2 := fg 2.
  Let fn3 := fg 3.
  Let fn4 := fg 4.
  Let fn5 := fg 5.
  Let fn6 := fg 6.
  Let f' := switch _ f0 f1 f2 f3 f4 f5 f6 f.
  Let fg' := switch _ fn0 fn1 fn2 fn3 fn4 fn5 fn6 fg.
  Local Notation iter_sym_folded :=
   (iter res f' (fun n m x y => opp (fg' n m y x)) fg' fnm).

  Definition iter_sym :=
   Eval lazy beta zeta iota delta [iter f' fg' switch] in iter_sym_folded.

  Lemma spec_iter_sym: forall x y, P [x] [y] (iter_sym x y).
  Proof.
  intros. change iter_sym with iter_sym_folded. apply spec_iter; clear x y.
  unfold_lets.
  intros. rewrite spec_switch. auto.
  intros. apply Popp. unfold_lets. rewrite spec_switch; auto.
  intros. unfold_lets. rewrite spec_switch; auto.
  auto.
  Qed.

  End IterSym.

 (** * Reduction

     [reduce] can be used instead of [mk_t], it will choose the
     lowest possible level. NB: We only search and remove leftmost
     W0's via ZnZ.eq0, any non-W0 block ends the process, even
     if its value is 0.
 *)

 (** First, a direct version ... *)

 Fixpoint red_t n : dom_t n -> t :=
  match n return dom_t n -> t with
   | O => N0
   | S n => fun x =>
     let x' := pred_t n x in
     reduce_n1 _ _ (N0 zero0) ZnZ.eq0 (red_t n) (mk_t_S n) x'
  end.

 Lemma spec_red_t : forall n x, [red_t n x] = [mk_t n x].
 Proof.
 induction n.
 reflexivity.
 intros.
 simpl red_t. unfold reduce_n1.
 rewrite <- (succ_pred_t n x) at 2.
 remember (pred_t n x) as x'.
 rewrite spec_mk_t, spec_succ_t.
 destruct x' as [ | xh xl]. simpl. apply ZnZ.spec_0.
 generalize (ZnZ.spec_eq0 xh); case ZnZ.eq0; intros H.
 rewrite IHn, spec_mk_t. simpl. rewrite H; auto.
 apply spec_mk_t_S.
 Qed.

 (** ... then a specialized one *)

 Definition eq00 := @ZnZ.eq0 _ w0_op.
 Definition eq01 := @ZnZ.eq0 _ w1_op.
 Definition eq02 := @ZnZ.eq0 _ w2_op.
 Definition eq03 := @ZnZ.eq0 _ w3_op.
 Definition eq04 := @ZnZ.eq0 _ w4_op.
 Definition eq05 := @ZnZ.eq0 _ w5_op.
 Definition eq06 := @ZnZ.eq0 _ w6_op.

 Definition reduce_0 := N0.
 Definition reduce_1 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq00 reduce_0 N1.
 Definition reduce_2 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq01 reduce_1 N2.
 Definition reduce_3 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq02 reduce_2 N3.
 Definition reduce_4 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq03 reduce_3 N4.
 Definition reduce_5 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq04 reduce_4 N5.
 Definition reduce_6 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq05 reduce_5 N6.
 Definition reduce_7 :=
  Eval lazy beta iota delta [reduce_n1] in
   reduce_n1 _ _ (N0 zero0) eq06 reduce_6 (Nn 0).
 Definition reduce_n n :=
  Eval lazy beta iota delta [reduce_n] in
   reduce_n _ _ (N0 zero0) reduce_7 Nn n.

 Definition reduce n : dom_t n -> t :=
  match n with
   | 0 => reduce_0
   | 1 => reduce_1
   | 2 => reduce_2
   | 3 => reduce_3
   | 4 => reduce_4
   | 5 => reduce_5
   | 6 => reduce_6
   | SizePlus (S n) => reduce_n n
  end.

 Ltac unfold_red := unfold reduce, reduce_1, reduce_2, reduce_3, reduce_4, reduce_5, reduce_6.

 Declare Equivalent Keys reduce reduce_0.
 Declare Equivalent Keys reduce reduce_1.
 Declare Equivalent Keys reduce reduce_2.
 Declare Equivalent Keys reduce reduce_3.
 Declare Equivalent Keys reduce reduce_4.
 Declare Equivalent Keys reduce reduce_5.
 Declare Equivalent Keys reduce reduce_6.
 Declare Equivalent Keys reduce_n reduce_7.

 Ltac solve_red :=
 let H := fresh in let G := fresh in
 match goal with
  | |- ?P (S ?n) => assert (H:P n) by solve_red
  | _ => idtac
 end;
 intros n G x; destruct (le_lt_eq_dec _ _ G) as [LT|EQ];
 solve [
  apply (H _ (lt_n_Sm_le _ _ LT)) |
  inversion LT |
  subst; change (reduce 0 x = red_t 0 x); reflexivity |
  specialize (H (pred n)); subst; destruct x;
   [|unfold_red; rewrite H; auto]; reflexivity
 ].

 Lemma reduce_equiv : forall n x, n <= Size -> reduce n x = red_t n x.
 Proof.
 set (P N := forall n, n <= N -> forall x, reduce n x = red_t n x).
 intros n x H. revert n H x. change (P Size). solve_red.
 Qed.

 Lemma spec_reduce_n : forall n x, [reduce_n n x] = [Nn n x].
 Proof.
 assert (H : forall x, reduce_7 x = red_t (SizePlus 1) x).
  destruct x; [|unfold reduce_7; rewrite (reduce_equiv Size)]; auto.
 induction n.
   intros. rewrite H. apply spec_red_t.
 destruct x as [|xh xl].
 simpl. rewrite make_op_S. exact ZnZ.spec_0.
 fold word in *.
 destruct xh; auto.
 simpl reduce_n.
 rewrite IHn.
 rewrite spec_extend_WW; auto.
 Qed.

 Lemma spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x.
 Proof.
 do_size (destruct n;
       [intros; rewrite reduce_equiv;[apply spec_red_t|auto with arith]|]).
 apply spec_reduce_n.
 Qed.

End Make.


Require Import util c_util.
Require abstract abstract_as_graph.
Require Import Program.

Require hybrid.examples.unbounded_rotator.conc hybrid.examples.unbounded_rotator.abs.
Module conc := unbounded_rotator.conc.
Module abs := unbounded_rotator.abs.

Theorem unsafe_unreachable: conc.UnsafeUnreachable.
Proof with eauto.
  repeat intro.
  cut (~ exists s, unbounded_rotator.conc.unsafe s /\ concrete.reachable s)...
  assert (forall s, unbounded_rotator.conc.unsafe s -> forall r,
   abstract.abs s r -> In r (` (unbounded_rotator.abs.unsafe_abstract centi))).
    destruct abs.unsafe_abstract...
  apply (overestimation_false (@abstract_as_graph.some_reachable _ _ (abs.system centi) conc.unsafe (abs.unsafe_abstract centi))).
  Time vm_compute. reflexivity.
Qed.

Print Assumptions unsafe_unreachable.


Require Import Fiat.ADT Fiat.ADTNotation.

Require Import Fiat.Narcissus.Examples.Guard.Core.
Require Export Fiat.Narcissus.Examples.Guard.IPTables.
Require Export Fiat.Narcissus.Examples.Guard.Ports.

Definition protected_let {A B} (a: A) (k: A -> B) : B :=
  k a.

Notation "'IPGuard' {{ inv1 ;  .. ;  invn }}" :=
  (Def ADT {
     rep := unit,

     Def Constructor0 "Init" : rep := ret tt,,

     Def Method1 "ProcessPacket" (db : rep) (bs : bytes) : rep * result :=
       let invocations := (List.cons inv1%iptables .. (List.cons invn%iptables List.nil) ..) in
       let rule := rule_of_invocations invocations in
       let policy := policy_of_invocations FORWARD invocations DROP in
       ret (protected_let (input_of_bytes FORWARD bs) (fun input =>
               (db, match rule input with
                    | Some res => res
                    | None => policy
                    end)))
  }%methDefParsing).


(************************************************************
* Lambda-calculus with exceptions                           *
* Combined pretty-big-step semantics with error rules       *
*************************************************************)

Set Implicit Arguments.
Require Export LambdaExn_Pretty.
Export BehaviorsWithErrors.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : beh.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Semantics *)

(** Outcome of an evaluation *)

Inductive out :=
  | out_ter : nat -> beh -> out
  | out_div : out.

Implicit Types o : out.

(** Grammar of extended terms *)

Inductive ext : Type :=
  | ext_trm : trm -> ext
  | ext_app_1 : out -> trm -> ext
  | ext_app_2 : val -> out -> ext
  | ext_try_1 : out -> trm -> ext
  | ext_raise_1 : out -> ext.

Coercion ext_trm : trm >-> ext.
Implicit Types e : ext.

(** Partial order on the outcomes *)

Implicit Types n : nat.

Inductive faster : binary out :=
  | faster_ter : forall n n' r r',
      n < n' ->
      faster (out_ter n r) (out_ter n' r')
  | faster_div : forall o,
      faster o out_div.

Inductive before : binary out :=
  | before_ter : forall n n' r,
      n < n' ->
      before (out_ter n r) (out_ter n' r)
  | before_div :
      before out_div out_div.

Definition faster_before o1 o2 o :=
  before o2 o /\ faster o1 o.

(** Non-regular behavior *)

Inductive abort : out -> Prop :=
  | abort_exn : forall n v,
     abort (out_ter n (beh_exn v))
  | abort_err : forall n,
     abort (out_ter n beh_err)
  | abort_div :
     abort out_div.

(** Characterisation of closures *)

Inductive isclo : val -> Prop :=
  | isclo_intro : forall x t3, isclo (val_clo x t3).

(** Semantics with a collection of error rules,
    and with [rand] always returning zero. *)

CoInductive cred : ext -> out -> Prop :=
  | cred_var : forall n x,
      cred (trm_var x) (out_ter n beh_err)
  | cred_val : forall n v,
      cred v (out_ter n v)
  | cred_abs : forall n x t,
      cred (trm_abs x t) (out_ter n (val_clo x t))
  | cred_app : forall o1 o2 o t1 t2,
      cred t1 o1 ->
      cred (ext_app_1 o1 t2) o2 ->
      faster_before o1 o2 o ->
      cred (trm_app t1 t2) o
  | cred_app_1_abort : forall o1 o t2,
      abort o1 ->
      before o1 o ->
      cred (ext_app_1 o1 t2) o
  | cred_app_1 : forall o2 o3 o n v1 t2,
      cred t2 o2 ->
      cred (ext_app_2 v1 o2) o3 ->
      faster_before o2 o3 o ->
      cred (ext_app_1 (out_ter n v1) t2) o
  | cred_app_2_abort : forall o2 v1 o,
      abort o2 ->
      before o2 o ->
      cred (ext_app_2 v1 o2) o
  | cred_app_2 : forall o3 o n x t3 v2,
      cred (subst x v2 t3) o3 ->
      before o3 o ->
      cred (ext_app_2 (val_clo x t3) (out_ter n v2)) o
  | cred_app_2_err : forall v1 n n' v2,
      ~ isclo v1 ->
      cred (ext_app_2 v1 (out_ter n v2)) (out_ter n' beh_err)
  | cred_try : forall o1 o2 t1 t2 o,
      cred t1 o1 ->
      cred (ext_try_1 o1 t2) o2 ->
      faster_before o1 o2 o ->
      cred (trm_try t1 t2) o
  | cred_try_1_val : forall n n' v1 t2,
      cred (ext_try_1 (out_ter n v1) t2) (out_ter n' v1)
  | cred_try_1_exn : forall o1 n v1 t2 o,
      cred (trm_app t2 v1) o1 ->
      before o1 o ->
      cred (ext_try_1 (out_ter n (beh_exn v1)) t2) o
  | cred_try_1_div : forall t2,
      cred (ext_try_1 out_div t2) out_div
  | cred_try_1_err : forall n n' t2,
      cred (ext_try_1 (out_ter n beh_err) t2) (out_ter n' beh_err)
  | cred_raise : forall o1 o2 t1 o,
      cred t1 o1 ->
      cred (ext_raise_1 o1) o2 ->
      faster_before o1 o2 o ->
      cred (trm_raise t1) o
  | cred_raise_1_abort : forall o1 o,
      abort o1 ->
      before o1 o ->
      cred (ext_raise_1 o1) o
  | cred_raise_1 : forall n n' v1,
      cred (ext_raise_1 (out_ter n v1)) (out_ter n' (beh_exn v1))
  | cred_rand : forall n,
      cred trm_rand (out_ter n (val_int O)).

(** Auxiliary *)

Definition credbeh e b := exists n, cred e (out_ter n b).

Definition cdiverge e := cred e out_div.

Definition terminates e := exists n b, cred e (out_ter n b).

(*==========================================================*)
(* * Proofs *)

(************************************************************)
(* ** Basic properties of the semantics *)

Hint Constructors abort cred faster before.
Hint Extern 1 (_ < _) => math.
Hint Extern 1 (_ <= _) => math.

(** Monotonicity *)

Section Monotonicity.

Lemma faster_le_l : forall o n n' b,
  faster o (out_ter n b) -> n <= n' -> faster o (out_ter n' b).
Proof. introv O L. inverts* O. Qed.

Lemma before_le_l : forall o n n' b,
  before o (out_ter n b) -> n <= n' -> before o (out_ter n' b).
Proof. introv O L. inverts* O. Qed.

Hint Resolve faster_le_l before_le_l.

Lemma faster_before_le_l : forall o1 o2 n n' b,
  faster_before o1 o2 (out_ter n b) -> n <= n' ->
  faster_before o1 o2 (out_ter n' b).
Proof. unfold faster_before. introv [O1 O2] L. split*. Qed.

End Monotonicity.

(** Automation for the partial order *)

Lemma faster_succ : forall n b,
  faster (out_ter n b) (out_ter (S n) b).
Proof. intros. auto. Qed.

Lemma before_succ : forall n b,
  before (out_ter n b) (out_ter (S n) b).
Proof. intros. auto. Qed.

Hint Extern 1 (before _ _) => apply before_succ.
Hint Extern 1 (faster _ _) => apply faster_succ.
Hint Extern 3 (faster_before _ _ _) => split.

Hint Resolve faster_before_le_l.

(** Additional automation *)

Lemma faster_before_max : forall n1 n2 b1 b2,
  faster_before (out_ter n1 b1) (out_ter n2 b2)
                (out_ter (S (max n1 n2)) b2).
Proof.
  intros. forwards [[? ?]|[? ?]]: max_cases n1 n2; split~.
Qed.

Ltac max_resolve :=
  simpl; match goal with |- context [max ?n1 ?n2] =>
    let e := fresh "m" in
    destruct (max_cases n1 n2) as [[? ?]|[? ?]];
    set (e := max n1 n2) in *; clearbody e end.

Hint Resolve faster_before_max.
Hint Extern 1 (before _ _) => max_resolve; constructor.
Hint Extern 1 (faster_before _ _ _) => apply faster_before_max.

(************************************************************)
(* * Full coverage property *)

Section Full.

(** Note: could be automated better using more advanced tactics *)

Ltac esplits :=
  esplit;
  repeat (match goal with |- exists _, _ => esplit end).

Lemma not_terminates_cred_div : forall e,
  ~ terminates e -> cred e out_div.
Proof.
  cofix IH. introv N. destruct e.
  destruct t; try solve [ false N; exists O __; auto ].
  tests (n1&b1&R1) C: (terminates t1).
    tests (n2&b2&R2) C': (terminates (ext_app_1 (out_ter n1 b1) t2)).
      false N. esplits. applys* cred_app.
      forwards: IH C'. applys* cred_app.
    applys* cred_app.
  tests (n1&b1&R1) C: (terminates t1).
    tests (n2&b2&R2) C': (terminates (ext_try_1 (out_ter n1 b1) t2)).
      false N. esplits. applys* cred_try.
      forwards: IH C'. applys* cred_try.
    applys* cred_try.
  tests (n1&b1&R1) C: (terminates t).
    tests (n2&b2&R2) C': (terminates (ext_raise_1 (out_ter n1 b1))).
      false N. esplits. applys* cred_raise.
      forwards: IH C'. applys* cred_raise.
     applys* cred_raise.
  destruct o.
    destruct b.
      tests (n1&b1&R1) C: (terminates t).
        tests (n2&b2&R2) C': (terminates (ext_app_2 v (out_ter n1 b1))).
          false N. esplits. applys* cred_app_1.
          forwards: IH C'. applys* cred_app_1.
        applys* cred_app_1.
      false N. esplits. applys~ cred_app_1_abort.
      false N. esplits. applys~ cred_app_1_abort.
      constructor~.
  destruct o.
    destruct b.
      tests C: (isclo v).
        inverts C as (?&?&?).
         tests (?&?&?) C': (terminates (subst x v0 t3)).
           false N. esplits. applys* cred_app_2.
           forwards: IH C'. applys* cred_app_2.
        false N. exists O __. applys~ cred_app_2_err.
      false N. esplits. applys~ cred_app_2_abort.
      false N. esplits. applys~ cred_app_2_abort.
    constructors~.
  destruct o.
    destruct b.
      false N. exists O __. applys~ cred_try_1_val.
      tests (?&?&?) C': (terminates (trm_app t v)).
        false N. esplits. applys* cred_try_1_exn.
        forwards: IH C'. applys* cred_try_1_exn.
      false N. exists O __. applys~ cred_try_1_err.
    constructors~.
  destruct o.
    destruct b.
      false N. exists O __. applys~ cred_raise_1.
      false N. esplits. applys~ cred_raise_1_abort.
      false N. esplits. applys~ cred_raise_1_abort.
    constructors~.
Qed.

Corollary cred_full : forall e, exists o, cred e o.
Proof.
  intros. tests_basic C: (exists n b, cred e (out_ter n b)).
  destruct C as (n&b&?). eauto.
  exists out_div. apply* not_terminates_cred_div.
Qed.

End Full.


(** * Push-Button Synthesis of Barrett Reduction: Reification Cache *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.derive.Derive.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Arithmetic.BarrettReduction.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Local Open Scope Z_scope.

Import BarrettReduction.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Module Export BarrettReduction.
  (* all the list operations from for_reification.ident *)
  Strategy 100 [length seq repeat combine map flat_map partition app rev fold_right update_nth nth_default ].
  Strategy -10 [Fancy.fancy_reduce reduce].

  Derive reified_barrett_red_gen
         SuchThat (is_reification_of reified_barrett_red_gen Fancy.fancy_reduce)
         As reified_barrett_red_gen_correct.
  Proof. Time cache_reify (). Time Qed.

  Module Export ReifyHints.
#[global]
    Hint Extern 1 (_ = _) => apply_cached_reification Fancy.fancy_reduce (proj1 reified_barrett_red_gen_correct) : reify_cache_gen.
#[global]
    Hint Immediate (proj2 reified_barrett_red_gen_correct) : wf_gen_cache.
#[global]
    Hint Rewrite (proj1 reified_barrett_red_gen_correct) : interp_gen_cache.
  End ReifyHints.
  Local Opaque reified_barrett_red_gen. (* needed for making [autorewrite] not take a very long time *)
End BarrettReduction.


Require Export Coq.Lists.List.
Require Export Symbols.
Require Export Util.
Require Export Expression.

(** printing esti #:# *)
(** printing ==> #⇒# *)
(** printing ==>* #⇒*# *)
(** printing |- #⊢# *)
(** printing tau #τ# *)
(** printing Gamma #Γ# *)
(** printing Gamma' #Γ'# *)
(** printing Gamma'' #Γ''# *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : exp -> exp -> Prop :=
  | ST_AppAbs :
      forall T t12 v2, wnf v2 -> EApp (ELam T t12) v2 ==> subst 0 v2 t12
  | ST_App1 : forall t1 t1' t2, t1 ==> t1' -> EApp t1 t2 ==> EApp t1' t2
  | ST_App2 : forall t1 t2 t2', t2 ==> t2' -> EApp t1 t2 ==> EApp t1 t2'
 where "t1 '==>' t2" := (step t1 t2).
Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(** ** Typing judgements

For lambda-typed lambda calculus, the type rules may superficially
resemble other lambda calculi. There are some quirks to observe.
The first is the variable typing rule:

<<
    Gamma |- A : B
  ------------------- (X_Var)
   Gamma, x:A |- x:A
>>

Although [X_Var] is semantically equivalent to the familiar rule,
this version allows us to introduce types (i.e., terms of the form [T:tau]).

*)

Reserved Notation "Gamma '|-' t 'esti' T" (at level 40).

Inductive has_type : context -> exp -> exp -> Prop :=
  | X_Var :
      forall (Gamma : context) (A B : exp),
      Gamma |- A esti B ->
      (cons A Gamma) |- (EVar (length Gamma)) esti (lift (length Gamma) A)
  | X_Abs :
      forall (Gamma : context) t1 t12 T,
      In t1 Gamma ->
      Gamma |- t12 esti T ->
      remove exp_eq_dec t1 Gamma |- ELam t1 t12 esti ELam t1 T
  | X_App :
      forall (Gamma : context) (t1 t12 T1 T12 : exp),
      Gamma |- t12 esti ELam T1 T12 ->
      Gamma |- t1 esti T1 ->
      Gamma |- EApp t12 t1 esti subst (length Gamma) t1 T12
  | X_Weak :
      forall (Gamma : context) (A B C D : exp),
      Gamma |- A esti B ->
      Gamma |- C esti D ->
      cons C Gamma |- (lift (length Gamma) A) esti (lift (length Gamma) B)
 where "Gamma '|-' t 'esti' T" := (has_type Gamma t T).

Hint Constructors has_type.