Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.FiniteGraph.
Require Import RamifyCoq.graph.MathGraph.
Require Import RamifyCoq.graph.LstGraph.
Require Import RamifyCoq.graph.UnionFind.

Section UnionFindGraph.

  Context {V E: Type}.
  Context {VE: EqDec V eq}.
  Context {EE: EqDec E eq}.

  Context {isNullDec: DecidablePred V}.
  Context {out_edge: V -> E}.

  (* Context {ufg: UnionFindGraph}. *)

  Class LiMaFin (g: PreGraph V E) :=
    {
      li: LstGraph g out_edge;
      ma: MathGraph g isNullDec;
      fin: FiniteGraph g
    }.

  Context {DV DE DG: Type}.

  Definition LGraph := LabeledGraph V E DV DE DG.
  Definition Graph := (GeneralGraph V E DV DE DG (fun g => LiMaFin (pg_lg g))).

  Definition Graph_LGraph (G: Graph): LGraph := lg_gg G.

  Local Coercion Graph_LGraph: Graph >-> LGraph.
  Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.

  Instance maGraph(G: Graph): MathGraph G isNullDec := @ma G (@sound_gg _ _ _ _ _ _ _ _ G).
  Instance finGraph (G: Graph): FiniteGraph G := @fin G (@sound_gg _ _ _ _ _ _ _ _ G).
  Instance liGraph (G: Graph):  LstGraph G out_edge := @li G (@sound_gg _ _ _ _ _ _ _ _ G).

  Definition vgamma (g: LGraph) (x: V) : DV * V := (vlabel g x, let target := dst (pg_lg g) (out_edge x) in if (projT2 isNullDec target) then x else target).

  Lemma valid_parent: forall (g: Graph) v n p, vvalid g v -> vgamma g v = (n, p) -> vvalid g p.
  Proof.
    intros. unfold vgamma in H0. simpl in H0. inversion H0. clear H0 H2. destruct (projT2 isNullDec (dst g (out_edge v))); auto.
    assert (~ isNullDec (dst g (out_edge v))) by (intro; apply n0; auto).
    pose proof (only_one_edge v (out_edge v) H). assert (out_edge v = out_edge v) by auto. rewrite <- H1 in H2. destruct H2.
    pose proof (valid_graph _ _ H4). destruct H5 as [_ [? | ?]]; auto. exfalso; auto.
  Qed.

  Lemma parent_loop: forall (g: Graph) v n y, vgamma g v = (n, v) -> reachable g v y -> v = y.
  Proof.
    intros. unfold vgamma in H. destruct (projT2 isNullDec (dst g (out_edge v))).
    - apply (lst_out_edge_only_one g _ v (dst g (out_edge v)) y); auto. intro. apply reachable_head_valid in H1. apply (valid_not_null g (dst g (out_edge v)) H1); auto.
    - apply (lst_self_loop _ (liGraph g)) in H0; auto. inversion H. rewrite H3. auto.
  Qed.

  Lemma gamma_parent_reachable_included: forall (g: Graph) x r pa, vvalid g x -> vgamma g x = (r, pa) -> Included (reachable g pa) (reachable g x).
  Proof.
    intros. intro y; intros. unfold vgamma in H0. destruct (projT2 isNullDec (dst g (out_edge x))).
    - inversion H0. auto.
    - apply edge_reachable_by with pa; auto. split; auto. split.
      + apply reachable_head_valid in H1; auto.
      + inversion H0. rewrite H4. rewrite (dst_step _ (liGraph g) _ _ H H4). auto.
  Qed.

  Lemma Prop_join_reachable_parent: forall (g: Graph) x r pa,
      vvalid g x -> vgamma g x = (r, pa) ->
      Prop_join
        (reachable g pa)
        (Intersection _ (reachable g x) (Complement V (reachable g pa)))
        (reachable g x).
  Proof.
    intros. apply Ensemble_join_Intersection_Complement.
    - eapply gamma_parent_reachable_included; eauto.
    - intros. apply decidable_prop_decidable. pose proof (finGraph g).
      apply (@reachable_decidable_prime _ _ _ _ _ _ (maGraph g)).
      + apply LocalFiniteGraph_FiniteGraph; auto.
      + apply (valid_parent _ x r); auto.
      + apply FiniteGraph_EnumCovered; auto.
  Qed.

  Definition Graph_gen_redirect_parent (g: Graph) (x: V) (pa: V) (H: weak_valid g pa) (Hv: vvalid g x) (Hn: ~ reachable g pa x): Graph.
  Proof.
    refine (generalgraph_gen_dst g (out_edge x) pa _). constructor.
    - simpl. apply (gen_dst_preserve_lst g (liGraph g)); auto.
    - apply (gen_dst_preserve_math g (out_edge x) pa (maGraph g) H).
    - apply (gen_dst_preserve_finite g (out_edge x) pa (finGraph g)).
  Defined.

  Lemma Graph_reachable_dec: forall (G: Graph) x, Decidable (vvalid G x) -> forall y, Decidable (reachable G x y).
  Proof.
    intros. apply reachable_decidable with (is_null := isNullDec); auto.
    + apply maGraph.
    + apply LocalFiniteGraph_FiniteGraph, finGraph.
    + apply FiniteGraph_EnumCovered, finGraph.
  Qed.

  Definition Graph_vgen (G: Graph) (x: V) (d: DV) : Graph := generalgraph_vgen G x d (sound_gg G).

  Lemma uf_root_vgamma: forall (g: Graph) v n, vvalid g v -> vgamma g v = (n, v) -> uf_root g v v.
  Proof. intros. split; [apply reachable_refl | intros; apply (parent_loop g _ n)]; auto. Qed.

  Lemma vgamma_not_dst: forall (g: Graph) x r pa, vgamma g x = (r, pa) -> pa <> x -> dst g (out_edge x) = pa.
  Proof. intros. unfold vgamma in H. destruct (projT2 isNullDec (dst g (out_edge x))); inversion H; [exfalso |]; auto. Qed.

  Lemma vgamma_not_edge: forall (g: Graph) x r pa, vvalid g x -> vgamma g x = (r, pa) -> pa <> x -> g |= x ~> pa.
  Proof.
    intros. assert (vvalid g pa) by (apply valid_parent in H0; auto). hnf. split; [|split]; auto.
    apply (vgamma_not_dst g x r) in H1; auto. rewrite step_spec. exists (out_edge x).
    pose proof (vvalid_src_evalid _ (liGraph g) _ H). destruct H3. split; auto.
  Qed.

  Lemma vgamma_not_reachable': forall (g: Graph) x r pa y, vvalid g x -> vgamma g x = (r, pa) -> pa <> x -> reachable g pa y -> ~ reachable g y x.
  Proof. intros. apply (dst_not_reachable _ (liGraph g) _ pa); auto. apply (vgamma_not_dst g x r); auto. Qed.

  Lemma vgamma_not_reachable: forall (g: Graph) x r pa, vvalid g x -> vgamma g x = (r, pa) -> pa <> x -> ~ reachable g pa x.
  Proof. intros. assert (vvalid g pa) by (apply valid_parent in H0; auto). apply (vgamma_not_reachable' g x r pa pa); auto. apply reachable_refl; auto. Qed.

  Lemma uf_root_not_eq_root_vgamma: forall (g: Graph) x r pa root, vgamma g x = (r, pa) -> uf_root g x root -> x <> root -> x <> pa.
  Proof.
    intros. unfold vgamma in H. destruct (projT2 isNullDec (dst g (out_edge x))).
    - destruct H0. apply reachable_ind.reachable_ind in H0. destruct H0. 1: exfalso; auto. destruct H0 as [z [[? [? ?]] [? ?]]]. rewrite step_spec in H4.
      destruct H4 as [ed [? [? ?]]]. pose proof (conj H7 H4). rewrite (@only_one_edge _ _ _ _ g _ (liGraph g)) in H9; auto. subst ed. rewrite H8 in p.
      exfalso. apply (@valid_not_null _ _ _ _ g _ (maGraph g)) in H3; auto.
    - inversion H. clear H H3. assert (vvalid g x) by (destruct H0; apply reachable_head_valid in H; auto).
      assert (g |= (x, (out_edge x) :: nil) is x ~o~> pa satisfying (fun _ => True)). {
        split; split; intros; hnf; simpl; auto. unfold strong_evalid. assert (out_edge x = out_edge x) by auto. rewrite <- (@only_one_edge _ _ _ _ g _ (liGraph g)) in H2; auto.
        destruct H2. split; [|split]; auto. rewrite H2. split; auto. apply (@valid_graph _ _ _ _ g _ (maGraph g)) in H3. destruct H3 as [_ [? | ?]]; auto.
        hnf in H3. exfalso; auto.
      } rewrite H4. intro. rewrite <- H3 in H2. apply (@no_loop_path _ _ _ _ g _ (liGraph g)) in H2. inversion H2.
  Qed.

  Lemma vgamma_uf_root: forall (g: Graph) x r pa root, vvalid g x -> vgamma g x = (r, pa) -> uf_root g x root -> x <> root -> uf_root g pa root.
  Proof.
    intros. pose proof (uf_root_not_eq_root_vgamma g _ _ _ _ H0 H1 H2). destruct H1. split; auto. pose proof (valid_parent g _ _ _ H H0).
    assert (Decidable (reachable g pa root)) by (apply Graph_reachable_dec; left; auto). apply decidable_prop_decidable in H6. destruct H6; auto. exfalso.
    pose proof (lst_out_edge_only_one g (liGraph g) x pa root). simpl in H7. apply H2. apply H7; auto. apply (vgamma_not_dst _ _ r); auto.
  Qed.

  Instance fml : FML_General V E DV DE DG LiMaFin out_edge isNullDec. Proof. constructor; intros; destruct X; auto. Defined.

  Global Existing Instance fml.

  Lemma findS_preserves_vgamma: forall (g1 g2: Graph) x r pa, vvalid g1 x -> vgamma g1 x = (r, pa) -> pa <> x -> findS g1 pa g2 -> vgamma g2 x = (r, pa).
  Proof.
    intros. assert (Hr: ~ reachable g1 pa x) by (apply vgamma_not_reachable with r; auto). unfold vgamma in *. destruct (projT2 isNullDec (dst g1 (out_edge x))).
    1: inversion H0; exfalso; auto. rewrite <- H0. destruct H2 as [? [[? ?] ?]]. f_equal.
    - assert (vvalid g2 x) by (rewrite <- H3; auto). specialize (H5 x H H6). unfold Graph_LGraph. rewrite H5. auto.
    - assert (evalid (predicate_partialgraph (lg_gg g1) (fun n : V => ~ reachable (lg_gg g1) pa n)) (out_edge x)). {
        simpl. hnf. pose proof (vvalid_src_evalid _ (liGraph g1) _ H). unfold Graph_LGraph in H6. destruct H6. rewrite H6. split; auto.
      } destruct H2 as [_ [? [_ ?]]]. pose proof H6. rewrite H2 in H8. clear H2. specialize (H7 _ H6 H8). simpl in H7. unfold Graph_LGraph. rewrite <- H7.
      destruct (projT2 isNullDec (dst (lg_gg g1) (out_edge x))); [exfalso |]; auto.
  Qed.

  Lemma the_same_root_union: forall (g g1 g2: Graph) x y root,
      vvalid g x -> vvalid g y -> uf_equiv g g1 -> uf_equiv g1 g2 -> uf_root g1 x root -> uf_root g2 y root -> uf_union g x y g2.
  Proof. intros. apply (same_root_union g g1 g2 x y root); auto. Qed.

  Lemma uf_equiv_root_the_same: forall (g1 g2: Graph) x root, uf_equiv g1 g2 -> uf_root g1 x root <-> uf_root g2 x root.
  Proof. intros. pose proof (@uf_equiv_the_same_root _ _ _ _ _ _ _ _ out_edge isNullDec fml g1 g2 x root H). apply H0. Qed.

  Lemma uf_equiv_not_reachable: forall (g1 g2: Graph) x r pa root,
      vvalid g1 x -> vgamma g1 x = (r, pa) -> pa <> x -> uf_equiv g1 g2 -> uf_root g2 pa root -> ~ reachable g2 root x.
  Proof.
    intros. pose proof H3. rewrite <- (uf_equiv_root_the_same _ _ pa root H2) in H4. destruct H3. intro. apply H5 in H6. subst x.
    pose proof (vgamma_not_reachable g1 root r pa H H0 H1). destruct H4. auto.
  Qed.

  Lemma graph_gen_redirect_parent_equiv': forall (g1 g2: Graph) x root,
      uf_equiv g1 g2 -> vvalid g2 x -> (~ reachable g2 root x) -> uf_root g2 x root -> uf_equiv g1 (pregraph_gen_dst g2 (out_edge x) root).
  Proof.
    intros. apply (@uf_equiv_trans _ _ _ _ g2 _ (liGraph g2) _ (maGraph g2) (finGraph g2)); auto. split; intro y; simpl; [intuition |]. intros.
    assert (Decidable (reachable g2 y x)) by (apply Graph_reachable_dec; left; destruct H3; apply reachable_head_valid in H3; auto).
    apply decidable_prop_decidable in H5. destruct H5.
    - pose proof (uf_root_gen_dst_same g2 (liGraph g2) _ _ _ H2 H1 H5). simpl in H6.
      pose proof (uf_root_unique _ (gen_dst_preserve_lst g2 (liGraph g2) _ _ H1 H0) _ _ _ H4 H6). subst r2.
      pose proof (uf_root_reachable _ _ _ _ H5 H2). apply (uf_root_unique g2 (liGraph g2) _ _ _ H3 H7).
    - apply (uf_root_unique _ (gen_dst_preserve_lst g2 (liGraph g2) _ _ H1 H0) y); auto. apply (uf_root_gen_dst_preserve g2 (liGraph g2)); auto.
  Qed.

  Lemma graph_gen_redirect_parent_equiv: forall (g1 g2: Graph) x r pa root (Hv: vvalid g2 x) (Hn: ~ reachable g2 root x),
      vvalid g1 x -> vgamma g1 x = (r, pa) -> pa <> x -> uf_equiv g1 g2 -> uf_root g2 pa root -> uf_equiv g1 (pregraph_gen_dst g2 (out_edge x) root).
  Proof.
    intros. apply graph_gen_redirect_parent_equiv'; auto. rewrite <- (uf_equiv_root_the_same g1); auto.
    apply (uf_root_edge g1 (liGraph g1) x pa); [| apply (vgamma_not_dst g1 x r) | rewrite (uf_equiv_root_the_same g1 g2)]; auto.
  Qed.

  Lemma graph_gen_redirect_parent_findS: forall (g1 g2: Graph) x r1 r2 pa pa' (H: weak_valid g2 pa') (Hv: vvalid g2 x) (Hn: ~ reachable g2 pa' x),
      vvalid g1 x -> vgamma g1 x = (r1, pa) -> pa <> x -> vgamma g2 x = (r2, pa) -> findS g1 pa g2 -> uf_root g2 pa pa' ->
      findS g1 x (Graph_gen_redirect_parent g2 x pa' H Hv Hn).
  Proof.
    intros. hnf. simpl. destruct H4 as [? [? ?]]. hnf in H4. simpl in H4. unfold predicate_vvalid, predicate_weak_evalid in H4. split; [|split].
    - assert (forall v, ~ reachable (lg_gg g1) x v -> ~ reachable (lg_gg g1) pa v). {
        intros. intro. apply H8. pose proof (gamma_parent_reachable_included g1 x r1 pa H0 H1). apply H10. auto. }
      assert (forall v, ~ reachable (lg_gg g1) pa v <-> ~ reachable (lg_gg g1) x v \/ x = v). {
        intros. split; intros.
        - destruct_eq_dec x v; [right | left]; auto. intro. apply H9. apply reachable_ind.reachable_ind in H11. destruct H11. 1: exfalso; auto.
          destruct H11 as [z [[_ [_ ?]] [? ?]]]. rewrite (dst_step g1 (liGraph g1) x pa) in H11; auto; [subst pa | apply (vgamma_not_dst g1 x r1)]; auto.
        - destruct H9.
          + apply H8; auto.
          + subst v. apply vgamma_not_reachable with r1; auto.
      } hnf. simpl. unfold predicate_vvalid, predicate_weak_evalid. simpl. destruct H4 as [? [? [? ?]]]. split; [|split; [|split]]; intros.
      + split; intros; destruct H13; split; auto; apply H8 in H14; pose proof (conj H13 H14); [rewrite H4 in H15 | rewrite <- H4 in H15]; destruct H15; auto.
      + split; intros; destruct H13.
        * pose proof (H8 _ H14). pose proof (conj H13 H15). rewrite H10 in H16. destruct H16. rewrite H9 in H17. destruct H17. 1: split; auto. symmetry in H17.
          pose proof (conj H17 H16). rewrite (@only_one_edge _ _ _ _ g2 _ (liGraph g2)) in H18; auto. subst e. pose proof (vvalid_src_evalid _ (liGraph g1) _ H0).
          destruct H18 as [? _]. unfold Graph_LGraph in H18. rewrite H18 in H14. exfalso. apply H14. apply reachable_refl. auto.
        * pose proof (H8 _ H14). pose proof (conj H13 H15). rewrite <- H10 in H16. destruct H16. rewrite H9 in H17. destruct H17. 1: split; auto. symmetry in H17.
          pose proof (conj H17 H16). rewrite (@only_one_edge _ _ _ _ g1 _ (liGraph g1)) in H18; auto. subst e. pose proof (vvalid_src_evalid _ (liGraph g2) _ Hv).
          destruct H18 as [? _]. unfold Graph_LGraph in H18. rewrite H18 in H14. exfalso. apply H14. apply reachable_refl. auto.
      + destruct H13, H14. apply H8 in H15. apply H8 in H16. apply H11; auto.
      + unfold updateEdgeFunc. destruct (equiv_dec (out_edge x) e).
        * unfold Equivalence.equiv in e0. subst e. pose proof (vvalid_src_evalid _ (liGraph g1) _ H0).
          destruct H15. unfold Graph_LGraph in H15. destruct H13. exfalso. apply H17. rewrite H15. apply reachable_refl; auto.
        * destruct H13, H14. apply H8 in H15. apply H8 in H16. apply H12; auto.
    - apply (graph_gen_redirect_parent_equiv _ _ _ r1 pa); auto.
    - apply H7.
  Qed.

  Lemma diff_root_union_1: forall (g g1 g2: Graph) x y x_root y_root,
      uf_equiv g g1 -> uf_root g1 x x_root -> uf_equiv g1 g2 -> uf_root g2 y y_root -> x_root <> y_root ->
      (@weak_valid _ _ _ _ g2 _ (maGraph g2) y_root) -> vvalid g2 x_root ->
      ~ reachable g2 y_root x_root -> uf_union g x y (pregraph_gen_dst g2 (out_edge x_root) y_root).
  Proof.
    intros. assert (uf_equiv g g2) by (apply (@uf_equiv_trans _ _ _ _ g1 _ (liGraph g1) _ (maGraph g1) (finGraph g1)); auto).
    pose proof (uf_equiv_union g g2 (Graph_gen_redirect_parent g2 x_root y_root H4 H5 H6) x y H7). simpl in H8. apply H8.
    apply (@diff_root_union _ _ _ _ _ _ _ _ out_edge isNullDec fml); auto. apply (uf_equiv_root_the_same g1); auto.
  Qed.

  Lemma diff_root_union_2: forall (g g1 g2: Graph) x y x_root y_root,
      uf_equiv g g1 -> uf_root g1 x x_root -> uf_equiv g1 g2 -> uf_root g2 y y_root -> x_root <> y_root -> (@weak_valid _ _ _ _ g2 _ (maGraph g2) x_root) -> vvalid g2 y_root ->
      ~ reachable g2 x_root y_root -> uf_union g x y (pregraph_gen_dst g2 (out_edge y_root) x_root).
  Proof.
    intros. assert (uf_equiv g g2) by (apply (@uf_equiv_trans _ _ _ _ g1 _ (liGraph g1) _ (maGraph g1) (finGraph g1)); auto).
    pose proof (uf_equiv_union g g2 (Graph_gen_redirect_parent g2 y_root x_root H4 H5 H6) y x H7). simpl in H8. apply uf_union_sym. apply H8.
    apply (@diff_root_union _ _ _ _ _ _ _ _ out_edge isNullDec fml); auto. apply (uf_equiv_root_the_same g1); auto.
  Qed.

  Lemma graph_gen_redirect_parent_vgamma: forall (g1 g2: Graph) x r pa y (H: weak_valid g1 x) (Hv: vvalid g1 y) (Hn: ~ reachable g1 x y),
      (forall a b, out_edge a = out_edge b -> a = b) -> vgamma g1 x = (r, pa) -> g2 = (Graph_gen_redirect_parent g1 y x H Hv Hn) -> vgamma g2 x = (r, pa).
  Proof.
    intros. rewrite H2. clear H2. unfold vgamma in *. simpl in *. inversion H1. f_equal. unfold updateEdgeFunc.
    destruct (equiv_dec (out_edge y) (out_edge x)); auto. hnf in e. apply H0 in e. subst y. exfalso; apply Hn; apply reachable_refl; auto.
  Qed.

End UnionFindGraph.


Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Bool.Bool.

Module BoolDT <: DecidableType.
  Definition U := bool.
  Definition eq_dec := bool_dec.
End BoolDT.

Module Import BoolDED := DecidableEqDep BoolDT.

Lemma bool_irre (a b : bool) (H1 H2 : a = b) : H1 = H2.
Proof.
  eapply UIP.
Qed.

Require Import Coq.Bool.Sumbool.

Definition boolcase := sumbool_of_bool.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23synthconj4_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv0) lv2) ->  (@eq natural (Succ (plus (plus (mult lv0 (plus Zero lv1)) lv1) lv0)) (plus lv2 (Succ lv1))).
Admitted.
QuickChick conj23synthconj4_hyp.


Require Import CSet LengthEq Option Map OrderedTypeEx Util List Get Computable DecSolve AllInRel.

Set Implicit Arguments.

Unset Printing Abstraction Types.

Fixpoint pos X `{OrderedType X} (l:list X) (x:X) (n:nat) : option nat :=
  match l with
    | nil => None
    | y::l => if [ x === y ] then Some n else pos l x (S n)
  end.

Lemma pos_add X `{OrderedType X} k' symb (f:X) k i
: pos symb f k = Some i -> pos symb f (k' + k) = Some (k' + i).
Proof.
  general induction symb; eauto.
  unfold pos in *; fold pos in *.
  cases. congruence.
  eapply IHsymb in H0. orewrite (S (k' + k) = k' + S k). eauto.
Qed.

Lemma pos_sub X `{OrderedType X} k' symb (f:X) k i
: pos symb f (k' + k) = Some (k' + i) -> pos symb f k = Some i.
Proof.
  general induction symb; eauto.
  unfold pos in *; fold pos in *.
  cases. f_equal. inv H0. omega.
  orewrite (S (k' + k) = k' + S k) in H0.
  eauto.
Qed.

Lemma pos_ge X `{OrderedType X} symb (l:X) i k
: pos symb l k = Some i
  -> k <= i.
Proof.
  general induction symb. unfold pos in H0; fold pos in H0.
  cases in H0. omega.
  exploit IHsymb; eauto. omega.
Qed.

Lemma pos_sub' X `{OrderedType X} k' symb (f:X) k i
: pos symb f k = Some i -> k' <= k -> pos symb f (k - k') = Some (i - k').
Proof.
  intros.
  eapply pos_sub.
  instantiate (1:=k').
  orewrite (k' + (k - k') = k).
  exploit pos_ge; eauto.
  orewrite (k' + (i - k') = i). eauto.
Qed.

Lemma get_first_pos X `{OrderedType X} n
      (Z:list X) z
: get Z n z
  -> (forall n' z', n' < n -> get Z n' z' -> z' =/= z)
  -> pos Z z 0 = Some n.
Proof.
  intros. general induction H0; simpl; cases; eauto.
  - exfalso. exploit (H1 0); eauto using get. omega.
  - exploit IHget; eauto.
    intros; eapply (H1 (S n')); eauto using get. omega.
    eapply pos_add with (k':=1) in H2. eauto.
Qed.

Lemma pos_get X  `{OrderedType X} (symb:list X) v x i
:  pos symb v i = ⎣x ⎦
   -> exists v', get symb (x-i) v' /\ v === v' /\ x >= i.
Proof.
  general induction symb; simpl in * |- *; eauto using get.
  cases in H0.
  - orewrite (x - x = 0). eexists; split; eauto using get.
  - exploit IHsymb; eauto; dcr.
    orewrite (x - i = S (x - S i)).
    eexists; split. econstructor; eauto. split; eauto; omega.
Qed.

Lemma pos_none X `{OrderedType X} symb (x:X) k k'
: pos symb x k = None
  -> pos symb x k' = None.
Proof.
  general induction symb; eauto; simpl in *.
  cases; try congruence; eauto.
Qed.

Lemma pos_eq X `{OrderedType X} symb y k
: pos symb y k = Some k
  -> hd_error symb === Some y.
Proof.
  intros. destruct symb; simpl in *; try cases in H0; simpl; try congruence.
  - constructor. rewrite COND. reflexivity.
  - exfalso. exploit pos_ge; eauto. omega.
Qed.

Lemma pos_indep  X `{OrderedType X} symb symb' x y k k'
: pos symb x k = pos symb' y k
  -> pos symb x k' = pos symb' y  k'.
Proof.
  general induction symb.
  - general induction symb'; simpl in *; eauto.
    cases in H0; try congruence; eauto.
  - simpl in *. cases.
    + symmetry in H0. eapply pos_eq in H0. destruct symb'; simpl in *.
      inv H0.
      cases; eauto. inv H0; exfalso; eauto.
    + destruct symb'; simpl in *. eauto using pos_none.
      cases.
      * exfalso. exploit pos_ge; eauto. omega.
      * eauto.
Qed.

Lemma pos_inc  X `{OrderedType X} symb symb' x y k k'
: pos symb x k = pos symb' y k
  -> pos symb x (k' + k) = pos symb' y (k' + k).
Proof.
  intros. eapply pos_indep; eauto.
Qed.

Lemma pos_dec  X `{OrderedType X} symb symb' x y k k'
: pos symb x k = pos symb' y k
  -> pos symb x (k - k') = pos symb' y (k - k').
Proof.
  intros. eapply pos_indep; eauto.
Qed.

Lemma pos_app_in X `{OrderedType X} x k L L'
: x ∈ of_list L
  -> pos (L ++ L') x k = pos L x k.
Proof.
  intros.
  general induction L; simpl in * |- *; cset_tac'.
  - cases; try congruence; exfalso; eauto.
  - cases; try congruence; eauto.
Qed.

Lemma pos_app_not_in X `{OrderedType X} x k L L'
: x ∉ of_list L
  -> pos (L ++ L') x k = pos L' x (length L + k).
Proof.
  intros.
  general induction L; simpl in * |- *; cset_tac'.
  cases; try congruence; eauto.
  - rewrite IHL; eauto.
Qed.

Require Import Drop.

Lemma pos_get_first X  `{OrderedType X} (symb:list X) v x i
:  pos symb v i = ⎣x ⎦
   -> exists v', get symb (x-i) v' /\ v === v' /\ x >= i /\
     forall z' n, n < x-i -> get symb n z' -> z' =/= v.
Proof.
  general induction symb; simpl in * |- *; eauto using get.
  cases in H0.
  - orewrite (x - x = 0). eexists; repeat split; eauto using get.
    + intros. exfalso. omega.
  - exploit IHsymb; eauto; dcr.
    orewrite (x - i = S (x - S i)).
    eexists; split. econstructor; eauto. repeat split; eauto; try omega.
    + intros. inv H5; intro; eauto. eapply H6; eauto. omega.
Qed.

Instance trivial_pos_instance X `{OrderedType X}
  : Proper (eq ==> eq ==> eq ==> eq) (@pos X _).
Proof.
  unfold Proper, respectful. intros; subst. eauto.
Qed.


Generalizable All Variables.
Require Import Coq.Lists.List. Import ListNotations.
Set Implicit Arguments.

(** * A terminal recursive version of [List.combine]. *)
Fixpoint combine_aux A B (l:list A)(l':list B) (res:list (A*B)) : list (A*B) :=
  match (l,l') with
    | (x::xs, y::ys) =>
      combine_aux xs ys ((x,y)::res)
    | _ => rev' res
  end.

Definition combine'  A B (l:list A)(l':list B) : list (A*B) :=
  combine_aux l l' [].

Lemma combine_aux_prop:
  forall A B (l:list A)(l':list B) acc,
    combine_aux l l' acc = rev' acc ++ combine l l'.
Proof.
  intros A B l;
    induction l as [| x xs IHx];
    intros l' acc; destruct l' as [ | y ys ];
      simpl; autorewrite with list; trivial.
  rewrite IHx. unfold rev'. simpl.
  repeat rewrite rev_append_rev.
  repeat rewrite <- app_assoc.
  trivial.
Qed.

Lemma combine'_combine:
  forall A B (l:list A) (l':list B),
    combine' l l' = combine l l'.
Proof.
  intros A B l l'. unfold combine'.
  apply combine_aux_prop.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e255m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import List.
Require Import ListSet.
Require Import Coqlib.
Require Import Metatheory.
Require Import Maps.
Require Import maps_ext.
Require Import alist.
Require Import Dipaths.
Require Import Program.Tactics.
Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Require Import Relations.Relation_Operators.
Require Import Relations.Operators_Properties.

(* This file defines control-flow graphs. *)

(* Properties of closure and transition of relations. *)
Lemma step_clos_refl_trans_1n__clos_trans_1n: forall A (R:A->A->Prop) y z
  (Hclos: clos_refl_trans_1n A R y z) x (Hrel: R x y),
  clos_trans_1n A R x z.
Proof.
  induction 1; simpl; intros.
    econstructor; eauto.
    apply Relation_Operators.t1n_trans with (y:=x); auto.
Qed.

Lemma step_clos_refl_trans__clos_trans: forall A (R:A->A->Prop) y z
  (Hclos: clos_refl_trans A R y z) x (Hrel: R x y),
  clos_trans A R x z.
Proof.
  intros.
  apply clos_t1n_trans.
  apply clos_rt_rt1n_iff in Hclos.
  eapply step_clos_refl_trans_1n__clos_trans_1n; eauto.
Qed.

Lemma clos_refl_trans__eq_or_clos_trans: forall A (R:A->A->Prop) x y
  (Hclos: clos_refl_trans A R x y),
  x = y \/ clos_trans A R x y.
Proof.
  induction 1; simpl; intros; auto.
    right. econstructor; eauto.
    destruct IHHclos1 as [EQ1 | IHHclos1]; subst.
      destruct IHHclos2 as [EQ2 | IHHclos2]; subst; auto.
      destruct IHHclos2 as [EQ2 | IHHclos2]; subst; auto.
        right. eapply t_trans; eauto.
Qed.

(* The Cfg module defines control-flow graphs, and is parameterized by a tree
   data type for representing CFGs. *)
Module Cfg (T:TREE0).

Module XTree := More_Tree_Properties(T).

Section Cfg.
(* A map from an id to its successors. *)
Variable successors: T.t (list T.elt).
(* Nodes in the CFG *)
Definition vertexes : V_set :=
fun (v:Vertex) => let '(index n) := v in XTree.in_cfg successors n.
(* Edges of the CFG *)
Definition arcs : A_set :=
fun (arc:Arc) =>
  let '(A_ends (index n2) (index n1)) := arc in
  In n2 (XTree.successors_list successors n1).
(* The entry point of the CFG. *)
Variable entry:T.elt.
(* The node av is reachable from entry. *)
Definition reachable av : Prop :=
  exists vl: V_list, exists al: A_list,
     D_walk vertexes arcs (index av) (index entry) vl al.
(* n1 dominates n2. *)
Definition domination (n1 n2:T.elt) : Prop :=
  forall vl al,
    D_walk vertexes arcs (index n2) (index entry) vl al ->
    (In (index n1) vl \/ n1 = n2).
(* n1 strictly dominates n2. *)
Definition strict_domination (n1 n2:T.elt) : Prop :=
  forall vl al,
    D_walk vertexes arcs (index n2) (index entry) vl al ->
    (In (index n1) vl /\ n1 <> n2).
(* n1 does not strictly dominates n2. *)
Definition non_sdomination (n1 n2:T.elt) : Prop :=
  exists vl, exists al,
    D_walk vertexes arcs (index n2) (index entry) vl al /\
    ~ In (index n1) vl.
(* n1 immediately dominates n2. *)
Definition imm_domination (n1 n2:T.elt) : Prop :=
  strict_domination n1 n2 /\
  forall n0, strict_domination n0 n2 -> domination n0 n1.
(* We assume that the names of CFG nodes are decidable. *)
Hypothesis Hdec: forall x y : T.elt, {x = y} + {x <> y}.
(* Properties of reachability. *)
Lemma reachable_succ: forall
  (n : T.elt) (sc : T.elt) (H1 : reachable n)
  (Hscs : In sc (XTree.successors_list successors n)),
  reachable sc.
Proof.
  intros.
  destruct H1 as [vl [al Hwk]].
  exists (index n::vl). exists (A_ends (index sc) (index n)::al).
  apply DW_step; auto.
    apply XTree.in_succ__in_cfg with (p:=n); auto.
Qed.

Lemma reachable_entry: forall
  (Hincfg: XTree.in_cfg successors entry),
  reachable entry.
Proof.
  intros.
  exists V_nil. exists A_nil.
  constructor; auto.
Qed.

Lemma reachable_dec: forall n,
  reachable n \/ ~ reachable n.
Proof. intros. tauto. Qed. (* classic logic *)

Lemma reachable_pred: forall n
  (Hreach: reachable n) (Hneq: n <> entry),
  exists p, In n (XTree.successors_list successors p) /\ reachable p.
Proof.
  intros.
  destruct Hreach as [vl [al Hreach]].
  inv Hreach; try congruence.
  destruct y as [y].
  exists y.
  unfold reachable.
  split; eauto.
Qed.

Lemma reachable_is_in_cfg: forall n (Hreach: reachable n),
  XTree.in_cfg successors n.
Proof.
  intros.
  destruct Hreach as [vl [al Hreach]].
  apply DW_endx_inv in Hreach; auto.
Qed.

(* Properties of domination relations. *)
Lemma non_sdomination_refl : forall
  n1 (Hneq: n1 <> entry)
  (Hreach: reachable n1),
  non_sdomination n1 n1.
Proof.
  unfold reachable, non_sdomination.
  intros.
  destruct Hreach as [vl [al Hreach]].
  apply DWalk_to_dpath in Hreach; auto.
    destruct Hreach as [vl0 [al0 Hp]].
    exists vl0. exists al0.
    split.
      apply D_path_isa_walk; auto.
      eapply DP_endx_ninV; eauto. congruence.
Qed.

Lemma dom_is_refl: forall n1, domination n1 n1.
Proof. unfold domination. auto. Qed.

Lemma dom_tran: forall n1 n2 n3
  (H: domination n1 n2) (H0: domination n2 n3), domination n1 n3.
Proof.
  intros.
  intros vl al Hw.
  destruct (Hdec n1 n3); auto.
  left.
  assert (Hw':=Hw).
  apply H0 in Hw'.
  destruct Hw' as [Hw' | Hw']; subst.
    apply DW_extract with (x:=index n2)(eq_a_dec:=Hdec) in Hw;
      simpl; auto.
    destruct Hw as [al' Hw].
    assert (Hw'':=Hw).
    apply H in Hw''.
    destruct Hw'' as [Hw'' | Hw'']; subst; auto.
    destruct (Hdec n1 n2); subst; auto.
    apply V_extract_spec in Hw''; try congruence.
    simpl in Hw''.
    destruct Hw'' as [Hw'' | Hw'']; auto.
      uniq_result. congruence.

    assert (Hw'':=Hw).
    apply H in Hw''.
    destruct Hw'' as [Hw'' | Hw'']; subst; congruence.
Qed.

Lemma everything_dominates_unreachable_blocks :
  forall n1 n2 (Hreach: ~ reachable n2),
  domination n1 n2.
Proof.
  unfold reachable.
  intros. intros vl al Hreach'.
  contradict Hreach. eauto.
Qed.

Lemma dom_reachable : forall n1 n2
  (H: reachable n2) (H0: domination n1 n2), reachable n1.
Proof.
  intros.
  destruct H as [vl [al H]].
  assert (H':=H).
  apply H0 in H'.
  apply DW_extract with (x:=index n1)(eq_a_dec:=Hdec) in H; simpl; auto.
    destruct H as [al' H].
    exists (V_extract Hdec (index n1) (index n2 :: vl)). exists al'. auto.

    destruct H' as [H' | H']; subst; auto.
Qed.

Lemma idom_sdom: forall l1 l2 (Hdom12 : imm_domination l1 l2),
  strict_domination l1 l2.
Proof.
  intros. destruct Hdom12. auto.
Qed.

Lemma sdom_isnt_refl: forall n1 n2 (Hreach: reachable n2)
  (Hdom12 : strict_domination n1 n2),
  n1 <> n2.
Proof.
  intros.
  destruct Hreach as [vl [al Hreach]].
  apply Hdom12 in Hreach.
  tauto.
Qed.

Lemma everything_sdominates_unreachable_blocks :
  forall n1 n2 (Hreach: ~ reachable n2),
  strict_domination n1 n2.
Proof.
  unfold reachable.
  intros.
  intros vl al Hreach'.
  contradict Hreach. eauto.
Qed.

Lemma sdom_reachable : forall n1 n2
  (H: reachable n2) (H0: strict_domination n1 n2), reachable n1.
Proof.
  intros.
  destruct H as [vl [al H]].
  assert (H':=H).
  apply H0 in H'. destruct H' as [J1 J2].
  apply DW_extract with (x:=index n1)(eq_a_dec:=Hdec) in H;
    simpl; auto.
  destruct H as [al' H].
  exists (V_extract Hdec (index n1) (index n2 :: vl)). exists al'.
  auto.
Qed.

Lemma sdom_dom: forall n1 n2
  (H: strict_domination n1 n2), domination n1 n2.
Proof.
  intros.
  intros vl al H0. apply H in H0. destruct H0; auto.
Qed.

Lemma dom_sdom: forall n1 n2
  (H: domination n1 n2) (H0: n1 <> n2), strict_domination n1 n2.
Proof.
  intros.
  intros vl al H1. apply H in H1.
  destruct H1 as [H1 | H1]; subst; auto.
    congruence.
Qed.

Section dom_acyclic_tran.

Hypothesis entry_has_no_preds : forall a0
  (Hin: In entry (XTree.successors_list successors a0)),
  False.

Lemma dom_acyclic: forall n1 n2
  (H: reachable n2) (H0: strict_domination n1 n2),
  ~ domination n2 n1.
Proof.
  intros.
  destruct H as [vl [al Hw]].
  apply DWalk_to_dpath in Hw; auto.
  destruct Hw as [vl0 [al0 Hp]].
  assert (Hw:=Hp).
  apply D_path_isa_walk in Hw.
  assert (Hw':=Hw).
  apply H0 in Hw'.
  destruct Hw' as [J1 J2].
  intros J.
  apply DW_extract with (x:=index n1)(eq_a_dec:=Hdec) in Hw; simpl; auto.
  destruct Hw as [al' Hw].
  assert (Hw'':=Hw).
  apply J in Hw''.
  destruct Hw'' as [Hw'' | Hw'']; subst; auto.
  apply V_extract_spec' in Hw''; try congruence.
  inv Hp.
    inv Hw''.

    simpl in Hw''.
    destruct Hw'' as [Hw'' | Hw'']; subst; try congruence.
    apply H5 in Hw''. inv Hw''.
    destruct y as [a0]. eauto.
Qed.

Lemma sdom_tran1: forall n1 n2 n3
  (H: strict_domination n1 n2) (H0: domination n2 n3), strict_domination n1 n3.
Proof.
  intros.
  destruct (Hdec n1 n3); subst.
    destruct (@reachable_dec n3).
      eapply dom_acyclic in H; eauto.
        contradict H; auto.
        apply dom_reachable in H0; auto.

      apply everything_sdominates_unreachable_blocks; auto.

    apply sdom_dom in H.
    apply dom_sdom; eauto using dom_tran.
Qed.

Lemma sdom_tran2: forall n1 n2 n3
  (H: domination n1 n2) (H0: strict_domination n2 n3), strict_domination n1 n3.
Proof.
  intros.
  destruct (Hdec n1 n3); subst.
    destruct (@reachable_dec n3).
      eapply dom_acyclic in H0; eauto.
      contradict H0; auto.

      apply everything_sdominates_unreachable_blocks; auto.

    apply sdom_dom in H0.
    apply dom_sdom; eauto using dom_tran.
Qed.

Lemma sdom_tran: forall n1 n2 n3
  (H: strict_domination n1 n2) (H0: strict_domination n2 n3),
  strict_domination n1 n3.
Proof.
  intros. apply sdom_dom in H0. eapply sdom_tran1; eauto.
Qed.

Lemma idom_injective: forall p l1 l2
  (Hidom1 : imm_domination p l1) (Hidom2 : imm_domination p l2)
  (Hrd1 : reachable l1) (Hrd2 : reachable l2)
  (Hneq : l1 <> l2)
  (Hdec0 : strict_domination l1 l2 \/ strict_domination l2 l1),
  False.
Proof.
  intros.
  destruct Hidom2 as [Hsdom2 Him2].
  destruct Hidom1 as [Hsdom1 Him1].
  destruct Hdec0 as [Hsdom | Hsdom].
    eapply Him2 in Hsdom.
    apply dom_acyclic in Hsdom1; auto.

    eapply Him1 in Hsdom.
    apply dom_acyclic in Hsdom2; auto.
Qed.

Lemma clos_trans_idom__sdom: forall a b
  (H: clos_trans T.elt imm_domination a b),
  strict_domination a b.
Proof.
  intros.
  apply clos_trans_t1n in H.
  induction H; eauto using idom_sdom, sdom_tran.
Qed.

Lemma idom_clos_refl_trans_idom__sdom: forall a b c
  (H': imm_domination a b)
  (H: clos_refl_trans T.elt imm_domination b c),
  strict_domination a c.
Proof.
  intros.
  apply clos_trans_idom__sdom.
  eapply step_clos_refl_trans__clos_trans; eauto.
Qed.

End dom_acyclic_tran.

Lemma sdom_dec : forall n1 n2,
  strict_domination n1 n2 \/ ~ strict_domination n1 n2.
Proof. intros. tauto. Qed. (* classic logic *)

Import Classical_Pred_Type.

Lemma non_sdom__inv: forall n1 n2
  (Hnsdom: ~ strict_domination n1 n2),
  exists vl, exists al, D_walk vertexes arcs
    (index n2) (index entry) vl al /\
    ~ (In (index n1) vl /\ n1 <> n2).
Proof.
  intros.
  apply not_all_ex_not in Hnsdom.
  destruct Hnsdom as [vl Hnsdom].
  apply not_all_ex_not in Hnsdom.
  destruct Hnsdom as [al Hnsdom].
  exists vl. exists al.
  tauto.
Qed.

Lemma sdom_ordered : forall n1 n2 n3
  (Hneq: n1 <> n2) (Hreach: reachable n3)
  (Hsdom: strict_domination n1 n3)
  (Hsdom': strict_domination n2 n3),
  strict_domination n1 n2 \/ strict_domination n2 n1.
Proof.
  intros.
  destruct (sdom_dec n1 n2) as [|Hnsdom12]; auto.
  destruct (sdom_dec n2 n1) as [|Hnsdom21]; auto.
  contradict Hsdom. intro Hsdom.
  destruct Hreach as [vl [al Hreach]].
  assert (Hw:=Hreach).
  apply Hsdom in Hw.
  destruct Hw as [Hin Hneq13].
  assert (Hw:=Hreach).
  apply Hsdom' in Hw.
  destruct Hw as [Hin' Heq23].

  (* on Hw, we need to figuire the closest one to l3 in l1 and l2,
     suppose l1 is, then we split hw at l1, so l2 cannot be in the part
     from l3 to l1.
  *)
  assert (Hw:=Hreach).
  assert (vl <> V_nil) as Hnqnil.
    destruct vl; auto.
      intro J. inv J.
  apply DW_cut with (x:=index n1) (w:=index n2) in Hw; try congruence;
    simpl; auto.
  destruct Hw as [al1 [al2 [vl1 [vl2
    [[J1 [J2 [J3 [J4 J5]]]]|[J1 [J2 [J3 [J4 J5]]]]]]]]]; subst.
  Case "1".
  eapply non_sdom__inv in Hnsdom21; eauto.
  destruct Hnsdom21 as [vl1' [al1' [J1' J2']]].

  assert ((D_walk vertexes arcs (index n3) (index entry)
    (vl1++vl1') (al1++al1') * ~ In (index n2) (vl1++vl1'))%type) as J.
    split.
      eapply DWalk_append; eauto.

      clear - J2' J5 Hneq.
      intro J. apply in_app_or in J.
      simpl in *.
      destruct J as [J | J]; auto.
  destruct J as [J3 J4].
  apply Hsdom' in J3.
  destruct J3 as [Hin'' Heq]; auto.

  Case "2".
  eapply non_sdom__inv in Hnsdom12; eauto.
  destruct Hnsdom12 as [vl2' [al2' [J1' J2']]].

  assert ((D_walk vertexes arcs (index n3) (index entry)
    (vl1++vl2') (al1++al2') * ~ In (index n1) (vl1++vl2'))%type) as J.
    split.
      eapply DWalk_append; eauto.

      clear - J2' J5 Hneq.
      intro J. apply in_app_or in J.
      simpl in *.
      destruct J as [J | J]; auto.
  destruct J as [J3 J4].
  apply Hsdom in J3.
  destruct J3 as [Hin'' Heq]; auto.
Qed.

Lemma idom_isnt_refl: forall l1 l2 (Hreach: reachable l2)
  (Hdom12 : imm_domination l1 l2),
  l1 <> l2.
Proof.
  intros.
  destruct Hdom12.
  eapply sdom_isnt_refl; eauto.
Qed.

Section rt_idom__sdom_ordered.

Hypothesis entry_has_no_preds : forall a0
  (Hin: In entry (XTree.successors_list successors a0)),
  False.

Lemma rt_idom__sdom_ordered: forall x y z
  (Hrt1 : clos_refl_trans T.elt imm_domination y x)
  (Hrt2 : clos_refl_trans T.elt imm_domination z x)
  (Hneq : y <> z)
  (Hreachx : reachable x),
  strict_domination y z \/ strict_domination z y.
Proof.
  intros.
  apply clos_refl_trans__eq_or_clos_trans in Hrt1.
  apply clos_refl_trans__eq_or_clos_trans in Hrt2.
  destruct Hrt1 as [EQ1 | Ht1].
    destruct Hrt2 as [EQ2 | Ht2].
      congruence.
      subst. right.
      eapply clos_trans_idom__sdom; eauto.
    destruct Hrt2 as [EQ2 | Hwk2].
      subst. left.
      eapply clos_trans_idom__sdom; eauto.

      apply sdom_ordered with (n3:=x);
        eauto using idom_sdom, clos_trans_idom__sdom.
Qed.

End rt_idom__sdom_ordered.

Lemma noone_sdom_entry: forall n
  (Hincfg: XTree.in_cfg successors entry)
  (Hnopred: XTree.successors_list
              (XTree.make_predecessors successors) entry = nil)
  (Hsdom : strict_domination n entry),
  False.
Proof.
  intros.
  assert (Hreach:=reachable_entry Hincfg).
  destruct Hreach as [vl [al Hreach]].
  assert (Hw:=Hreach).
  apply Hsdom in Hw.
  inv Hreach.
    tauto.

    simpl in H1.
    destruct y.
    apply XTree.make_predecessors_correct in H1.
    rewrite Hnopred in H1. tauto.
Qed.

Lemma sdom_of_reachable_is_in_cfg: forall n1 n2
  (Hreach: reachable n2)
  (Hsdom: strict_domination n1 n2),
  XTree.in_cfg successors n1.
Proof.
  intros.
  apply sdom_reachable in Hsdom; auto.
  apply reachable_is_in_cfg; auto.
Qed.

Lemma entry_doms_others: forall n (Hnentry: n <> entry),
  strict_domination entry n.
Proof.
  intros.
  intros vl al Hwk.
  assert (J:=Hwk).
  inv J; try congruence.
  apply DW_iny_vl in Hwk; auto.
    intro EQ. inv EQ.
Qed.

End Cfg. End Cfg.

(* A CFG named by atoms *)
Module ACfg := Cfg(ATree).
(* A CFG named by positives *)
Module PCfg := Cfg (PTree).

Import LLVMsyntax.
Import LLVMinfra.
(* The following defines CFGs used by Vellvm's semantics. *)

(* Compute a successor map of a list of blocks. *)
Fixpoint successors_blocks (bs: blocks) : ATree.t ls :=
match bs with
| nil => ATree.empty ls
| (l0, stmts_intro _ _ tmn) :: bs' =>
    ATree.set l0 (successors_terminator tmn) (successors_blocks bs')
end.

(* Compute a successor map of a function. *)
Definition successors (f: fdef) : ATree.t ls :=
let '(fdef_intro _ bs) := f in
successors_blocks bs.

(* The set of label names of a list of blocks *)
Fixpoint bound_blocks (bs: blocks) : set atom :=
match bs with
| nil => empty_set _
| (l0, _) :: bs' => l0::(bound_blocks bs')
end.

(* The set of label names of a function *)
Definition bound_fdef (f: fdef) : set atom :=
let '(fdef_intro _ bs) := f in
bound_blocks bs.

(* All CFG nodes of a funcion *)
Definition vertexes_fdef (f:fdef) : V_set :=
ACfg.vertexes (successors f).

(* All CFG edges of a funcion *)
Definition arcs_fdef (f:fdef) : A_set :=
ACfg.arcs (successors f).

(* l0 is reachable by f's entry. *)
Definition reachable (f:fdef) (l0:l) : Prop :=
match getEntryBlock f with
| Some (entry, _) =>
  ACfg.reachable (successors f) entry l0
| _ => false
end.

(* l1 dominates l2 in f. *)
Definition domination (f:fdef) (l1 l2:l) : Prop :=
match getEntryBlock f with
| Some (entry, _) =>
  ACfg.domination (successors f) entry l1 l2
| _ => False
end.

(* l1 strictly dominates l2 in f. *)
Definition strict_domination (f:fdef) (l1 l2:l) : Prop :=
match getEntryBlock f with
| Some (entry, _) =>
  ACfg.strict_domination (successors f) entry l1 l2
| _ => False
end.

Hint Unfold ACfg.domination ACfg.reachable ACfg.non_sdomination
            ACfg.strict_domination: cfg.

(* l1 immediately dominates l2 in f. *)
Definition imm_domination (f:fdef) (l1 l2:l) : Prop :=
strict_domination f l1 l2 /\
forall l0, strict_domination f l0 l2 -> domination f l0 l1.

Notation " f ~>* l " := (reachable f l) (at level 0): dom.
Notation " f |= l1 >> l2 " := (strict_domination f l1 l2) (at level 0): dom.
Notation " f |= l1 >>= l2 " := (domination f l1 l2) (at level 0): dom.
Notation " f |= l1 >>> l2 " := (imm_domination f l1 l2) (at level 0): dom.

(* Compute a predecessor map of a function. *)
Definition predecessors (f: fdef) : ATree.t ls :=
XATree.make_predecessors (successors f).

(* Check if b has no predecessors in f. *)
Definition has_no_predecessors (f: fdef) (b:block) : bool :=
match (predecessors f) !!! (getBlockLabel b) with
| nil => true
| _ => false
end.

(* Properties of successors *)
Lemma in_successors_blocks__in_bound_blocks: forall (n : ATree.elt) (s : ls)
  (bs : blocks) (Hinscs : (successors_blocks bs) ! n = Some s),
  In n (bound_blocks bs).
Proof.
  induction bs as [|[? []] bs]; simpl in *; intros.
    rewrite ATree.gempty in Hinscs. congruence.

    rewrite ATree.gsspec in Hinscs.
    destruct_if; auto.
Qed.

Lemma in_bound_blocks__in_successors_blocks: forall (n : ATree.elt)
  (bs : blocks) (Hin: In n (bound_blocks bs)),
  exists s, (successors_blocks bs) ! n = Some s.
Proof.
  induction bs as [|[? []] bs]; simpl in *; intros.
    tauto.

    rewrite ATree.gsspec.
    destruct_if; eauto.
    destruct Hin; try solve [auto | congruence].
Qed.

Lemma successors_blocks__InBlocksB : forall l0 a bs,
  In l0 (successors_blocks bs) !!! a ->
  exists ps0, exists cs0, exists tmn0,
    InBlocksB (a, stmts_intro ps0 cs0 tmn0) bs /\
    In l0 (successors_terminator tmn0).
Proof.
  unfold XATree.successors_list.
  induction bs as [|a0 bs]; simpl; intro.
    rewrite ATree.gempty in H. inv H.

    destruct a0 as [l1 [p c t]].
    destruct (id_dec l1 a); subst.
      rewrite ATree.gss in H.
      exists p. exists c. exists t.
      split; auto.
        eapply orb_true_iff. left. apply blockEqB_refl.

      rewrite ATree.gso in H; auto.
      apply IHbs in H; auto.
      destruct H as [ps0 [cs0 [tmn0 [J1 J2]]]].
      exists ps0. exists cs0. exists tmn0.
      split; auto.
        eapply orb_true_iff; eauto.
Qed.

Lemma successors__blockInFdefB : forall l0 a f,
  In l0 (successors f) !!! a ->
  exists ps0, exists cs0, exists tmn0,
    blockInFdefB (a, stmts_intro ps0 cs0 tmn0) f /\
    In l0 (successors_terminator tmn0).
Proof.
  destruct f as [fh bs]. simpl.
  apply successors_blocks__InBlocksB; auto.
Qed.

Lemma successors_blocks__blockInFdefB : forall l0 a fh bs,
  In l0 (successors_blocks bs) !!! a ->
  exists ps0, exists cs0, exists tmn0,
    blockInFdefB (a, stmts_intro ps0 cs0 tmn0) (fdef_intro fh bs) /\
    In l0 (successors_terminator tmn0).
Proof.
  intros.
  apply successors__blockInFdefB; auto.
Qed.

Lemma successors_terminator__successors_blocks : forall
  (bs : blocks)
  (l0 : l)
  (cs : phinodes)
  (ps : cmds)
  (tmn : terminator)
  (l1 : l)
  (HuniqF : uniqBlocks bs)
  (HbInF : InBlocksB (l0, stmts_intro cs ps tmn) bs)
  (Hin : In l1 (successors_terminator tmn)),
  successors_terminator tmn = (successors_blocks bs) !!! l0.
Proof.
  intros.
  induction bs.
    inversion HbInF.

    assert (J:=HuniqF).
    simpl_env in J.
    apply uniqBlocks_inv in J.
    destruct J as [J1 J2].
    simpl in *.
    apply orb_prop in HbInF.
    destruct a as [? []].
    destruct HbInF as [HbInF | HbInF].
      unfold blockEqB in HbInF.
      apply sumbool2bool_true in HbInF. inv HbInF.
      unfold XATree.successors_list.
      rewrite ATree.gss. auto.

      apply IHbs in J2; auto.
      unfold XATree.successors_list in *.
      destruct HuniqF as [J _].
      inv J.
      rewrite ATree.gso; auto.
        eapply InBlocksB__NotIn; eauto.
Qed.

Lemma successor_in_arcs : forall l0 cs ps tmn f l1
  (HuniqF : uniqFdef f)
  (HbInF : blockInFdefB (l0, stmts_intro cs ps tmn) f)
  (Hin : In l1 (successors_terminator tmn)),
  arcs_fdef f (A_ends (index l1) (index l0)).
Proof.
  intros.
  unfold arcs_fdef.
  destruct f as [fh bs]. apply uniqF__uniqBlocks in HuniqF.
  simpl.
  erewrite <- successors_terminator__successors_blocks; eauto.
Qed.

Lemma blockInFdefB__successors : forall a ps0 cs0 tmn0 f (Huniq: uniqFdef f)
  (H: blockInFdefB (a, stmts_intro ps0 cs0 tmn0) f),
  (successors f) ! a = Some (successors_terminator tmn0).
Proof.
  destruct f as [[] bs]. simpl.
  intros [J _].
  unfold uniqBlocks in J.
  destruct J as [J _].
  induction bs as [|a1 bs]; simpl; intros.
    congruence.

    destruct a1 as [l0 [ps1 cs1 tmn1]].
    apply orb_true_iff in H.
    destruct H as [H | H].
      apply blockEqB_inv in H. inv H.
      rewrite ATree.gss. auto.

      assert (J':=J). inv J'.
      simpl in J. simpl_env in J.
      assert (H':=H).
      apply IHbs in H'; auto.
      apply InBlocksB_In in H.
      apply uniq_app_3 in J.
      destruct (id_dec l0 a); subst.
        congruence.
        rewrite ATree.gso; auto.
Qed.

Lemma successors__successors_terminator : forall scs a f
  (H: Some scs = (successors f) ! a),
  exists ps0, exists cs0, exists tmn0,
    blockInFdefB (a, stmts_intro ps0 cs0 tmn0) f /\
    scs = successors_terminator tmn0.
Proof.
  destruct f as [fh bs]. simpl.
  induction bs as [|a0 bs]; simpl; intro.
    rewrite ATree.gempty in H. inv H.

    destruct a0 as [l1 [p c t]].
    destruct (id_dec l1 a); subst.
      rewrite ATree.gss in H.
      inv H.
      exists p. exists c. exists t.
      split; auto.
        eapply orb_true_iff. left. apply blockEqB_refl.

      rewrite ATree.gso in H; auto.
      apply IHbs in H; auto.
      destruct H as [ps0 [cs0 [tmn0 [J1 J2]]]].
      exists ps0. exists cs0. exists tmn0.
      split; auto.
        eapply orb_true_iff; eauto.
Qed.

(* Properties of bound *)
Lemma in_parents__in_bound: forall bs n
  (Hparents: In n (XATree.parents_of_tree (successors_blocks bs))),
  In n (bound_blocks bs).
Proof.
  intros.
  apply XATree.parents_of_tree__in_successors in Hparents.
  destruct Hparents as [s Hinscs].
  eapply in_successors_blocks__in_bound_blocks; eauto.
Qed.

Lemma in_bound__in_parents: forall bs n
  (Hin: In n (bound_blocks bs)),
  In n (XATree.parents_of_tree (successors_blocks bs)).
Proof.
  intros.
  apply in_bound_blocks__in_successors_blocks in Hin.
  apply XATree.parents_of_tree__in_successors in Hin; auto.
Qed.

Lemma in_parents__in_bound_fdef: forall f n
  (Hparents: In n (XATree.parents_of_tree (successors f))),
  In n (bound_fdef f).
Proof.
  destruct f.
  intros.
  apply in_parents__in_bound; auto.
Qed.

Lemma in_bound_fdef__in_parents: forall f n
  (Hin: In n (bound_fdef f)),
  In n (XATree.parents_of_tree (successors f)).
Proof.
  destruct f.
  intros.
  apply in_bound__in_parents; auto.
Qed.

Lemma blockInFdefB_in_bound_fdef : forall l0 s0 f
  (HbInF : blockInFdefB (l0, s0) f),
  In l0 (bound_fdef f).
Proof.
  intros.
  unfold bound_fdef.
  destruct f as [f b].
  generalize dependent s0.
  generalize dependent l0.
  induction b; simpl in *; intros.
    congruence.

    destruct a.
    apply orb_prop in HbInF.
    destruct HbInF as [HbInF | HbInF].
      unfold blockEqB in HbInF.
      apply sumbool2bool_true in HbInF. inv HbInF.
      simpl. auto.

      apply IHb in HbInF.
      simpl. auto.
Qed.

Section reachable__in_bound.

Variable f:fdef.
Hypothesis branches_in_bound_fdef: forall p ps0 cs0 tmn0 l2
  (J3 : blockInFdefB (p, stmts_intro ps0 cs0 tmn0) f)
  (J4 : In l2 (successors_terminator tmn0)),
  In l2 (bound_fdef f).

Lemma reachable__in_bound: forall a (Hrd: reachable f a),
  In a (bound_fdef f).
Proof.
  intros.
  unfold reachable in Hrd.
  match goal with
  | H: match ?e with
       | Some _ => _
       | None => is_true false
       end |- _ => remember e as R; destruct R; tinv H
  end.
  destruct b.
  destruct Hrd as [vl [al Hrd]].
  apply Dipaths.DW_endx_inv in Hrd.
  destruct Hrd as [Hrd | Hrd].
    apply in_parents__in_bound_fdef in Hrd; auto.

    apply XATree.children_of_tree__in_successors in Hrd.
    destruct Hrd as [p [sc [Hrd Hin]]].
    assert (In a (successors f) !!! p) as Hin'.
      unfold XATree.successors_list.
      unfold ATree.elt, l in *.
      rewrite Hrd. auto.
    apply successors__blockInFdefB in Hin'.
    destruct_conjs. eauto.
Qed.

End reachable__in_bound.

Lemma In_bound_fdef__blockInFdefB: forall f l3
  (Hin: In l3 (bound_fdef f)),
  exists s3, blockInFdefB (l3, s3) f = true.
Proof.
  destruct f as [[] bs].
  simpl. intros.
  induction bs as [|[l0 s0]]; simpl in *.
    tauto.

    destruct Hin as [Hin | Hin]; subst.
      exists s0.
      apply orb_true_intro.
      left. solve_refl.

      apply IHbs in Hin.
      destruct Hin as [s0' Hin].
      exists s0'.
      apply orb_true_intro. auto.
Qed.

Lemma in_bound__in_cfg : forall bs l0 (Hin: In l0 (bound_blocks bs)),
  XATree.in_cfg (successors_blocks bs) l0.
Proof.
  intros. left. apply in_bound__in_parents; auto.
Qed.

Lemma in_bound_blocks__in_dom: forall bs,
  (forall a, In a (bound_blocks bs) <-> a `in` dom bs).
Proof.
  induction bs as [|[] bs]; simpl; intros.
    split; intros. tauto. fsetdec.

    split; intros.
      destruct H as [H | H]; subst; auto.
        apply IHbs in H; auto.
      apply AtomSetFacts.add_iff in H.
      destruct H as [H | H]; subst; auto.
        apply IHbs in H; auto.
Qed.

Lemma notin_bound_blocks__notin_dom: forall bs,
  (forall a, ~ In a (bound_blocks bs) <-> a `notin` dom bs).
Proof.
  intros.
  split; intros H; intro J; apply H; apply in_bound_blocks__in_dom; auto.
Qed.

Lemma uniqFdef__NoDup_bounds_fdef: forall f (Huniq: uniqFdef f),
  NoDup (bound_fdef f).
Proof.
  destruct f as [[] bs]. simpl.
  intros.
  destruct Huniq as [[Huniq _] _].
  induction bs as [|[? []] bs]; simpl.
    constructor.

    inv Huniq.
    constructor; auto.
      apply notin_bound_blocks__notin_dom; auto.
Qed.

Section ElementsOfCfg__eq__Bound.

Variable f:fdef.

Hypothesis branches_in_bound_fdef: forall p ps0 cs0 tmn0 l2
  (J3 : blockInFdefB (p, stmts_intro ps0 cs0 tmn0) f)
  (J4 : In l2 (successors_terminator tmn0)),
  In l2 (bound_fdef f).

Lemma in_cfg__in_bound : forall l0
  (Hin: XATree.in_cfg (successors f) l0), In l0 (bound_fdef f).
Proof.
  destruct f as [fh bs].
  intros.
  destruct Hin as [Hin | Hin].
    apply in_parents__in_bound; auto.

    apply XATree.children_of_tree__in_successors in Hin.
    destruct Hin as [p [sc [Hscs Hin]]].
    assert (In l0 (successors (fdef_intro fh bs)) !!! p) as Hin'.
      unfold XATree.successors_list.
      unfold ATree.elt, l in *.
      rewrite Hscs. auto.
    apply successors__blockInFdefB in Hin'.
    destruct_conjs. eauto.
Qed.

Lemma elements_of_acfg__eq__bound :
  AtomSet.set_eq (XATree.elements_of_cfg (successors f) eq_atom_dec)
    (bound_fdef f).
Proof.
  split.
    intros x Hinx.
    apply XATree.in_elements_of_cfg__in_cfg in Hinx.
    apply in_cfg__in_bound; auto.

    intros x Hinx.
    apply XATree.in_elements_of_cfg__in_cfg.
    destruct f.
    apply in_bound__in_cfg in Hinx; auto.
Qed.

End ElementsOfCfg__eq__Bound.

(* Properties of vertexes *)
Lemma entry_in_vertexes : forall f l0 s0
  (Hentry : getEntryBlock f = Some (l0, s0)),
  vertexes_fdef f (index l0).
Proof.
  intros.
  unfold vertexes_fdef, ACfg.vertexes. destruct f as [f b].
  destruct b; simpl in *.
    congruence.
    inv Hentry.
    left. destruct s0.
    apply ACfg.XTree.parents_of_tree__in_successors.
    rewrite ATree.gss. eauto.
Qed.

Lemma blockInFdefB_in_vertexes : forall l0 s0 f
  (HbInF : blockInFdefB (l0, s0) f),
  vertexes_fdef f (index l0).
Proof.
  intros.
  left.
  apply blockInFdefB_in_bound_fdef in HbInF.
  apply in_bound_fdef__in_parents; auto.
Qed.

(* Properties of arcs *)
Lemma arcs_fdef_inv : forall f a1 a2,
  arcs_fdef f (A_ends (index a2) (index a1)) ->
  In a2 ((successors f) !!! a1).
Proof. auto. Qed.

(* Properties of predecessors *)
Lemma successors_predecessors_of_block : forall f l1 ps1 cs1 tmn1 l0,
  uniqFdef f ->
  blockInFdefB (l1, stmts_intro ps1 cs1 tmn1) f = true ->
  In l0 (successors_terminator tmn1) ->
  In l1 ((predecessors f) !!! l0).
Proof.
  unfold predecessors.
  intros.
  apply XATree.make_predecessors_correct; auto.
  unfold XATree.successors_list.
  erewrite blockInFdefB__successors; eauto.
Qed.

Lemma successors_predecessors_of_block': forall (f : fdef) b (Huniq : uniqFdef f)
  (l1 : atom)
  (Hscs : In (getBlockLabel b) ((successors f) !!! l1)),
  In l1 ((predecessors f) !!! (getBlockLabel b)).
Proof.
  intros.
  destruct b as [l0 ps0 cs0 tmn0].
  apply successors__blockInFdefB in Hscs.
  destruct Hscs as [ps1 [cs1 [tmn1 [HBinF Hintmn]]]].
  eapply successors_predecessors_of_block in Hintmn; eauto.
Qed.

Lemma has_no_predecessors_tinv: forall f b
  (Hnpred: has_no_predecessors f b = true),
  (predecessors f) !!! (getBlockLabel b) = nil.
Proof.
  unfold has_no_predecessors.
  intros.
  destruct (predecessors f) !!! (getBlockLabel b); tinv Hnpred; auto.
Qed.

Definition predecessors_dom__uniq_prop
  (scs:ATree.t ls) (pds: ATree.t ls) : Prop :=
(forall l1 l2, In l1 pds !!! l2 -> In l2 scs !!! l1) /\
forall l0 (Huniq: forall l1, NoDup (scs !!! l1)),
  NoDup (pds !!! l0).

Lemma predecessors_dom__uniq_aux_helper: forall m k (v:list atom)
  (Herr : m ! k = None)
  (Huniq1 : forall l1, NoDup ((ATree.set k v m) !!! l1)),
  NoDup v /\ forall l1, NoDup (m !!! l1).
Proof.
  intros.
  split.
    assert (J:=Huniq1 k).
    unfold XATree.successors_list in J.
    rewrite ATree.gsspec in J.
    destruct (ATree.elt_eq k k); try congruence.

    intros l0.
    assert (J:=Huniq1 l0).
    unfold XATree.successors_list in J.
    rewrite ATree.gsspec in J.
    unfold XATree.successors_list.
    destruct (ATree.elt_eq l0 k); subst; auto.
      rewrite Herr. auto.
Qed.

Lemma add_successors_dom__uniq: forall
  (m : ATree.t (list atom))
  (k : ATree.elt)
  (l0 : atom)
  (v2 v1 : list atom)
  (a : ATree.t (list atom))
  (H : forall l1 l2 : atom,
          In l1 a !!! l2 ->
          (l1 <> k -> In l2 m !!! l1) /\
          (l1 = k -> In l2 v1))
  (G1 : NoDup (v1++v2))
  (J : NoDup a !!! l0),
  NoDup (XATree.add_successors a k v2) !!! l0.
Proof.
  induction v2; simpl; intros; auto.
    rewrite_env ((v1++[a])++v2) in G1.
    apply IHv2 with (v1:=v1++[a]); clear IHv2; auto.
    Case "1".
      intros l1 l2 Hin.
      unfold XATree.successors_list in Hin.
      destruct (id_dec a l2); subst.
      SCase "1.1".
        rewrite ATree.gss in Hin.
        destruct_in Hin.
        SSCase "1.1.1".
          split; intro; try congruence.
            xsolve_in_list.

        SSCase "1.1.2".
          apply H in Hin.
          destruct Hin as [Hin1 Hin2].
          split; auto.
            intros EQ; subst.
            xsolve_in_list.

      SCase "1.2".
        rewrite ATree.gso in Hin; auto.
        apply H in Hin.
        destruct Hin as [Hin1 Hin2].
        split; auto.
          intros EQ; subst.
          xsolve_in_list.

    Case "2".
      unfold XATree.successors_list in J.
      unfold XATree.successors_list.
      destruct (id_dec a l0); subst.
      SCase "2.1".
        rewrite ATree.gss.
        unfold ATree.elt.
        remember (a0 ! l0) as R.
        destruct R; auto.
          constructor; auto.
            intro Hin.
            assert (In k (a0 !!! l0)) as Hin'.
              unfold XATree.successors_list.
              rewrite <- HeqR. auto.
            apply_clear H in Hin'.
            destruct Hin' as [_ Hin'].
            apply NoDup_split in G1. destruct G1 as [G1 _].
            eapply NoDup_disjoint in G1; simpl; eauto.

      SCase "2.2".
        rewrite ATree.gso; auto.
Qed.

Lemma predecessors_dom__uniq_aux: forall scs,
  predecessors_dom__uniq_prop scs (XATree.make_predecessors scs).
Proof.
  intros.
  unfold XATree.make_predecessors.
  apply ATree_Properties.fold_rec.
  Case "1".
    unfold predecessors_dom__uniq_prop.
    intros m m' a Heq [IH1 IH2].
    split.
    SCase "1.1".
      intros l1 l2.
      intros.
      erewrite XATree.eq_eli__eq_successors_list; eauto.

    SCase "1.2".
      intros l0 Huniq.
      apply IH2 with (l0:=l0).
        intros l1.
        assert (J:=Huniq l1).
        erewrite XATree.eq_eli__eq_successors_list; eauto.

  Case "2".
    unfold predecessors_dom__uniq_prop.
    unfold XATree.successors_list.
    split; intros; repeat rewrite ATree.gempty.
      tauto.
      auto.

  Case "3".
    unfold predecessors_dom__uniq_prop.
    intros m a k v Herr Hkh [IH1 IH2].
    split.
    SCase "3.1".
      clear - IH1 Herr.
      intros. eapply XATree.add_successors_correct''; eauto.

    SCase "3.2".
      intros l0 Huniq.
      assert (G:=Huniq).
      apply predecessors_dom__uniq_aux_helper in G; auto.
      destruct G as [G1 G2].
      apply IH2 with (l0:=l0) in G2; auto.
        clear - G1 G2 IH1 Herr.
        eapply add_successors_dom__uniq with (v1:=nil)(m:=m); eauto.
          intros l1 l2 Hin.
          split; auto.
            intro EQ; subst.
            apply IH1 in Hin.
            unfold XATree.successors_list in Hin.
            change l with ATree.elt in Hin.
            rewrite Herr in Hin. tauto.
Qed.

Lemma make_predecessors_dom__uniq: forall scs l0
  (Huniq: forall l1, NoDup (scs !!! l1)),
  NoDup ((XATree.make_predecessors scs) !!! l0).
Proof.
  intros.
  assert (J:=predecessors_dom__uniq_aux scs).
  unfold predecessors_dom__uniq_prop in J. destruct J; auto.
Qed.

(* Properties of entries *)
Lemma entry_in_parents: forall (f : fdef) (a : atom)
  (Hentry : getEntryLabel f = Some a),
  In a (XATree.parents_of_tree (successors f)).
Proof.
  intros.
  destruct f as [? [|[? []]]]; inv Hentry.
  simpl.
  apply ACfg.XTree.parents_of_tree__in_successors.
  rewrite ATree.gss. eauto.
Qed.

Lemma entry_in_bound_fdef: forall entry f (Hentry: getEntryLabel f = Some entry),
  ListSet.set_In entry (bound_fdef f).
Proof.
  intros.
  apply getEntryLabel__getEntryBlock in Hentry.
  destruct Hentry as [[le' []] [Hentry Heq]].
  simpl in Heq. subst.
  apply entryBlockInFdef in Hentry.
  eapply blockInFdefB_in_bound_fdef; eauto.
Qed.

Lemma le_in_cfg: forall f le
  (Hentry: getEntryLabel f = Some le),
  XATree.in_cfg (successors f) le.
Proof.
  intros.
  apply getEntryLabel__getEntryBlock in Hentry.
  destruct Hentry as [[le' []] [Hentry Heq]].
  simpl in Heq. subst.
  eapply entry_in_vertexes; eauto.
Qed.

(* The following defines the maximal iteration step for Kildall's algorithms. *)
Definition Pcubeplus (p:positive) : positive := (p * (p * p) + p)%positive.

Lemma Pcubeplus_ge: forall p1 p2 (Hge: (p1 >= p2)%positive),
  (Pcubeplus p1 >= Pcubeplus p2)%positive.
Proof.
  unfold Pcubeplus.
  intros.
  assert (p1 * (p1 * p1) >= p2* (p2 * p2))%positive.
    zify. repeat (apply Zmult_ge_compat; try omega).
  zify; omega.
Qed.

Definition plength A := fun (ls1 : list A) => P_of_succ_nat (length ls1).
Implicit Arguments plength [A].

Definition pnum_of_blocks_in_fdef (f: fdef) : positive :=
match f with
| fdef_intro _ bs => List.fold_left (fun acc _ => Psucc acc) bs 3%positive
end.

Definition num_iters (f: fdef): positive :=
let pn := pnum_of_blocks_in_fdef f in
Pcubeplus pn.

Lemma plength_of_blocks__eq__P_of_plus_nat: forall bs p,
  fold_left (fun (acc : positive) (_ : block) => Psucc acc) bs p =
    P_of_plus_nat p (length (bound_blocks bs)).
Proof.
  induction bs as [|[] bs]; simpl; intros; auto.
    rewrite IHbs.
    repeat rewrite Pplus_one_succ_l.
    rewrite P_of_plus_nat_Pplus_commut; auto.
Qed.


Require Export euclidean__axioms.
Require Export euclidean__tactics.
Require Export lemma__3__6a.
Require Export lemma__betweennotequal.
Require Export lemma__equalitysymmetric.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Definition lemma__ondiameter : forall D F K M N P Q, (euclidean__axioms.CI K F P Q) -> ((euclidean__axioms.Cong F D P Q) -> ((euclidean__axioms.Cong F M P Q) -> ((euclidean__axioms.BetS D F M) -> ((euclidean__axioms.BetS D N M) -> (euclidean__axioms.InCirc N K))))).
Proof.
intro D.
intro F.
intro K.
intro M.
intro N.
intro P.
intro Q.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
assert (* Cut *) (euclidean__axioms.neq D F) as H4.
- assert (* Cut *) ((euclidean__axioms.neq F M) /\ ((euclidean__axioms.neq D F) /\ (euclidean__axioms.neq D M))) as H4.
-- apply (@lemma__betweennotequal.lemma__betweennotequal D F M H2).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H7.
- assert (* Cut *) (euclidean__axioms.neq F D) as H5.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric D F H4).
-- assert (* Cut *) (~(~((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))))) as H6.
--- intro H6.
assert (* Cut *) (~(euclidean__axioms.BetS D F N)) as H7.
---- intro H7.
assert (* Cut *) (euclidean__axioms.BetS F N M) as H8.
----- apply (@lemma__3__6a.lemma__3__6a D F N M H7 H3).
----- apply (@H6).
------right.
left.
exact H8.

---- assert (* Cut *) (F = N) as H8.
----- apply (@euclidean__axioms.axiom__connectivity D F N M H2 H3 H7).
------intro H8.
apply (@H6).
-------left.
exact H8.

----- apply (@H6).
------right.
right.
exact H8.

--- assert (* Cut *) (euclidean__axioms.Cong F N F N) as H7.
---- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H7.
----- apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) H6).
----- apply (@euclidean__axioms.cn__congruencereflexive F N).
---- assert (* Cut *) (euclidean__axioms.InCirc N K) as H8.
----- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H8.
------ apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N)))).
-------intro H8.
assert (* Cut *) (False) as H9.
-------- apply (@H6 H8).
-------- assert (* Cut *) ((euclidean__axioms.BetS D N F) -> False) as H10.
--------- intro H10.
apply (@H8).
----------left.
exact H10.

--------- assert (* Cut *) (((euclidean__axioms.BetS F N M) \/ (F = N)) -> False) as H11.
---------- intro H11.
apply (@H8).
-----------right.
exact H11.

---------- assert (* Cut *) ((euclidean__axioms.BetS F N M) -> False) as H12.
----------- intro H12.
apply (@H11).
------------left.
exact H12.

----------- assert (* Cut *) ((F = N) -> False) as H13.
------------ intro H13.
apply (@H11).
-------------right.
exact H13.

------------ contradiction H9.

------ assert ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H9 by exact H8.
assert ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as __TmpHyp by exact H9.
destruct __TmpHyp as [H10|H10].
------- assert (* Cut *) (euclidean__axioms.BetS F N D) as H11.
-------- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H11.
--------- apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) H6).
--------- apply (@euclidean__axioms.axiom__betweennesssymmetry D N F H10).
-------- assert (* Cut *) (euclidean__axioms.InCirc N K) as H12.
--------- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H12.
---------- apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) H6).
---------- exists D.
exists N.
exists F.
exists P.
exists Q.
split.
----------- exact H.
----------- right.
split.
------------ exact H11.
------------ split.
------------- exact H0.
------------- exact H7.
--------- exact H12.
------- destruct H10 as [H11|H11].
-------- assert (* Cut *) (euclidean__axioms.InCirc N K) as H12.
--------- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H12.
---------- apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) H6).
---------- exists M.
exists N.
exists F.
exists P.
exists Q.
split.
----------- exact H.
----------- right.
split.
------------ exact H11.
------------ split.
------------- exact H1.
------------- exact H7.
--------- exact H12.
-------- assert (* Cut *) (N = F) as H12.
--------- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H12.
---------- apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) H6).
---------- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric N F H11).
--------- assert (* Cut *) (euclidean__axioms.InCirc N K) as H13.
---------- assert (* Cut *) ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) as H13.
----------- apply (@euclidean__tactics.NNPP ((euclidean__axioms.BetS D N F) \/ ((euclidean__axioms.BetS F N M) \/ (F = N))) H6).
----------- exists M.
exists M.
exists F.
exists P.
exists Q.
split.
------------ exact H.
------------ left.
exact H12.
---------- exact H13.
----- exact H8.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Solange Coupet-Grimal and William Delobel, 2006-01-09

Model of MPO statisfying Hypotheses in RPO_Types
*)

From CoLoR Require Import VPrecedence MultisetListOrder VRPO_Type VTerm
  ListUtil AccUtil LogicUtil.
From Coq Require Import Relations.

Module MPO (PT : VPrecedenceType).

  Module Export P := VPrecedence PT.
  Module Export S := Status PT.

  Inductive lt_mpo : relation term :=
    | mpo1 : forall f g ss ts, g <F f ->
        (forall t, In t ts -> lt_mpo t (Fun f ss)) ->
        lt_mpo (Fun g ts) (Fun f ss)
    | mpo2 : forall f g, f =F= g ->
        forall ss ts, mult (transp lt_mpo) ts ss ->
          lt_mpo (Fun g ts) (Fun f ss)
    | mpo3 : forall t f ss,
        ex (fun s => In s ss /\ (s = t \/ lt_mpo t s)) ->
        lt_mpo t (Fun f ss).

  Definition mytau (f : Sig) (r : relation term) := mult (transp r).

End MPO.

(***********************************************************************)

From CoLoR Require Import VRPO_Type.

Module MPO_Model (PT : VPrecedenceType) <: RPO_Model with Module P := PT.

  Module P := PT.
  Module Export MPO := MPO PT.

  Definition tau := mytau.

  Lemma tau_dec : forall f R ts ss,
    (forall t s, In t ts -> In s ss -> {R t s} + {~R t s}) ->
    {tau f R ts ss} + {~tau f R ts ss}.

  Proof.
    intros. unfold tau, mytau.
    apply mul_status_dec. hyp.
  Defined.

  Lemma status_eq : forall f g, f =F= g -> tau f = tau g.

  Proof.
    intros f g f_eq_g. unfold tau, mytau; trivial.
  Qed.

  Definition lt := lt_mpo.

  (* Verification des axiomes lt : *)

  Lemma lt_roots : forall f g, g <F f ->
    forall ss ts, (forall t, In t ts -> lt t (Fun f ss)) -> lt (Fun g ts) (Fun f ss).

  Proof.
    intros f g ltgf ss ts Hsub. unfold lt; apply mpo1; trivial.
  Qed.

  Lemma lt_status : forall f g, f =F= g ->
    forall ss ts, (forall t, In t ts -> lt t (Fun f ss)) ->
      tau f lt ts ss -> lt (Fun g ts) (Fun f ss).

  Proof.
    unfold lt, tau, mytau. intros f g feqg ss ts Hsub; apply mpo2; trivial.
  Qed.

  Lemma lt_subterm : forall f ss t,
    ex (fun s => In s ss /\ (s = t \/ lt t s)) -> lt t (Fun f ss).

  Proof.
    intros f ss t Hex; unfold lt; apply mpo3; trivial.
  Qed.

  Lemma lt_decomp : forall s t, lt s t ->
    ((ex (fun f => ex (fun g => ex (fun ss => ex (fun ts =>
      ltF f g /\
      (forall s, In s ss -> lt s (Fun g ts)) /\
      s = Fun f ss /\
      t = Fun g ts
    )))))
    \/
    ex (fun f => ex (fun g => ex (fun ss => ex (fun ts =>
      f =F= g /\
      (forall s, In s ss -> lt s (Fun g ts)) /\
      tau f lt ss ts /\
      s = Fun f ss /\
      t = Fun g ts)))))
    \/
    ex (fun f => ex (fun ts => ex (fun t' => In t' ts /\ (s = t' \/ lt s t')) /\
      t = Fun f ts)).

  Proof.
    intros s t Hst.
    unfold lt in Hst; inversion Hst as [f'' g'' ss' ts'' ltFfg Hsi'
      | f'' g'' feq ss' ts'' Hss'ts' Hsi'
      | f'' s' ts'' Hex]; subst.
    left; left.
    exists g''; exists f''; exists ts''; exists ss'.
    split; trivial; repeat split; trivial.
    left; right.
    exists g''; exists f''; exists ts''; exists ss'.
    split; elim feq; trivial; repeat split; trivial.
    intros t t_in_ts''.
    assert (IN_compat : forall ss x x', In x' ss -> x =A= x' -> In x ss).
    unfold eqA; intros; subst; trivial.
    elim (mult2element (transp lt_mpo) IN_compat ts'' ss' Hss'ts' t t_in_ts'').
    intros s Hs; elim Hs; clear Hs; intros s_in_ss Hs.
    apply mpo3; exists s; split; trivial.
    right.
    exists s'; exists ts''.
    split; trivial; elim Hex; clear Hex; intros t Ht.
    elim Ht; clear Ht; intros t_in_ts Ht.
    exists t; split; trivial.
    elim Ht; [left; subst | right]; trivial.
  Qed.

(***********************************************************************)

  Lemma SPO_to_status_SPO : forall f (r : relation term),
    forall ss,
      (forall s, In s ss -> (forall t u, r s t -> r t u -> r s u) /\ (r s s -> False)) ->
      (forall ts us, tau f r ss ts -> tau f r ts us -> tau f r ss us) /\ (tau f r ss ss -> False).

  Proof.
    intros f r.
    unfold tau, mytau.
    intros.
    apply transp_SPO_to_mult_SPO; trivial.
    unfold eqA, Term.eqA; intros; subst; trivial.
    unfold eqA, Term.eqA; intros; subst; trivial.
  Qed.

  Lemma mono_axiom : forall f (r : relation term),
    forall ss ts, one_less r ss ts -> tau f r ss ts.

  Proof.
    intros f r ss ts.
    unfold tau, mytau.
    apply one_less2mult.
    unfold eqA, Term.eqA; intros; subst; trivial.
  Qed.

(***********************************************************************)

  Definition wf_ltF := ltF_wf.
  Definition leF_dec := leF_dec.

  Definition lifting R := forall l, Accs lt l -> Restricted_acc (Accs lt) R l.

  Lemma status_lifting : forall f, lifting (tau f lt).

  Proof.
    intro f; unfold tau, mytau, lt.
    intro l.
    apply mult_lifting.
    unfold eqA, Term.eqA; intros; subst; trivial.
    unfold eqA, Term.eqA; intros; subst; trivial.
  Qed.

End MPO_Model.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Matrix implemented with Fin Function
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. reference:
  https://math-comp.github.io/htmldoc_1_14_0/mathcomp.algebra.matrix.html#matrix
  2. change it to Functor version, which can support multiple Base Type.
  3. especially we want to use RingType as Base Type, because lots of operations
    related to Base Type could be omitted.
 *)

(** The library all_algebra contain 'matrix' formalization *)
From mathcomp Require Import all_ssreflect all_algebra.

Require CoqSetting. (* to reset the default coq behavior of bullet *)

Require Export BasicConfig NatExt TupleExt SetoidListListExt HierarchySetoid.

Generalizable Variable A B C Aeq Beq Ceq Aadd Aopp Amul Ainv.

Open Scope A_scope.
Open Scope mat_scope.

Section FinFunMatrix.

  (* Note that, in the construction of _ringtype, we need the proof of "1 <> 0",
     I don't sure how to organize it, becuase in my hierarchy and in Coq's hierarchy,
     "1 <> " is a property in a field structure. So, I use limited field to instead
     ring structure *)

  (* Context `{R : Ring A Aadd A0 Aopp Amul A1 eq}. *)
  (* Add Ring ring_inst : make_ring_theory. *)

  Context `{F : Field A Aadd A0 Aopp Amul A1 Ainv eq}.
  Context `{Dec_eq : Decidable A eq}.

  Infix "+" := Aadd : A_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Infix "*" := Amul : A_scope.
  Add Field field_inst : make_field_theory.

  (** package A to ringType structure, to enable A be used as carrier type
    of MathComp.matrix.
    We must construct the required hierarchy one by one, otherwise, the later
    structure will fail.
    For example, choiceType need a eqType canonical declaration, and so on *)
  Section carrier_of_matrix.

    (* eqType *)
    Section eqType.
      (** reflect (x1 = x2) (x1 =? x2) *)
      Let A_eqbP : Equality.axiom Aeqb.
      Proof.
        hnf. intros. destruct (decidable x y) as [H|H]; auto.
        - apply Aeqb_true in H. rewrite H. constructor.
          apply Aeqb_true. auto.
        - apply Aeqb_false in H. rewrite H. constructor.
          apply Aeqb_false. auto.
      Qed.

      Let A_eqMixin := EqMixin A_eqbP.
      Canonical A_eqType := Eval hnf in EqType A A_eqMixin.
    End eqType.

    (* choiceType *)
    Section choiceType.
      Import Countable.

      Definition pickle (x : A) := 0%nat.
      Definition unpickle (n:nat) : option A := None.
      Definition pcancel : pcancel pickle unpickle. Admitted.
      Definition A_choiceType_mixin_of : mixin_of A :=
        Mixin pcancel.

      Let A_choiceMixin := ChoiceMixin A_choiceType_mixin_of.
      Canonical A_choiceType := ChoiceType A A_choiceMixin.
    End choiceType.

    (* zmodType *)
    Section zmodType.
      Import ssrfun.

      Let Aadd_assoc : associative Aadd.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Aadd_comm : commutative Aadd.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Aadd_left_id : left_id A0 Aadd.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Aadd_left_inv : left_inverse A0 Aopp Aadd.
      Proof.
        hnf;intros;ring.
      Qed.

      Let A_zmodMixin := ZmodMixin Aadd_assoc Aadd_comm Aadd_left_id
                           Aadd_left_inv.
      Canonical A_zmodType := Eval hnf in ZmodType _ A_zmodMixin.
    End zmodType.

    (* ringType *)
    Section ringType.
      Import ssrfun.

      Let Amul_assoc : associative Amul.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Amul_left_id : left_id A1 Amul.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Amul_right_id : right_id A1 Amul.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Amul_left_distr : left_distributive Amul Aadd.
      Proof.
        hnf;intros;ring.
      Qed.

      Let Amul_right_distr : right_distributive Amul Aadd.
      Proof.
        hnf;intros;ring.
      Qed.

      (* 1 != 0%R *)
      Let A_1_neq_0 : negb (eq_op A1 (GRing.zero A_zmodType)).
      Proof.
        cbv. assert (H : Aeqb A1 A0 = false).
        - apply Aeqb_false. apply field_1_neq_0.
        - apply Aeqb_false in H.
          destruct Dec_eq. destruct decidable; auto.
      Qed.

      Let A_ringMixin := RingMixin Amul_assoc Amul_left_id Amul_right_id
                           Amul_left_distr Amul_right_distr A_1_neq_0.
      Canonical A_ringType := Eval hnf in RingType _ A_ringMixin.

    End ringType.

  End carrier_of_matrix.

  (** Matrix type *)

  (* details about Mathcomp.matrix is complex *)
  (*   Print matrix.       (* Inductive matrix := Matrix (_:finfun_of) *)
  Print finfun_of.    (* Inductive finfun_of := FinfunOf (_:finfun_on) *)
  Print finfun_on.    (* Inductive finfun_on := finfun_nil | finfun_cons *)
   *)
  Definition mat (r c : nat) := matrix A r c.

  (** The equality is decidable *)
  Lemma meq_dec : forall {r c} (m1 m2 : mat r c), {m1 = m2} + {m1 <> m2}.
  Proof.
    intros. apply (@eq_comparable (matrix_eqType A_eqType r c)).
  Qed.

  (** Mathcomp issue: leq (S a) b <-> Nat.ltb a b *)
  (* Two different definitions for natural number comparision:
   leq is given by Mathcomp
   Nat.ltb is given by Coq Std.Lib *)
  Fact mathcomp_leq_iff_ltb : forall a b : nat, leq (S a) b <-> Nat.ltb a b.
  Proof.
    intros.
    destruct (@leP a b), (@Nat.ltb_spec a b).
  Admitted. (* ToDo: ? *)
  (* Some idea of the proof: owing to big difference of two definitions, maybe it is
   hard to proof directly. We can proove it with the help of induction relation le.
   1. Convert Nat.ltb to le，use Nat.ltb_spec，
      Convert leq to le, use leP.
   2. Nat.ltb_spec : forall x y : nat, BoolSpec (lt x y) (le y x) (Nat.ltb x y)
      if lt x y，Nat.ltb x y = true
      then     ，Nat.ltb x y = false

      leP: forall {m n : nat}, reflect (le m n) (leq m n)
      if le m n，leq m n = true
      then     ，leq m n = false *)

  (** Get element of a matrix *)
  Definition mnth' {r c} (m : mat r c) (ri ci : nat) : A.
  Proof.
    destruct (ri <? r) eqn:H1, (ci <? c) eqn:H2.
    { apply mathcomp_leq_iff_ltb in H1,H2.  (*  <? to <  *)
      pose (ri' := @Ordinal r ri H1).
      pose (ci' := @Ordinal c ci H2).
      exact (m ri' ci'). }
    all: exact A0.  (* all other situation is A0 *)
  Defined.

  Definition mnth {r c} (m : mat r c) (ri ci : nat) : A.
  Proof.
    destruct (ri < r) eqn:H1, (ci < c) eqn:H2.
    { exact (m (@Ordinal r ri H1) (@Ordinal c ci H2)). }
    all: exact A0.
  Defined.

  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
      m1 = m2 <->
        (forall ri ci (Hri : lt ri r) (Hci : lt ci c),
            mnth m1 ri ci = mnth m2 ri ci).
  Proof.
    intros. split; intros.
    { destruct (ri < r) eqn:H1, (ci < c) eqn:H2.
      { unfold mnth.
  Admitted.

  (** Create specific matrix *)
  Definition mk_mat_1_1 (a11 : A) : mat 1 1 :=
    matrix_of_fun_def
      (fun i j => match i,j with (* i : ordinal_finType 1 *)
                  | Ordinal 0 _, Ordinal 0 _ => a11
                  | _,_ => A0
                  end).
  Definition mk_mat_3_1 (a1 a2 a3 : A) : mat 3 1 :=
    matrix_of_fun_def
      (fun i j => match i,j with
                  | Ordinal 0 _, Ordinal 0 _ => a1
                  | Ordinal 1 _, Ordinal 0 _ => a2
                  | Ordinal 2 _, Ordinal 0 _ => a3
                  | _,_ => A0
                  end).
  Definition mk_mat_3_3 (a11 a12 a13 a21 a22 a23 a31 a32 a33 : A) : mat 3 3 :=
    matrix_of_fun_def
      (fun i j => match i,j with
                  | Ordinal 0 _, Ordinal 0 _ => a11
                  | Ordinal 0 _, Ordinal 1 _ => a12
                  | Ordinal 0 _, Ordinal 2 _ => a13
                  | Ordinal 1 _, Ordinal 0 _ => a21
                  | Ordinal 1 _, Ordinal 1 _ => a22
                  | Ordinal 1 _, Ordinal 2 _ => a23
                  | Ordinal 2 _, Ordinal 0 _ => a31
                  | Ordinal 2 _, Ordinal 1 _ => a32
                  | Ordinal 2 _, Ordinal 2 _ => a33
                  | _,_ => A0
                  end).
  Definition mk_mat_2_2 (a11 a12 a21 a22 : A) : mat 2 2 :=
    matrix_of_fun_def
      (fun i j => match i,j with
                  | Ordinal 0 _, Ordinal 0 _ => a11
                  | Ordinal 0 _, Ordinal 1 _ => a12
                  | Ordinal 1 _, Ordinal 0 _ => a21
                  | Ordinal 1 _, Ordinal 1 _ => a22
                  | _,_ => A0
                  end).

  (** Zero matrix *)
  Definition mat0 r c : mat r c
    := matrix_of_fun_def (fun i j => A0).

  (** A matrix is a nonzero matrix *)
  Definition matnonzero {r c} (m : mat r c) : Prop := m <> mat0 r c.

  (** Unit matrix *)
  Definition mat1 n : mat n n :=
    matrix_of_fun_def (fun i j => if (i == j) then A1 else A0).

  (** Mapping of a matrix *)
  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c :=
    matrix_of_fun_def (fun i j => f (m i j)).

  (** Mapping of two matrices *)
  Definition mmap2 {r c} (f : A -> A -> A) (m1  m2 : mat r c) : mat r c :=
    matrix_of_fun_def (fun i j => f (m1 i j) (m2 i j)).

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
                       (f_comm : forall a b : A, f a b = f b a)
                       (m1 m2 : mat r c),
      mmap2 f m1 m2 = mmap2 f m2 m1.
  Proof.
    intros.
  Admitted.

  Lemma mmap2_assoc : forall {r c} (f : A -> A -> A)
                        (f_assoc : forall a b c, f (f a b) c = f a (f b c))
                        (m1 m2 m3 : mat r c),
      mmap2 f (mmap2 f m1 m2) m3 = mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    intros.
  Admitted.

  (** Addition of matrix *)
  Definition madd {r c} (m1 m2 : mat r c) :=
    matrix_of_fun_def (fun i j => Aadd (m1 i j) (m2 i j)).
  Notation "m1 + m2" := (madd m1 m2) : mat_scope.

  Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 = m2 + m1.
  Proof.
  Admitted.

  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 + m2) + m3 = m1 + (m2 + m3).
  Proof.
  Admitted.

  Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m = m.
  Proof.
  Admitted.

  Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) = m.
  Proof.
  Admitted.

  (** Opposite of matrix *)
  Definition mopp {r c} (m : mat r c) : mat r c :=
    matrix_of_fun_def (fun i j => Aopp (m i j)).
  Notation "- m" := (mopp m) : mat_scope.

  Lemma mopp_opp : forall {r c} (m : mat r c), - - m = m.
  Proof.
  Admitted.

  Lemma mopp_exchange : forall {r c} (m1 m2 : mat r c), -m1 = m2 <-> m1 = -m2.
  Proof.
  Admitted.

  Lemma mopp_mat0 : forall {r c}, - (mat0 r c) = mat0 r c.
  Proof.
  Admitted.

  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) = mat0 r c.
  Proof.
  Admitted.

  Definition msub {r c} (m1 m2 : mat r c) :=
    matrix_of_fun_def (fun i j => Aadd (m1 i j) (Aopp (m2 i j))).
  Infix "-" := msub : mat_scope.

  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 = - (m2 - m1).
  Proof.
  Admitted.

  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c),
      (m1 - m2) - m3 = m1 - (m2 + m3).
  Proof.
  Admitted.

  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m = - m.
  Proof.
  Admitted.

  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) = m.
  Proof.
  Admitted.

  Lemma msub_self : forall {r c} (m : mat r c), m - m = (mat0 r c).
  Proof.
  Admitted.

  (** 矩阵数乘 *)
  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    matrix_of_fun_def (fun i j => Amul a (m i j)).

  Notation "a c* m" := (mcmul a m) : mat_scope.

  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    matrix_of_fun_def (fun i j => Amul (m i j) a).

  Notation "m *c a" := (mmulc m a) : mat_scope.

  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c),  m *c a = a c* m.
  Proof.
  Admitted.

  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) = (a * b) c* m.
  Proof.
  Admitted.

  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) = b c* (a c* m).
  Proof.
  Admitted.

  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) = (a c* m1) + (a c* m2).
  Proof.
  Admitted.

  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m = a c* m + b c* m.
  Proof.
  Admitted.

  (* 0 c* m = mat0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m = mat0 r c.
  Proof.
  Admitted.

  (* 1 * m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m = m.
  Proof.
  Admitted.

  (* (-a) * m = - (a * m) *)
  Lemma mcmul_neg : forall {r c} a (m : mat r c), (- a)%A c* m = - (a c* m).
  Proof.
  Admitted.

  (* (-a) * (- m) = (a * m) *)
  Lemma mcmul_neg_mopp : forall {r c} a (m : mat r c), (-a)%A c* (-m) = a c* m.
  Proof.
  Admitted.

  (* a * m = m -> a = 1 \/ m = 0 *)
  Lemma mcmul_same_imply_coef1_or_mzero : forall {r c} a (m : mat r c),
      a c* m = m -> (a = A1) \/ (m = mat0 r c).
  Proof.
  Abort.

  (* m1 <> 0 -> m2 <> 0 -> m1 = k c* m2 -> k <> 0 *)
  Lemma mat_eq_mcmul_implfy_coef_neq0 : forall {r c} (m1 m2 : mat r c) k,
      matnonzero m1 -> matnonzero m2 -> (m1 = k c* m2) -> k <> A0.
  Proof.
  Abort.

  (* m <> 0 -> k c* m = 0 -> k = 0 *)
  Lemma mcmul_mnonzero_eq0_imply_k0 : forall {r c} (m : mat r c) k,
      matnonzero m -> mat0 r c = k c* m -> k = A0.
  Proof.
  Abort.

  (** transpose *)
  Definition mtrans {r c} (m : mat r c): mat c r :=
    matrix_of_fun_def (fun i j => m j i).

  Notation "m \T" := (mtrans m) : mat_scope.

  Lemma mtrans_trans : forall {r c} (m : mat r c), m \T \T = m.
  Proof.
  Admitted.

  (** 矩阵乘法 *)
  Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
    @mulmx A_ringType r c s m1 m2.
  Infix "*" := mmul : mat_scope.

  Lemma mmul_add_distr_l : forall {r c A} (m1 : mat r c) (m2 m3 : mat c A),
      m1 * (m2 + m3) = m1 * m2 + m1 * m3.
  Proof.
  Admitted.

  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
      (m1 + m2) * m3 = (m1 * m3) + (m2 * m3).
  Proof.
  Admitted.

  Lemma mmul_assoc : forall {r c s A} (m1 : mat r c) (m2 : mat c s) (m3 : mat s A),
      (m1 * m2) * m3 = m1 * (m2 * m3).
  Proof. intros. apply Logic.eq_sym. apply mulmxA. Qed.

  Lemma mmul_0_l : forall {r c A} (m : mat c A), (mat0 r c) * m = mat0 r A.
  Proof.
  Admitted.

  Lemma mmul_0_r : forall {r c A} (m : mat r c), m * (mat0 c A) = mat0 r A.
  Proof.
  Admitted.

  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m = m.
  Proof.
  Admitted.

  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) = m.
  Proof.
  Admitted.

  (*   (** Vector type *)
  Definition vecr n := mat 1 n.
  Definition vecc n := mat n 1.

  (** ** Construct a matrix with a vector and a a matrix *)

  (** Construct by row *)
  Definition mconsr {r c} (v : vecr c) (m : mat r c) : mat (S r) c.
  Proof.
    destruct v,m.
    refine (mk_mat ((hd [] mat_data) :: mat_data0) _ _).
    - simpl. f_equal. auto.
    - simpl. split; auto.
      destruct mat_data; simpl in *; try lia.
  Defined.

  (** Construct by column *)
  Definition mconsc {r c} (v : vecc r) (m : mat r c) : mat r (S c).
  Proof.
    destruct v as [v], m as [m].
    refine (mk_mat (consc (hdc A0 v) m) _ _).
    - apply consc_height; auto. rewrite hdc_length; auto.
    - apply consc_width; auto. rewrite hdc_length; subst; auto.
  Defined. *)

  (** list list to matrix *)

  (* Definition l2m_old {r c} (dl : list (list A)) (H1 : length dl = r) *)
  (*   (H2 : width dl c) : mat r c := mk_mat dl H1 H2. *)

  Definition l2m {r c} (dl : list (list A)) : mat r c.
  Proof.
    (* destruct (ri <? r) eqn:H1, (ci <? c) eqn:H2. *)
    (* { apply mathcomp_leq_iff_ltb in H1,H2. *)
    (*   pose (ri' := @Ordinal r ri H1). *)
    (*   pose (ci' := @Ordinal c ci H2). *)
    (*   exact (m ri' ci'). } *)
    (*   all: exact A0. *)
    (* Defined. *)
    (* matrix_of_fun_def (fun i j => *)
    (*                      match  *)
    (*                        dlnth Amul (m i j) a). *)
    apply (matrix_of_fun_def (fun i j => A0)).
  Defined.

  (* Learn finfun_on *)
  Section check_finfun_on.
    Variable r c : nat.
    Let fin_r_c_T := prod_finType (ordinal_finType r) (ordinal_finType c).

    (* it's complex form *)
  (*     Check @finfun_on fin_r_c_T (fun _ : 'I_r * 'I_c => A)
      (@enum_mem fin_r_c_T
        (@mem ('I_r * 'I_c) (predPredType ('I_r * 'I_c))
          (@PredOfSimpl.coerce ('I_r * 'I_c) (pred_of_argType ('I_r * 'I_c))))).

    (* simple form, benefit from type inference *)
    Check finfun_on (fun _ : 'I_r * 'I_c => A)
      (enum_mem (mem (PredOfSimpl.coerce (pred_of_argType ('I_r * 'I_c))))). *)
  End check_finfun_on.

  (** convert "finfun_on" to "list (list A)" *)
  Definition finfun_on_to_dlist (r c : nat)
    (f : finfun_on (fun _ : 'I_r * 'I_c => A)
           (enum_mem (mem (PredOfSimpl.coerce (pred_of_argType ('I_r * 'I_c))))))
    : list (list A) :=
    match f with
    | finfun_nil => []
    | finfun_cons _ _ _ _ => []
    end.

  Definition m2l {r c} (m : mat r c) : list (list A).
  Proof.
    destruct m. destruct f.
    apply (finfun_on_to_dlist r c f).
  Defined.

  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof.
  Admitted.

  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
  Admitted.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
                            (H2 : width dl c), @m2l r c (l2m dl) = dl.
  Proof.
  Admitted.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) = m.
  Proof.
  Admitted.

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
      length d1 = r -> width d1 c ->
      length d2 = r -> width d2 c ->
      d1 <> d2 -> @l2m r c d1 <> l2m d2.
  Proof.
  Admitted.

  Lemma l2m_surj : forall {r c} (m : mat r c),
      (exists d, l2m d = m).
  Proof.
  Admitted.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
      m1 <> m2 -> m2l m1 <> m2l m2.
  Proof.
  Admitted.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
      length d = r -> width d c ->
      (exists m, @m2l r c m = d).
  Proof.
  Admitted.

  (** ** Other OPs and PROPs *)

  (** Convert between tuples and matrix *)

  (** tuple_3x3 -> mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : mat 3 3.
  Proof.
    destruct t as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    exact (mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33).
  Defined.

  (** mat_3x3 -> tuple_3x3 *)
  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A :=
    ((mnth m 0 0, mnth m 0 1, mnth m 0 2),
      (mnth m 1 0, mnth m 1 1, mnth m 1 2),
      (mnth m 2 0, mnth m 2 1, mnth m 2 2)).
  (*
  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A.
    destruct m. rename mat_data into dl.
    remember (hd [] dl) as l1.
    remember (hd [] (tl dl)) as l2.
    remember (hd [] (tl (tl dl))) as l3.
    remember (hd A0 l1, hd A0 (tl l1), hd A0 (tl (tl l1))) as t1.
    remember (hd A0 l2, hd A0 (tl l2), hd A0 (tl (tl l2))) as t2.
    remember (hd A0 l3, hd A0 (tl l3), hd A0 (tl (tl l3))) as t3.
    exact (t1, t2, t3).
  Defined.
   *)

  Lemma m2t_t2m_id_3x3 : forall (x : @T_3x3 A), m2t_3x3 (t2m_3x3 x) = x.
  (*     Proof.
    destruct x as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    simpl. auto.
  Qed. *)
  Admitted.

  (*   Lemma t2m_m2t_id_3x3 (m : mat 3 3) : t2m_3x3 (m2t_3x3 m) = m.
    Proof.
    unfold t2m_3x3, m2t_3x3. unfold mk_mat_3_3.
    intros ri ci Hi Hj.
    do 3 (destruct ri; [do 3 (destruct ci; auto); lia | idtac]). lia.
  Qed.
  Admitted. *)
  Lemma t2m_m2t_id_3x3 : forall (m : mat 3 3),
      t2m_3x3 (m2t_3x3 m) = m.
  Proof.
  Admitted.

  (** m[0,0] : mat_1x1 -> A *)
  Definition scalar_of_mat (m : mat 1 1) := mnth m 0 0.

End FinFunMatrix.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e480m2e240m1_15limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.