Require Import relations.

Set Implicit Arguments.

Section weak_diamond_property.

Variables (I A : Set) (R_ : Rfam I A) (L E : relation I).

Definition LE (x y : I) := L x y \/ E x y.

Notation "R_ << j" := (Rfam_union_S R_ L j) (at level 7, no associativity).
Notation "R_ <<= j" := (Rfam_union_S R_ (L (+) E) j) (at level 7, no associativity).

Definition curly (i : I) : relation A := R_<<i* ; R_ i # ; R_<<i*.
Notation "~~> j" := (curly j) (at level 7, no associativity).

Definition curlyn (i : I) (n : nat) : relation A := nfold (curly i) n.

(* The weak diamond property. *)

Definition weak_diamond_property :=
  forall a b c alpha beta,
  LE beta alpha ->
  R_ beta a c ->
  R_ alpha a b ->
  exists d : A, (
    ((R_<< beta)* ; R_ alpha # ; (R_<< alpha)*)  c d  /\
    (R_<<= alpha)* b d /\
    (L beta alpha -> (R_<< alpha)* b d)
  ).

Hypothesis oeq : order_up_to_eq L E.
Hypothesis teq : total_up_to_eq L E.
Hypothesis wfL : well_founded L.
Hypothesis wdp : weak_diamond_property.

Hypothesis REcongr : forall (i j : I), E i j -> samerel (R_ i) (R_ j).

Variable top : I.
Hypothesis top_top : forall i : I, i = top \/ L i top.

Variable bot : I.
Hypothesis bot_bot : forall i : I, i = bot \/ L bot i.
Hypothesis bot_id : samerel (R_ bot) (@eq A).

(* Lemmas *)

(* reflexive WDP *)

Lemma wdp_refl :
  forall a b c alpha beta,
  LE beta alpha ->
  (R_ beta #) a c ->
  (R_ alpha #) a b ->
  exists d : A, (
    ((R_<< beta)* ; R_ alpha # ; (R_<< alpha)*) c d  /\
    (R_<<= alpha)* b d /\
    (L beta alpha -> (R_<< alpha)* b d)
  ).
Proof.
  intros a b c alpha beta LEba Rac Rab.
  destruct Rab as [a b Rab | a].
  destruct Rac as [a c Rac | a].
  (* none empty *)
  apply wdp with a.
  exact LEba.
  exact Rac.
  exact Rab.
  (* Rac empty *)
  exists b; split.
  exists a; split.
  apply refl_trans_refl.
  exists b; split.
  left; exact Rab.
  apply refl_trans_refl.
  split.
  apply refl_trans_refl.
  intro Lba.
  apply refl_trans_refl.
  destruct Rac as [a c Rac | a].
  (* Rab empty *)
  exists c; split.
  exists c; split.
  apply refl_trans_refl.
  exists c; split.
  right.
  apply refl_trans_refl.
  split.
  apply refl_trans_step.
  exists beta.
  split.
  destruct LEba as [Lba | Eba].
  left; exact Lba.
  right; exact Eba.
  exact Rac.
  intro Lba.
  apply refl_trans_step.
  exists beta; split.
  exact Lba.
  exact Rac.
  (* both empty *)
  exists a.
  split.
  exists a; split.
  apply refl_trans_refl.
  exists a; split.
  right.
  apply refl_trans_refl.
  split.
  apply refl_trans_refl.
  intro Lba; apply refl_trans_refl.
Qed.

(* Eq_star *)

Lemma eq_star :
  forall (X : Set),
  subrel (@eq X *) (@eq X).
Proof.
  intros X a b Rab.
  induction Rab; trivial.
  rewrite IHRab1; exact IHRab2.
Qed.

(* Lemmas about L and E *)

Lemma le_le :
  forall (a b c : I),
  LE a b ->
  LE b c ->
  LE a c.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LEinv [_ Ltrans]]].
  intros a b c [ab | ab] [bc | bc].
  left; apply (Ltrans a b c ab bc).
  left; apply (LEinv a a b c ab (Erefl a) bc).
  left; apply (LEinv b a c c bc (Esymm a b ab) (Erefl c)).
  right; apply (Etrans a b c ab bc).
Qed.

Lemma le_lt :
  forall (a b c : I),
  LE a b ->
  L b c ->
  L a c.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LEinv [_ Ltrans]]].
  intros a b c [ab | ab] bc.
  apply (Ltrans a b c ab bc).
  apply (LEinv b a c c bc (Esymm a b ab) (Erefl c)).
Qed.

Lemma lt_le :
  forall (a b c : I),
  L a b ->
  LE b c ->
  L a c.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LEinv [_ Ltrans]]].
  intros a b c ab [bc | bc].
  apply (Ltrans a b c ab bc).
  apply (LEinv a a b c ab (Erefl a) bc).
Qed.

(* Lemmas about R_<<= and R_<< *)

Lemma lt_subrel_le :
  forall (i : I),
  subrel (R_<< i) (R_<<= i).
Proof.
  intros i x y lt.
  destruct lt as [z [Lzy Rzxy]].
  exists z.
  split.
  left.
  exact Lzy.
  exact Rzxy.
Qed.

Lemma red_incl_le :
  forall alpha beta,
  LE alpha beta ->
  subrel (R_<<= alpha) (R_<<= beta).
Proof.
  intros alpha beta LEab.
  apply subrel_Rfam_union_P.
  intros i LEialpha.
  apply (le_le LEialpha LEab).
Qed.

Lemma red_incl_lt :
  forall alpha beta,
  L alpha beta ->
  subrel (R_<<= alpha) (R_<< beta).
Proof.
  intros alpha beta LEab.
  apply subrel_Rfam_union_P.
  intros i LEialpha.
  apply (le_lt LEialpha LEab).
Qed.

Lemma max_label :
  forall (i j beta : I) (a b c d : A),
  L i beta ->
  (R_ <<= i *) a b ->
  L j beta ->
  (R_ <<= j *) c d
  ->
  exists (gamma : I), L gamma beta /\
        (R_ <<= gamma *) a b /\ (R_ <<= gamma *) c d.
Proof.
  intros i j beta a b c d Lib Rab Ljb Rcd.
  destruct (teq i j) as [Lij | [Eij | Lji]].
  (* L i j *)
  exists j; split; [exact Ljb | split; [ | exact Rcd]].
  apply refl_trans_monotone with (R_<<= i).
  apply red_incl_le; left; exact Lij.
  exact Rab.
  (* E i j *)
  exists j; split; [exact Ljb | split].
  apply refl_trans_monotone with (R_<<= i).
  apply red_incl_le; right; exact Eij.
  exact Rab.
  exact Rcd.
  (* L j i *)
  exists i; split; [exact Lib | split; [exact Rab | ]].
  apply refl_trans_monotone with (R_<<= j).
  apply red_incl_le; left; exact Lji.
  exact Rcd.
Qed.

Lemma Rlt_eq :
  forall i j,
  E i j ->
  subrel (R_<< i) (R_<< j).
Proof.
  intros i j Eij x y [i' [Li'i Rxy]].
  exists i'; split.
  apply lt_le with i.
  exact Li'i.
  right; exact Eij.
  exact Rxy.
Qed.

Lemma Rle_eq :
  forall i j,
  E i j ->
  subrel (R_<<= i) (R_<<= j).
Proof.
  intros i j Eij x y [i' [Li'i Rxy]].
  exists i'; split.
  apply le_le with i.
  exact Li'i.
  right; exact Eij.
  exact Rxy.
Qed.

(* Lemmas about bot *)

Lemma bot_eq :
  forall gamma,
  E gamma bot ->
  gamma = bot.
Proof.
  destruct oeq as [[Erefl _] [LinvE [Lirrefl _]]].
  intros gamma Egammabot.
  destruct (bot_bot gamma).
  exact H.
  assert (Lbotbot := LinvE bot bot gamma bot H (Erefl bot) Egammabot).
  destruct (Lirrefl bot Lbotbot).
Qed.

Lemma bot_lt :
  forall gamma,
  ~(L gamma bot).
Proof.
  destruct oeq as [_ [_ [Lirrefl Ltrans]]].
  intros gamma Lgammabot.
  destruct (bot_bot gamma).
  rewrite H in Lgammabot.
  destruct (Lirrefl bot Lgammabot).
  destruct (Lirrefl bot (Ltrans bot gamma bot H Lgammabot)).
Qed.

Lemma bot_red_step :
  forall gamma,
  E gamma bot ->
  subrel (R_ gamma) (@eq A).
Proof.
  intros gamma Egammabot.
  rewrite (bot_eq Egammabot).
  apply bot_id.
Qed.

Lemma bot_red_le :
  forall gamma,
  E gamma bot ->
  subrel ((R_<<= gamma)*) (@eq A).
Proof.
  intros gamma Egammabot.
  rewrite (bot_eq Egammabot).
  apply subrel_trans with (eq *).
  apply refl_trans_monotone.
  intros a b [i [LEibot Riab]].
  destruct LEibot.
  destruct (bot_lt H).
  rewrite (bot_eq H) in Riab.
  apply bot_id.
  exact Riab.
  apply eq_star.
Qed.

Lemma bot_red_lt :
  forall gamma,
  E gamma bot ->
  subrel ((R_<< gamma)*) (@eq A).
Proof.
  intros gamma Egb.
  apply subrel_trans with ((R_<<= gamma)*).
  apply refl_trans_monotone.
  apply lt_subrel_le.
  apply bot_red_le.
  exact Egb.
Qed.

Lemma lt_red_lt :
  forall beta,
  forall a b,
  (R_<< beta) * a b ->
  (beta = bot /\ a = b)
  \/ (L bot beta /\ exists gamma, L gamma beta /\ (R_<<= gamma) * a b).
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros beta a b ab.
  pose proof (bot_bot beta) as [Ebetabot | Lbotbeta].
  (* bot = beta *)
  rewrite Ebetabot in *.
  left; split; [reflexivity | ].
  apply (bot_red_lt (Erefl bot)).
  exact ab.
  (* L bot beta *)
  right; split.
  exact Lbotbeta.
  (* induction *)
  induction ab as [a b ab | a | a b c ab IHab bc IHbc].
  (* step *)
  destruct ab as [i [Libeta Riab]].
  exists i; split; [exact Libeta | ].
  apply refl_trans_step; exists i; split.
  right; apply Erefl.
  exact Riab.
  (* refl *)
  exists bot; split; [exact Lbotbeta | apply refl_trans_refl].
  (* trans *)
  destruct IHab as [u [Lubeta IHab]].
  destruct IHbc as [w [Lwbeta IHbc]].
  destruct (max_label Lubeta IHab Lwbeta IHbc) as [gamma [Lgammabeta [max_ab max_bc]]].
  exists gamma; split.
  exact Lgammabeta.
  apply refl_trans_trans with b; [exact max_ab | exact max_bc].
Qed.

(* Lemmas about ~~> *)

Lemma le_trans_eq_curly_trans :
  forall (i : I), samerel ((R_ <<= i)*) ((~~>i)*).
Proof.
  split.
  (* => direction *)
  apply refl_trans_monotone.
  intros x y [j [[Lji | Eij] Rjxy]].
  (* L j i *)
  exists y.
  split.
  apply refl_trans_step.
  exists j.
  split.
  exact Lji.
  exact Rjxy.
  exists y.
  split.
  right.
  apply refl_trans_refl.
  exists x.
  split.
  apply refl_trans_refl.
  (* E j i *)
  exists y.
  split.
  left.
  apply REcongr with (1:=Eij) (2:=Rjxy).
  apply refl_trans_refl.
  (* <= direction *)
  apply refl_trans_monotone_trans.
  intros x z xz.
  destruct xz as [y [xy [y' [yy' y'z]]]].
  apply refl_trans_trans with y.
  apply refl_trans_monotone with (R_<< i).
  apply lt_subrel_le.
  exact xy.
  apply refl_trans_trans with y'.
  destruct yy' as [y y' yy' | y].
  apply refl_trans_step.
  exists i.
  split.
  right.
  apply (proj1 (proj1 oeq)).
  exact yy'.
  apply refl_trans_refl.
  apply refl_trans_monotone with (R_ << i).
  apply lt_subrel_le.
  exact y'z.
Qed.

(* The main diagram X *)

Definition X (alpha beta : I) :=
  forall a b' b c,
  (R_<<= beta)* a c ->
  (R_ alpha #) a b' ->
  (R_<< alpha)* b' b ->
  exists d,
    (Runion (R_<< alpha) (R_<<= beta))* b d /\
    ((R_<< beta)* ; R_ alpha # ; (R_<< alpha)*) c d.

Lemma X_confluence :
  forall i : I,
  X i i ->
  confluent (R_<<= i).
Proof.
  destruct oeq as [[_ [Esymm _]] _].
  intros i Xii.
  apply strip_lemma.
  intros a b c ab ac.
  destruct ab as [j [LEji ab]].
  assert (H: exists d, ((R_<< i (+) R_<<= i) *) b d /\ (R_<< i *; R_ i #; R_<< i *) c d).
  destruct LEji as [Lji | Eji].
  apply (Xii a a b c); [exact ac | right | ].
  apply refl_trans_step. exists j; split; [exact Lji |  exact ab].
  apply (Xii a b b c); [exact ac | | ].
  left.
  apply REcongr with j.
  exact (Esymm j i Eji).
  exact ab.
  apply refl_trans_refl.
  destruct H as [d [bd cd]].
  exists d; split.
  apply trans_Runion_elim with (R_ << i).
  apply lt_subrel_le.
  exact bd.
  apply le_trans_eq_curly_trans.
  apply refl_trans_step.
  exact cd.
Qed.

Lemma X_top :
  X top top ->
  confluent (Rfam_union R_).
Proof.
  intros Xtt.
  apply confluent_eq with (R_<<= top).
  split; intros a b [i Riab]; exists i.
  apply Riab.
  split.
  destruct (top_top i) as [Eit | Lit].
  right; rewrite Eit; apply (proj1 (proj1 oeq)).
  left; exact Lit.
  exact Riab.
  apply X_confluence; exact Xtt.
Qed.

(* Diagrams SS1, SS1_lt and SS2 for proving X *)

Lemma SS1 :
  forall alpha: I,
  (forall alpha', L alpha' alpha -> X alpha' alpha') ->
  forall gamma,
  L gamma alpha ->
  confluent (R_<<= gamma).
Proof.
  intros alpha IH gamma Lga.
  apply X_confluence.
  apply IH.
  exact Lga.
Qed.

Lemma SS1_lt :
  forall alpha: I,
  (forall alpha', L alpha' alpha -> X alpha' alpha') ->
  forall gamma,
  LE gamma alpha ->
  confluent (R_<< gamma).
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros alpha IH gamma LEga a b c Rab Rac.
  destruct (lt_red_lt Rab) as [[Egb Eab] | [Lbg [gamma' [Lg'g Rab']]]].
  rewrite <- Eab.
  exists c; split; [exact Rac | apply refl_trans_refl].
  destruct (lt_red_lt Rac) as [[Egb _] | [_ [gamma'' [Lg''g Rac'']]]].
  rewrite Egb in Lg'g.
  destruct (bot_lt Lg'g).
  destruct (max_label Lg'g Rab' Lg''g Rac'') as [m [Lmg [ab ac]]].
  assert (Lma := lt_le Lmg LEga).
  destruct (SS1 IH Lma ab ac) as [d [bd cd]].
  exists d; split;
  apply refl_trans_monotone with (R_<<= m).
  apply (red_incl_lt Lmg).
  exact bd.
  apply (red_incl_lt Lmg).
  exact cd.
Qed.

Lemma SS2 :
  forall alpha beta : I,
  LE beta alpha ->
  (forall alpha' : I, L alpha' alpha -> X alpha' alpha') ->
  (forall gamma : I, L gamma beta -> X beta gamma) ->
  forall (n : nat),
  forall (a b c : A),
  (R_<< beta)* a c ->
  (curlyn beta n) a b ->
   exists d : A, (curlyn beta n) c d /\ (R_<< beta)* b d.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros alpha beta LEba IH1 IH2.
  induction n as [|n IHn]; simpl; intros a b c ac ab.

  (* base case n = 0 *)
  rewrite <- ab.
  exists c; split; [reflexivity | exact ac].

  (* setting up the n = 1 subdiagram *)
  destruct ab as [a' [aa' a'b]].
  assert (dia : exists d', (R_<< beta)* a' d' /\ (~~> beta c d')).
  destruct aa' as [a0 [aa0 a0a']].

  (* MAPPING
     a----a0----a1----a'--...--b
     |    |           |        |
     |    |           |        |
     c----d0----d1----d'--...--d
  *)

  destruct (SS1_lt IH1 LEba aa0 ac) as [d0 [a0d0 cd0]].
  (* finding gamma for a0d0 *)
  destruct (lt_red_lt a0d0) as [[Ebb Ea0d0]| [Lbb [gamma [Lgb Rg_a0d0]]]].
  exists a'; split; [apply refl_trans_refl | ].
  exists a0; split; [rewrite Ea0d0 | ]; trivial.
  (* applying IH2 *)
  destruct a0a' as [a1 [a0a1 a1a']].
  destruct (IH2 gamma Lgb a0 a1 a' d0 Rg_a0d0 a0a1 a1a') as [d' [a'd' d0d']].
  exists d'; split.
  (* a' -- d' *)
  apply trans_Runion_elim with (R_<<= gamma).
  apply red_incl_lt; exact Lgb.
  apply refl_trans_monotone with (R_ << beta(+)R_ <<= gamma).
  apply Runion_symm.
  exact a'd'.
  (* c -- d' *)
  destruct d0d' as [d1 [d0d1 d1d']].
  exists d1; split.
  apply refl_trans_trans with d0.
  exact cd0.
  apply refl_trans_monotone with (R_ << gamma).
  apply subrel_trans with (R_<<= gamma).
  apply lt_subrel_le.
  apply red_incl_lt; exact Lgb.
  exact d0d1.
  exact d1d'.

  (* using ind hypothesis *)
  destruct dia as [d' [a'd' cd']].
  destruct (IHn a' b d' a'd' a'b) as [d [d'd bd]].
  exists d; split; [ | exact bd].
  exists d'; split; [exact cd' | exact d'd].
Qed.

Lemma X_n_eq_1_beta'_eq_bottom :
  forall (alpha beta : I),
  LE beta alpha ->
  (forall alpha' : I, L alpha' alpha -> X alpha' alpha') ->
  (forall alpha' : I, L alpha' beta -> X alpha alpha') ->
  (forall gamma : I, L gamma beta -> X beta gamma) ->
  forall (a b c : A),
  ((R_ alpha #) ; (R_ << alpha *)) a b ->
  ((R_ beta #) ; (R_ << beta *)) a c
  ->
  exists d,
  ((R_ << beta *); (R_ alpha #); (R_ << alpha *)) c d /\
  ((R_ << alpha (+) R_ <<= beta) *) b d.
Proof.
  (* MAPPING
     a--------------b1-----b
     |    wdp       |  SS1 |
     c1---w1---w2---w  and |
     | SS1| X(a, <b) \ SS2 |
     c----d1--d2--d3--d4---d
  *)

  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros alpha beta LEba Xaa Xaa' Xbg a b c [b1 [Rab1 Rb1b]] [c1 [Rac1 Rc1c]].

  (* First handle the case E beta bot *)
  destruct (bot_bot beta) as [Ebb | Lbb].
  assert (Ebb' : E beta bot).
  rewrite Ebb; apply Erefl.

  destruct Rac1 as [a c1 Rac1 | a ].
  (* Rac1 non-empty *)
  apply (bot_red_step Ebb') in Rac1.
  apply (bot_red_lt Ebb') in Rc1c.
  rewrite <- Rc1c; rewrite <- Rac1.
  exists b; split; [exists a; split; [ | exists b1; split] | ];
  try (apply refl_trans_refl).
  exact Rab1.
  apply Rb1b.
  (* Rac1 empty *)
  apply (bot_red_lt Ebb') in Rc1c.
  rewrite <- Rc1c.
  exists b; split; [exists a; split; [ | exists b1; split] | ];
  try (apply refl_trans_refl).
  exact Rab1.
  apply Rb1b.

  (* wdp diagram, joins in w.
     We have (R <<= alpha * ) b1 w in general,
     And also (R << alpha * ) b1 w if L beta alpha *)
  pose proof (wdp_refl LEba Rac1 Rab1) as [w [Rc1w [Rb1w wdpL]]].

  destruct Rc1w as [w1 [Rc1w1 [w2 [Rw1w2 Rw2w]]]].

  (* bottom left diagram, using SS1 *)
  assert (betaconf := SS1_lt Xaa LEba).
  destruct (betaconf c1 w1 c Rc1w1 Rc1c) as [d1 [Rw1d1 Rcd1]].

  (* subdiagram X(a, <b) *)
  destruct (lt_red_lt Rw1d1) as [[Ebb _] | [_ [gamma [Lgb Rgw1d1]]]].
  rewrite Ebb in Lbb; destruct (Lirrefl bot Lbb).
  assert (Lga := lt_le Lgb LEba).
  destruct (Xaa' gamma Lgb w1 w2 w d1 Rgw1d1 Rw1w2 Rw2w) as [d4 [Ruwd4 Rd1d4]].
  assert (Rwd4 : (R_ << alpha *) w d4).
  apply trans_Runion_elim with (R_<<= gamma).
  apply red_incl_lt; exact Lga.
  apply refl_trans_monotone with (R_ << alpha (+) R_ <<= gamma).
  apply Runion_symm.
  exact Ruwd4.

  (* destruct bottom reduction sequence completely,
     and transform gamma to beta *)
  destruct Rd1d4 as [d2 [Rgd1d2 [d3 [Rd2d3 Rd3d4]]]].
  assert (Rd1d2 : (R_ << beta *) d1 d2).
  apply refl_trans_monotone with (R_ << gamma).
  apply subrel_trans with (R_<<= gamma).
  apply lt_subrel_le.
  apply red_incl_lt; exact Lgb.
  exact Rgd1d2.

  (* rightmost diagram *)
  assert (concl : exists d,
                  ((R_ << alpha(+)R_ <<= beta) *) b d /\
                  (R_ << alpha *) d4 d).

  pose proof LEba as [Lba | Eba].

  (* case 1 : L beta alpha, applying SS1 *)
  assert (LEaa : LE alpha alpha).
  right; apply Erefl.
  assert (alphaconf := SS1_lt Xaa LEaa).
  assert (Rb1d4 := refl_trans_trans (wdpL Lba) (Rwd4)).
  destruct (alphaconf b1 d4 b Rb1d4 Rb1b) as [d [Rd4d Rbd]].
  exists d; split.
  apply refl_trans_monotone with (R_ << alpha).
  intros x y H; left; exact H.
  exact Rbd.
  exact Rd4d.

  (* case 2: E beta alpha, applying SS2 *)
  assert (Rb1d4_exi : exists k, curlyn beta k b1 d4).
  apply refl_trans_nfold.
  apply le_trans_eq_curly_trans.
  apply refl_trans_monotone with (R_ <<= alpha).
  apply (Rle_eq (Esymm beta alpha Eba)).
  apply refl_trans_trans with w.
  exact Rb1w.
  apply refl_trans_monotone with (R_ << alpha).
  apply lt_subrel_le.
  exact Rwd4.
  destruct Rb1d4_exi as [k Rb1d4].

  assert (Rb1b' : R_ << beta * b1 b).
  apply refl_trans_monotone with (R_ << alpha).
  apply (Rlt_eq (Esymm beta alpha Eba)).
  exact Rb1b.
  destruct (SS2 LEba Xaa Xbg k d4 Rb1b' Rb1d4) as [d [Rbd Rd4d]].
  exists d; split.
  apply refl_trans_monotone with (R_ <<= beta).
  intros x y xy; right; exact xy.
  apply le_trans_eq_curly_trans.
  apply refl_trans_nfold.
  exists k.
  exact Rbd.
  apply refl_trans_monotone with (R_ << beta).
  apply (Rlt_eq Eba).
  exact Rd4d.

  (* finishing *)
  destruct concl as [d [Rbd Rd4d]].
  exists d; split.
  exists d2; split.
  apply refl_trans_trans with d1.
  exact Rcd1.
  exact Rd1d2.
  exists d3; split.
  exact Rd2d3.
  apply refl_trans_trans with d4.
  exact Rd3d4.
  exact Rd4d.
  exact Rbd.
Qed.

Definition X_n_eq_1_dia (alpha beta beta': I) :=
  forall (a b c : A),
  ((R_ alpha #) ; (R_ << alpha *)) a b ->
  ((R_ <<= beta' *) ; (R_ beta #) ; (R_ << beta *)) a c
  ->
  exists d : A,
  ((R_ << beta *) ; (R_ alpha #) ; (R_ << alpha *)) c d /\
  ((R_ << alpha (+) R_ <<= beta) *) b d.

Lemma X_n_eq_1 :
  forall (alpha beta beta' : I),
  LE beta alpha ->
  L beta' beta ->
  (forall alpha' : I, L alpha' alpha -> X alpha' alpha') ->
  (forall alpha' : I, L alpha' beta -> X alpha alpha') ->
  (forall gamma : I, L gamma beta -> X beta gamma) ->
  (forall delta : I, L delta beta' -> X_n_eq_1_dia alpha beta delta) ->
  X_n_eq_1_dia alpha beta beta'.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros alpha beta beta' LEba Lb'b Xaa Xaa' Xbg IH.
  intros a b c Rab Rac.
  pose proof Rab as [b1 [Rab1 Rb1b]].
  pose proof Rac as [c1 [Rac1 Rc1c]].
  pose proof Rc1c as [c2 [Rc1c2 Rc2c]].
  assert (Lb'a := lt_le Lb'b LEba).

  destruct (bot_bot beta') as [Eb'bot | Lbotb'].

  (* E beta' bot --> edge case *)
  apply (X_n_eq_1_beta'_eq_bottom LEba Xaa Xaa' Xbg Rab).
  assert (a_eq_c1 : a = c1).
  apply bot_red_le with beta'.
  rewrite Eb'bot; apply Erefl.
  exact Rac1.
  rewrite -> a_eq_c1.
  exact Rc1c.

  (* L bot beta' *)

  (* MAPPING
     a------b1------b
     |      Xab'    |
     c1---w1---w2---w
     |    |         |
     c2   x1        |
     |Xbb'|   IH b' |
     |    x2        |
     |    |         |
     c----d1--d2-d3-d
  *)

  (* Top diagram X(a, b') *)
  destruct (Xaa' beta' Lb'b a b1 b c1) as [w X_concl]; trivial.
  destruct X_concl as [Rbw [w1 [Rc1w1 [w2 [Rw1w2 Rw2w]]]]].

  (* Bottom left diagram X(b, b') *)
  destruct (lt_red_lt Rc1w1) as [[Eb'b _] | [_ [gamma [Lgb' Rgc1w1]]]].
  rewrite Eb'b in Lbotb'; destruct (Lirrefl bot Lbotb').
  assert (Lgb := Ltrans gamma beta' beta Lgb' Lb'b).
  destruct (Xbg gamma Lgb c1 c2 c w1 Rgc1w1 Rc1c2 Rc2c) as [d1 [Rcd1 Rw1d1]].

  (* bottom right diagram, IH beta' *)
  assert (Rw1w : ((R_ alpha #) ; (R_<< alpha)*) w1 w).
  exists w2; split; [exact Rw1w2 | exact Rw2w].
  assert (Rw1d1' : (R_ <<= gamma *; R_ beta #; R_ << beta *) w1 d1).
  destruct Rw1d1 as [x1 [Rw1x1 Rx1d1]].
  exists x1; split; [ | exact Rx1d1].
  apply refl_trans_monotone with (R_<< gamma).
  apply lt_subrel_le.
  exact Rw1x1.
  assert (IH_concl := IH gamma Lgb' w1 w d1 Rw1w Rw1d1').
  destruct IH_concl as [d [[d2 [Rd1d2 Rd2d]] Rwd]].

  (* Finishing *)
  exists d; split.
  exists d2; split.
  apply refl_trans_trans with d1.
  apply trans_Runion_elim with (R_ <<= gamma).
  apply (red_incl_lt Lgb).
  apply refl_trans_monotone with (R_ << beta (+) R_ <<= gamma).
  apply Runion_symm.
  exact Rcd1.
  exact Rd1d2.
  exact Rd2d.
  apply refl_trans_trans with w.
  apply refl_trans_monotone with ((R_ << alpha) (+) (R_ <<= beta')).
  intros x y [Rxy | Rxy]; [left; exact Rxy | ].
  right.
  apply lt_subrel_le.
  apply (red_incl_lt Lb'b).
  exact Rxy.
  exact Rbw.
  exact Rwd.
Qed.

Definition X_ind_step_dia (alpha beta : I) (n : nat) :=
  forall (a b c : A),
  ((R_ alpha #) ; (R_ << alpha *)) a b ->
  curlyn beta (S n) a c
  ->
  exists (d : A),
  ((R_ << beta *) ; (R_ alpha #) ; (R_ << alpha *)) c d /\
  ((R_ << alpha (+) R_ <<= beta) *) b d.

Lemma X_ind_step :
  forall (alpha beta : I),
  forall (n : nat),
  LE beta alpha ->
  (forall alpha' : I, L alpha' alpha -> X alpha' alpha') ->
  (forall alpha' : I, L alpha' beta -> X alpha alpha') ->
  (forall gamma : I, L gamma beta -> X beta gamma) ->
  (forall beta' : I, L beta' beta -> X_n_eq_1_dia alpha beta beta') ->
  (n > 0 -> X_ind_step_dia alpha beta (pred n)) ->
  X_ind_step_dia alpha beta n.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros alpha beta n LEba Xaa Xaa' Xbg base IH.
  intros a b c Rab Rac.
  pose proof Rab as [b1 [Rab1 Rb1b]].
  pose proof Rac as [c1 [Rac1 Rc1c]].

  (* MAPPING
     a-------------b1-------------b
     |    n = 1    |  SS1 and SS2 |
     c1----w1--w2--w3-------------w
     | SS2 |         IH n         |
     c-----d1------d2------d3-----d
  *)

  (* First handle the case E beta bot *)
  destruct (bot_bot beta) as [Ebb | Lbb].
  assert (Ebb' : E beta bot).
  rewrite Ebb; apply Erefl.
  assert (sub : subrel (~~> beta *) (@eq A)).
  apply subrel_trans with (R_<<= beta *).
  apply le_trans_eq_curly_trans.
  apply bot_red_le.
  exact Ebb'.
  assert (a_eq_c : a = c).
  apply sub.
  apply refl_trans_nfold; exists (S n); exact Rac.
  exists b; split; [ | apply refl_trans_refl].
  rewrite <- a_eq_c.
  exists a; split; [apply refl_trans_refl | exact Rab].

  (* top left, n = 1 diagram *)
  destruct Rac1 as [f [Raf Rfc1]].
  destruct (lt_red_lt Raf) as [[Ebb _] | [_ [beta' [Lb'b Rb'af]]]].
  rewrite Ebb in Lbb; destruct (Lirrefl bot Lbb).
  destruct (base beta' Lb'b a b1 c1) as [w3 [[w1 [Rc1w1 [w2 [Rw1w2 Rw2w3]]]] Rb1w3]].
  exists b1; split; [exact Rab1 | apply refl_trans_refl].
  exists f; split; [exact Rb'af | exact Rfc1].

  (* bottom left diagram, using SS2 *)
  destruct (SS2 LEba Xaa Xbg n c Rc1w1 Rc1c) as [d1 [Rw1d1 Rcd1]].

  (* top right diagram, using SS1 and SS2 *)
  assert (top_right : exists w, ((R_ << alpha)(+)(R_ <<= beta))* b w /\
                    (R_ << alpha *) w3 w).

  pose proof LEba as [Lba | Eba].
  (* L beta alpha, with SS1 *)
  assert (alphaconf := SS1_lt Xaa (or_intror (Erefl alpha))).
  destruct (alphaconf b1 b w3 Rb1b) as [w [Rbw Rw3w]].
  apply trans_Runion_elim with (R_<<= beta).
  apply (red_incl_lt Lba).
  apply refl_trans_monotone with ((R_ << alpha(+)R_ <<= beta)).
  apply Runion_symm.
  exact Rb1w3.
  exists w; split.
  apply refl_trans_monotone with (R_<< alpha).
  left; exact H.
  exact Rbw.
  exact Rw3w.
  (* E beta alpha, using SS2 *)
  (* label Rb1w3 with curlyn k for some k *)
  assert (Rb1w3' : R_ <<= beta * b1 w3).
  apply trans_Runion_elim with (R_ << alpha).
  apply subrel_trans with (R_<<= alpha).
  apply lt_subrel_le.
  apply (Rle_eq (Esymm beta alpha Eba)).
  exact Rb1w3.
  assert (exi_k : exists k, (curlyn beta k) b1 w3).
  apply refl_trans_nfold.
  apply le_trans_eq_curly_trans.
  exact Rb1w3'.
  destruct exi_k as [k Rkb1w3].

  assert (Rb1b' : (R_ << beta *) b1 b).
  apply refl_trans_monotone with (R_<< alpha).
  apply (Rlt_eq (Esymm beta alpha Eba)).
  exact Rb1b.

  destruct (SS2 LEba Xaa Xbg k w3 Rb1b' Rkb1w3) as [w [Rkbw Rw3w]].
  exists w; split.
  apply refl_trans_monotone with (R_<<= beta).
  intros x y; right; exact H.
  apply le_trans_eq_curly_trans.
  apply refl_trans_nfold.
  exists k; exact Rkbw.
  apply refl_trans_monotone with (R_<< beta).
  apply (Rlt_eq Eba).
  exact Rw3w.

  destruct top_right as [w [Rbw Rw3w]].

  (* Bottom IH n diagram *)
  destruct n.
  (* n = 0 *)
  assert (c1c : c = c1).
  destruct Rc1c; reflexivity.
  rewrite c1c.
  exists w; split.
  exists w1; split; [exact Rc1w1 | ].
  exists w2; split; [exact Rw1w2 | ].
  apply refl_trans_trans with w3; [exact Rw2w3 | exact Rw3w].
  exact Rbw.

  (* S n *)
  assert (notzero : S n > 0).
  generalize n; induction n0; [apply le_n | apply le_S; apply IHn0].

  destruct (IH notzero w1 w d1) as [d [[d2 [Rd1d2 Rd2d]] Rwd]].
  exists w2; split; [exact Rw1w2 | ].
  apply refl_trans_trans with w3; [exact Rw2w3 | exact Rw3w].
  exact Rw1d1.

  (* finishing up *)
  exists d; split.
  exists d2; split; [ | exact Rd2d].
  apply refl_trans_trans with d1; [exact Rcd1 | exact Rd1d2].
  apply refl_trans_trans with w; [exact Rbw | exact Rwd].
Qed.

Lemma Xeq :
  forall alpha alpha' beta,
  E alpha alpha' ->
  X alpha beta ->
  X alpha' beta.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].
  intros alpha alpha' beta Eaa' Xab.
  intros a b' b c ac ab' b'b.

  assert (ab'' : (R_ alpha #) a b').
  destruct ab' as [a b' ab' | a].
  left; apply (REcongr Eaa') in ab'; exact ab'.
  right.
  assert (b'b' : R_<< alpha * b' b).
  apply refl_trans_monotone with (R_<< alpha').
  apply (Rlt_eq (Esymm alpha alpha' Eaa')).
  exact b'b.
  assert (H : exists d : A,
            ((R_ << alpha (+) R_ <<= beta) *) b d /\
            (R_ << beta *; R_ alpha #; R_ << alpha *) c d).
  apply (Xab a b').
  exact ac.
  exact ab''.
  exact b'b'.
  destruct H as [d [Rbd Rcd]].
  exists d; split.
  apply refl_trans_monotone with (R_ << alpha(+)R_ <<= beta).
  intros x y [Rxy | Rxy].
  left; apply (Rlt_eq Eaa'); trivial.
  right; trivial.
  exact Rbd.
  destruct Rcd as [x [Rcx [y [Rxy Ryd]]]].
  exists x; split; [trivial | ].
  exists y; split.
  destruct Rxy as [x y xy | x].
  left; apply (REcongr Eaa'); exact xy.
  right.
  apply refl_trans_monotone with (R_ << alpha).
  apply (Rlt_eq Eaa'); trivial.
  exact Ryd.
Qed.

Lemma X_inh :
  forall alpha beta,
  LE beta alpha ->
  X alpha beta.
Proof.
  destruct oeq as [[Erefl [Esymm Etrans]] [LinvE [Lirrefl Ltrans]]].

  set (P := fun alpha beta =>
            LE beta alpha ->
            (forall beta', L beta' beta -> X_n_eq_1_dia alpha beta beta') /\
            (forall n, X_ind_step_dia alpha beta n) /\
            X alpha beta).

  assert (XXX : forall alpha beta, P alpha beta).

  intros alpha.
  apply well_founded_induction_type with (1:=wfL) (P:=fun alpha => forall beta, P alpha beta).
  clear alpha.

  intros alpha IHalpha beta.
  apply well_founded_induction_type with (1:=wfL) (P:= fun beta => P alpha beta).
  clear beta.
  intros beta IHbeta LEba.

  assert (Xaa : forall alpha' : I, L alpha' alpha -> X alpha' alpha').
  intros alpha' H.
  apply (IHalpha alpha' H).
  right; apply Erefl.

  assert (Xab' : forall beta' : I, L beta' beta -> X alpha beta').
  intros beta' Lb'b.
  apply (IHbeta beta' Lb'b).
  left; apply (lt_le Lb'b LEba).

  assert (Xbg : forall gamma : I, L gamma beta -> X beta gamma).
  intros gamma Lgb.
  pose proof LEba as [Lba | Eba].
  apply (IHalpha beta).
  exact Lba.
  left; exact Lgb.
  apply Xeq with alpha.
  exact (Esymm beta alpha Eba).
  apply (IHbeta gamma).
  exact Lgb.
  left; apply (lt_le Lgb LEba).

  assert (base : forall beta' : I, L beta' beta -> X_n_eq_1_dia alpha beta beta').
  intros beta'.
  apply well_founded_induction_type with (1:=wfL) (P:= fun beta' => L beta' beta -> X_n_eq_1_dia alpha beta beta').
  clear beta'.
  intros beta' IHbeta' Lb'b.
  apply (X_n_eq_1 LEba Lb'b Xaa Xab' Xbg).
  intros delta Ldb'.
  apply IHbeta'.
  exact Ldb'.
  apply (Ltrans delta beta' beta Ldb' Lb'b).

  assert (ind_step : forall n : nat, X_ind_step_dia alpha beta n).
  intros n.
  induction n.
  apply (X_ind_step LEba Xaa Xab' Xbg base).
  intros zz; inversion zz.
  apply (X_ind_step LEba Xaa Xab' Xbg base).
  intros snz; apply IHn.

  split; [apply base | split; [apply ind_step|]].

  intros a b' b c ac ab' b'b.
  assert (trans_curly : subrel (R_ <<= beta *) (curly beta*)).
  apply le_trans_eq_curly_trans.
  destruct (proj1 (refl_trans_nfold (~~> beta)) a c (trans_curly a c ac)) as [n ac'].
  clear ac; rename ac' into ac.
  assert (ab : ((R_ alpha #) ; (R_ << alpha *)) a b).
  exists b'; split; trivial.
  destruct n.
  exists b; split; [apply refl_trans_refl | ].
  rewrite <- ac.
  exists a; split; [apply refl_trans_refl | trivial].
  destruct (ind_step n a b c ab ac) as [d [Rcd Rbd]].
  exists d; split; trivial.

  apply XXX.
Qed.

Theorem weak_diamond_property_implies_confluence :
  confluent (Rfam_union R_).
Proof.
destruct oeq as [[Erefl [_ _]] [_ [_ _]]].
apply X_top.
apply X_inh.
right.
apply Erefl.
Qed.

End weak_diamond_property.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrightangle_1 : (forall A B C : Universe, (exists X : Universe, (per_ A B C -> (betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C)))))).
Variable defrightangle2_2 : (forall A B C X : Universe, ((betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C))) -> per_ A B C)).
Variable lemma_layoff_3 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable defcollinear_4 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_5 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_6 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_7 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_8 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_9 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_10 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_sameside2_11 : (forall A B C E F G : Universe, ((oS_ E F A C /\ (col_ A B C /\ out_ B F G)) -> oS_ E G A C)).
Variable lemma_8_3_12 : (forall A B C D : Universe, ((per_ A B C /\ out_ B C D) -> per_ A B D)).
Variable lemma_congruencesymmetric_13 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_10_12_14 : (forall A B C H : Universe, ((per_ A B C /\ (per_ A B H /\ cong_ B C B H)) -> cong_ A C A H)).
Variable lemma_congruenceflip_15 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_rightangleNC_16 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable proposition_07_17 : (forall A B C D : Universe, ((A <> B /\ (cong_ C A D A /\ (cong_ C B D B /\ oS_ C D A B))) -> C = D)).
Variable lemma_ray5_18 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).

Theorem lemma_erectedperpendicularunique_19 : (forall A B C E : Universe, ((per_ A B C /\ (per_ A B E /\ oS_ C E A B)) -> out_ B C E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import HoTT.
From HoTT.Categories Require Export Category.
From HoTT.Categories Require Import Functor NaturalTransformation FunctorCategory.

Definition const_functor
           {C D : PreCategory}
           (X : D)
  : Functor C D
  := Build_Functor C
                   D
                   (fun _ => X)
                   (fun _ _ _ => Category.identity X)
                   (fun _ _ _ _ _ => (left_identity _ _ _ _)^)
                   (fun _ => idpath).

Definition apply_functor
           `{Funext}
           {C : PreCategory}
           (D : PreCategory)
           (X : C)
  : Functor (C -> D) D.
Proof.
  simple refine (Build_Functor _ _ _ _ _ _).
  - exact (fun F => object_of F X).
  - exact (fun F G η => η X).
  - reflexivity.
  - reflexivity.
Defined.

Definition assoc_prod (C D E : PreCategory)
  : Functor ((C * D) * E) (C * (D * E))
  := fst o fst * (snd o fst * snd).

Definition pair
           {C₁ D₁ C₂ D₂ : PreCategory}
           {F₁ F₂ : Functor C₁ C₂}
           {G₁ G₂ : Functor D₁ D₂}
           (af : NaturalTransformation F₁ F₂)
           (ag : NaturalTransformation G₁ G₂)
  : NaturalTransformation (F₁,G₁) (F₂,G₂).
Proof.
  simple refine (Build_NaturalTransformation _ _ _ _).
  - exact (fun X => (af (fst X),ag (snd X))).
  - exact (fun X Y f => path_prod' (commutes af _ _ _) (commutes ag _ _ _)).
Defined.

Definition inverse_compose
           {C : PreCategory}
           {X Y Z : C}
           (g : morphism C Y Z) (f : morphism C X Y)
           `{IsIsomorphism C _ _ f} `{IsIsomorphism C _ _ g}
  : ((g o f)^-1 = f^-1 o g^-1)%morphism
  := idpath.

Definition inverse_id
           {C : PreCategory}
           (X : C)
  : (1^-1 = Core.identity X)%morphism
  := idpath.

Global Instance iso_pair
       {C D : PreCategory}
       {XC YC : C}
       {XD YD : D}
       (f : morphism C XC YC) (g : morphism D XD YD)
       `{IsIsomorphism C _ _ f} `{IsIsomorphism D _ _ g}
  : IsIsomorphism ((f,g) : morphism (Category.Prod.prod C D) (XC,XD) (YC,YD)).
Proof.
  simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
  - exact (f^-1,g^-1)%morphism.
  - exact (path_prod' left_inverse left_inverse).
  - exact (path_prod' right_inverse right_inverse).
Defined.

Definition inverse_pair
           {C D : PreCategory}
           {XC YC : C}
           {XD YD : D}
           (f : morphism C XC YC) (g : morphism D XD YD)
           `{IsIsomorphism C _ _ f} `{IsIsomorphism D _ _ g}
  : (((f,g) : morphism (Category.Prod.prod C D) (XC,XD) (YC,YD))^-1)%morphism
    = (f^-1,g^-1)%morphism
  := idpath.

Definition inverse_of
           {C D : PreCategory}
           (F : Functor C D)
           {X Y : C}
           (f : morphism C X Y)
           `{IsIsomorphism C _ _ f}
  : (morphism_of F (f^-1) = (morphism_of F f)^-1)%morphism
  := idpath.

Definition path_inverse
           {C : PreCategory}
           {X Y : C}
           (f g : morphism C X Y)
           `{IsIsomorphism C _ _ f} `{IsIsomorphism C _ _ g}
  : f = g -> (f^-1 = g^-1)%morphism.
Proof.
  intros p ; induction p.
  refine ((right_identity _ _ _ _)^ @ _).
  refine (ap _ (@right_inverse _ _ _ f _)^ @ _).
  refine ((associativity _ _ _ _ _ _ _ _)^ @ _).
  refine (ap (fun z => z o _)%morphism (@left_inverse _ _ _ f _) @ _).
  apply left_identity.
Defined.

Definition iso_component
           `{Funext}
           {C D : PreCategory}
           {F G : Functor C D}
           (η : NaturalTransformation F G)
           `{IsIsomorphism (_ -> _) _ _ η}
           (X : C)
  : Core.components_of (@morphism_inverse (_ -> _) _ _ η _) X
    =
    morphism_inverse (Core.components_of η X).
Proof.
  reflexivity.
Defined.

Definition nice_path_functor'
           `{Funext}
           {C D : PreCategory}
           {F G : Functor C D}
           (FGO : object_of F = G)
           (FGM : forall {X Y : C} (f : morphism C X Y),
               ((@morphism_isomorphic _ _ _ (Category.Morphisms.idtoiso D (ap10 FGO Y)))
                 o (morphism_of F f)
                 o morphism_inverse (Category.Morphisms.idtoiso D (ap10 FGO X)))%morphism
           = morphism_of G f)
  : F = G.
Proof.
  simple refine (path_functor _ _ _ _).
  - exact FGO.
  - funext X Y f.
    destruct F, G.
    cbn in *.
    induction FGO ; simpl in *.
    specialize (FGM X Y f).
    rewrite left_identity, right_identity in FGM.
    exact FGM.
Defined.

Definition nice_path_functor
           `{Funext}
           {C D : PreCategory}
           {F G : Functor C D}
           (FGO : forall (X : C), F X = G X)
           (FGM : forall {X Y : C} (f : morphism C X Y),
               ((@morphism_isomorphic _ _ _ (Category.Morphisms.idtoiso D (FGO Y)))
                  o (morphism_of F f)
                  o morphism_inverse (Category.Morphisms.idtoiso D (FGO X)))%morphism
               = morphism_of G f)
  : F = G.
Proof.
  simple refine (nice_path_functor' (path_forall _ _ FGO) _).
  intros X Y f.
  rewrite !ap10_path_forall.
  apply FGM.
Defined.


Theorem nat_eq_nat : nat = nat.
Proof.
  trivial.
Qed.

Theorem True_neq_False : ~(True = False).
Proof.
  unfold not.
  intros.
  symmetry in H.
  rewrite H.
  trivial.
Qed.

Theorem Prop_eq_prod : forall (a : Prop) (b : Prop), a = b -> (a -> b).
Proof.
  intros.
  rewrite <- H.
  trivial.
Qed.

Theorem Set_eq_prod : forall (a : Set) (b : Set), a = b -> (a -> b).
Proof.
  intros.
  rewrite <- H.
  trivial.
Qed.

Lemma Type_eq_prod : forall (a : Type) (b : Type), a = b -> (a -> b).
Proof.
  intros.
  rewrite <- H.
  trivial.
Qed.
(*
Theorem eq_prod : forall (X : Type) (a : X) (b : X), a = b -> (a -> b).

  Error: In environment
  X : Type
  a : X
  b : X
  The term "a" has type "X" which should be Set, Prop or Type.
*)

Theorem nat_neq_False : ~(nat = False).
Proof.
  unfold not.
  intros.
  apply (Type_eq_prod nat False) in H. (*这个地方只能写成Type_eq_prod nat False, 不知道为什么*)
  inversion H.
  apply 0.
(*
Error: Illegal application (Type Error):
The term "Type_eq_prod" of type "forall a b : Type, a = b -> a -> b"
cannot be applied to the terms
 "nat" : "Set"
 "False" : "Prop"
 "H" : "nat = False"
 "0" : "nat"
The 3rd term has type "nat = False" which should be coercible to
 "nat = False".
*)
Abort.

Theorem nat_neq_bool : ~(nat = bool).
Proof.
  unfold not.
  intros.
Abort.

Theorem nat_neq_true : ~(nat = True).
Proof.
  unfold not.
  intros.
Abort.

Theorem nat_neq_False : ~(nat = False).
Proof.
  unfold not.
  intros.
  symmetry in H.
  rewrite H.
  trivial.
Qed.


Require Import Kami.AllNotations FpuKami.Definitions FpuKami.Round.

Section Definitions.
  Open Scope nat.
  Variable szMinus2 outExpWidthMinus2 outSigWidthMinus2: nat.

  Local Notation outExpWidthMinus1 := (outExpWidthMinus2 + 1).
  Local Notation outSigWidthMinus1 := (outSigWidthMinus2 + 1).

  Local Notation szMinus1 := (szMinus2 + 1).
  Local Notation sz := (szMinus1 + 1).

  Section Ty.
    Variable ty: Kind -> Type.
    Section Convert.

      Definition INToNFInput := STRUCT_TYPE {
                                "in" :: Bit sz;
                                "signedIn" :: Bool;
                                "afterRounding" :: Bool;
                                "roundingMode" :: Bit 3
                              }.

      Open Scope kami_expr.
      Variable input: INToNFInput @# ty.

      Definition signedIn := input @% "signedIn" .
      Definition inputIN  := input @% "in".

      Definition expWidthMinus2 := Nat.log2_up sz.
      Local Notation expWidthMinus1 := (expWidthMinus2 + 1)%nat.
      Local Notation expWidth := (expWidthMinus1 + 1)%nat.

      Open Scope kami_action.

      Definition INToNF_expr
        :  OpOutput outExpWidthMinus2 outSigWidthMinus2 ## ty
        := LETC sign <- signedIn && ((UniBit (TruncMsb szMinus1 1) inputIN) == $1);
           LETC absIn <- IF #sign then $0 - inputIN else inputIN;

           LETC leadingZeros <- countLeadingZeros (sz+1) #absIn;

           LETC adjSig <- UniBit (TruncLsb szMinus1 1) (#absIn << #leadingZeros);
           LETC exp <- $sz - #leadingZeros - $1;

           LETC preRoundOutput: NF szMinus2 szMinus2 <-
                                  STRUCT {
                                    "isNaN"  ::= $$false;
                                    "isInf"  ::= $$false;
                                    "isZero" ::= #absIn == $0;
                                    "sign"   ::= #sign;
                                    "sExp"   ::= #exp;
                                    "sig"   ::= #adjSig
                                  };

           LETC roundInput: RoundInput szMinus2 szMinus2 <-
                                      STRUCT {
                                        "in" ::= #preRoundOutput;
                                        "afterRounding" ::= input @% "afterRounding";
                                        "roundingMode" ::= input @% "roundingMode"
                                      };

           LETE roundOutput <- (RoundNF_expr outExpWidthMinus2 outSigWidthMinus2
                                               (2 ^ outExpWidthMinus1 - 2)%nat
                                               (2 ^ outExpWidthMinus1 + outSigWidthMinus1 - 2)%nat
                                               (2 ^ outExpWidthMinus1 - 1)%nat
                                               #roundInput);

           RetE #roundOutput.

      Definition INToNF_action: ActionT ty (OpOutput outExpWidthMinus2 outSigWidthMinus2)
        := convertLetExprSyntax_ActionT INToNF_expr.

    End Convert.

  End Ty.
End Definitions.


Require Coq.extraction.Extraction.
Require Import ZArith.

(* Custom extraction from nat -> OCaml Z (arbitrary precision integers) *)
Extract Inductive nat => "Z.t" [ "Z.zero" "Z.succ" ]
  "(fun fO fS n -> if Z.equal n Z.zero then fO () else fS (Z.pred n))".
Extract Constant Nat.pred => "(fun a -> Z.max (Z.pred a) Z.zero)".
Extract Inlined Constant Nat.add => "Z.add".
Extract Constant Nat.sub => "(fun a b -> Z.max (Z.sub a b) Z.zero)".
Extract Inlined Constant Nat.mul => "Z.mul".
Extract Inlined Constant Nat.div => "Z.div".
Extract Inlined Constant Nat.modulo => "Z.rem".
Extract Constant Nat.pow => "(fun a b -> Z.pow a (Z.to_int b))".
Extract Inlined Constant Nat.gcd => "Z.gcd".
Extract Constant Nat.log2 => "fun n -> (Z.of_int (Z.log2 n))".
Extract Inlined Constant Nat.eqb => "Z.equal".
Extract Inlined Constant Nat.leb => "Z.leq".
Extract Inlined Constant Nat.ltb => "Z.lt".


(* Copyright 2012-2017 by Adam Petcher and FCF Contributors.	*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* An argument that is used to prove that the "two worlds" style of security definition is equivalent to the "coin flipping" style. *)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.Crypto.
Require Import FCF.Asymptotic.

Theorem evalDist_bool_support :
  forall (c : Comp bool)(ls : list bool),
    well_formed_comp c ->
    ls = getSupport c ->
    sumList ls (evalDist c) == evalDist c false + evalDist c true.

  intuition.
  specialize (support_NoDup c); intuition.
  rewrite <- H0 in H1.

  destruct ls; intuition.
  specialize (getSupport_length_nz H); intuition.
  rewrite <- H0 in H2.
  simpl in *.
  lia.

  destruct b.

  destruct ls.
  unfold sumList; simpl.

  eapply ratAdd_eqRat_compat.
  symmetry.
  eapply getSupport_not_In_evalDist.
  intuition.
  rewrite <- H0 in H2.
  simpl in *.
  intuition.
  intuition.

  destruct b.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.

  destruct ls.

  unfold sumList.
  simpl.
  rewrite <- ratAdd_0_l.
  eapply ratAdd_comm.

  destruct b.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.
  inversion H5; clear H5; subst.
  simpl in *; intuition.

  destruct ls.
  unfold sumList; simpl.

  rewrite ratAdd_comm.
  eapply ratAdd_eqRat_compat.
  intuition.
  symmetry.
  eapply getSupport_not_In_evalDist.
  intuition.
  rewrite <- H0 in H2.
  simpl in *.
  intuition.

  destruct b.

  destruct ls.

  unfold sumList.
  simpl.
  rewrite <- ratAdd_0_l.
  intuition.

  destruct b.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.
  inversion H5; clear H5; subst.
  simpl in *; intuition.
  inversion H1; clear H1; subst.
  simpl in *; intuition.
  inversion H1; clear H1; subst.
  simpl in *; intuition.

Qed.

Theorem evalDist_bool_complement :
  forall (c : Comp bool),
    well_formed_comp c ->
    evalDist c false == ratSubtract 1 (evalDist c true).

  intuition.
  eapply (eqRat_ratAdd_same_r (evalDist c true)).
  symmetry.
  rewrite ratAdd_comm.
  rewrite ratSubtract_ratAdd_inverse_2.

  specialize (@evalDist_lossless _ c); intuition.
  rewrite <- H1.
  clear H1.
  eapply evalDist_bool_support.
  intuition.
  intuition.

  eapply evalDist_le_1.
Qed.

Theorem rndBool_bind :
  forall
    (f : bool -> Comp bool),
    Pr[b <-$ {0, 1}; f b] == (1 / 2) * Pr[f true] + (1 / 2) * Pr[f false].

  intuition.
  simpl.
  destruct (bind_eq_dec ({ 0 , 1 }^1) (fun m : Bvector 1 => ret Vector.hd m)
    false true).
  discriminate.

  unfold sumList.
  simpl.
  destruct (EqDec_dec bool_EqDec true false).
  discriminate.
  destruct (EqDec_dec bool_EqDec false true).
  discriminate.
  destruct (EqDec_dec bool_EqDec true true).
  destruct (EqDec_dec bool_EqDec false false).

  repeat rewrite <- ratAdd_0_l.
  repeat rewrite ratMult_0_r.
  repeat rewrite <- ratAdd_0_r.
  repeat rewrite <- ratAdd_0_l.
  repeat rewrite ratMult_1_r.
  eapply ratAdd_eqRat_compat;
    eapply ratMult_eqRat_compat; intuition.

  intuition.
  intuition.
Qed.

Section TwoWorldsEquiv.

  Variable f : nat -> bool -> Comp bool.

  Hypothesis f_wf : forall n b, well_formed_comp (f n b).

  Section TwoWorldsEquiv_eta.
    Variable eta : nat.

    Definition StandardDef_G :=
      b <-$ {0, 1};
      b' <-$ f eta b;
      ret (eqb b b').

    Theorem StandardDef_equiv_2W_h :
      | Pr[StandardDef_G] - 1 / 2 | == (1 / 2) * | Pr[f eta true] - Pr[f eta false] |.

      unfold StandardDef_G.

      rewrite rndBool_bind.

      assert ( Pr[b' <-$ f eta true; ret eqb true b'] == Pr[f eta true]).
      symmetry.
      rewrite <- evalDist_right_ident.
      comp_skip.
      fcf_compute.
      rewrite H.
      clear H.

      assert ( Pr  [b' <-$ f eta false; ret eqb false b' ] == (ratSubtract 1 (Pr[f eta false]))).
      assert (Pr  [b' <-$ f eta false; ret eqb false b' ]  == evalDist (f eta false) false).
      symmetry.
      rewrite <- evalDist_right_ident.
      comp_skip.
      fcf_compute.
      rewrite H.
      clear H.

      eapply evalDist_bool_complement.
      wftac.

      rewrite H.
      clear H.

      rewrite <- ratMult_distrib.
      rewrite <- (ratMult_1_r (1/2)) at 2.

      rewrite ratMult_ratDistance_factor_l.
      eapply ratMult_eqRat_compat; intuition.

      assert ((Pr  [f eta false])  + ratSubtract 1 (Pr  [f eta false]) == 1).
      rewrite <- ratSubtract_ratAdd_assoc.
      eapply ratSubtract_ratAdd_inverse.

      eapply evalDist_le_1.
      unfold eq_dec.

      rewrite <- H at 2.

      rewrite ratDistance_add_same_r.
      reflexivity.

      Unshelve.
      exact _.
      exact _.
    Qed.

    Theorem Def_equiv_2W :
      | Pr[StandardDef_G] - 1 / 2 | == (1 / 2) * | Pr[f eta false] - Pr[f eta true] |.

      rewrite StandardDef_equiv_2W_h.
      rewrite ratDistance_comm.
      intuition.

    Qed.

    End TwoWorldsEquiv_eta.

    Theorem TwoWorlds_equiv_f :
      negligible (fun eta => (| Pr[f eta false] - Pr[f eta true] |)) ->
      negligible (fun eta => | Pr[StandardDef_G eta] - 1 / 2 |).

      unfold negligible.
      intuition.
      destruct (H c).
      exists x.
      intuition.
      eapply H0.
      intuition.
      rewrite H2.
      rewrite Def_equiv_2W.

      rewrite ratMult_comm.
      eapply ratMult_small_le.

      eapply rat_le_1.
      simpl.
      lia.

    Qed.

    Theorem TwoWorlds_equiv_b :
      negligible (fun eta => | Pr[StandardDef_G eta] - 1 / 2 |) ->
      negligible (fun eta => (| Pr[f eta false] - Pr[f eta true] |)).

      unfold negligible.
      intuition.
      edestruct (H (1 + c)%nat).
      exists (S x)%nat.
      intuition.
      eapply H0.
      lia.

      assert ((RatIntro (S O)
        (@natToPosnat (expnat x0 (plus (S O) c))
           (@expnat_nz (plus (S O) c) x0 pf_nz))) == (1 / x0) * (1 / (expnat x0 c))).

      simpl.
      rewrite <- ratMult_denom.
      eapply eqRat_terms; intuition.

      rewrite H3.
      clear H3.
      rewrite H2.

      eapply leRat_trans.
      2:{
        eapply eqRat_impl_leRat.
        symmetry.
        eapply Def_equiv_2W.
      }

      eapply ratMult_leRat_compat; intuition.
      unfold leRat.
      eapply leRat_terms; intuition.
      unfold natToPosnat, posnatToNat.
      lia.

    Qed.

    Theorem TwoWorlds_equiv :
      negligible (fun eta => (| Pr[f eta false] - Pr[f eta true] |)) <->
      negligible (fun eta => | Pr[StandardDef_G eta] - 1 / 2 |).

      intuition.
      eapply TwoWorlds_equiv_f; intuition.
      eapply TwoWorlds_equiv_b; intuition.

    Qed.

End TwoWorldsEquiv.


Require Import Framework Lia.

(* Definition super_block_num := 0. *)
Definition hdr_block_num := 0.
Definition log_start := 1.
Axiom log_length : nat. (** # of log blocks **)

Lemma hdr_block_num_eq:
  hdr_block_num = 0.
Proof. eauto. Qed.

Lemma log_start_eq:
  log_start = 1.
Proof. eauto. Qed.

Lemma hdr_before_log:
  hdr_block_num < log_start.
Proof. eauto. Qed.

Definition data_start := S log_length.
Definition data_length := disk_size - data_start.

Lemma data_start_where_log_ends:
  data_start = log_start + log_length.
Proof. eauto. Qed.

Axiom data_fits_in_disk:
  disk_size = data_start + data_length.

(** Below all reside in data region indexed accordingly *)
(** For simplicity, it will be 1 inode per block *)
Definition inode_blocks_start := 0.
Axiom inode_count: nat.
Axiom inode_count_nonzero: 0 < inode_count.
Axiom inode_count_in_bounds: inode_count <= block_size.

Definition file_blocks_start:= S(inode_count). (** 1 bitmap + inode_count inodes *)
Axiom file_blocks_count : nat.
Axiom file_blocks_count_nonzero: 0 < file_blocks_count.
Axiom file_blocks_count_in_bounds: file_blocks_count <= block_size.

Axiom all_fits_to_data_region : 2 + inode_count + file_blocks_count <= data_length.

Theorem inodes_before_data:
  inode_blocks_start + inode_count < file_blocks_start.
Proof.
  unfold inode_blocks_start, file_blocks_start; lia.
Qed.

Theorem inodes_fit_in_disk:
  inode_blocks_start + inode_count < data_length.
Proof.
  pose proof all_fits_to_data_region.
  unfold inode_blocks_start.
  lia.
Qed.

Theorem file_blocks_fit_in_disk:
  file_blocks_start + file_blocks_count < data_length.
Proof.
  pose proof all_fits_to_data_region.
  unfold file_blocks_start.
  lia.
Qed.

Global Opaque hdr_block_num log_start data_start data_length inode_blocks_start file_blocks_start.


Require Import VST.floyd.proofauto.
Require Import Coq.Program.Equality.

Require Import my_tactics.

Inductive bin_tree (A: Type) : Type :=
  | leaf : bin_tree A
  | node : A -> bin_tree A -> bin_tree A -> bin_tree A.
Arguments bin_tree _%type_scope.
Arguments leaf {A}%type_scope.
Arguments node {A}%type_scope.

Inductive bin_tree_forall {A} : bin_tree A -> (A -> Prop) -> Prop :=
  | bin_tree_forall_leaf : forall p, bin_tree_forall leaf p
  | bin_tree_forall_node : forall (p: A -> Prop) a l r,
      p a -> bin_tree_forall l p -> bin_tree_forall r p -> bin_tree_forall (node a l r) p.

Theorem bin_tree_forall_strengthen {A} : forall (p q: A -> Prop) b,
  (forall x, p x -> q x) -> bin_tree_forall b p -> bin_tree_forall b q.
Proof.
  intros.
  dependent induction H0; subst; constructor; simplify_assumps.
  - apply H. assumption.
  - assumption.
  - assumption.
Qed.

Inductive well_ordered {A} : bin_tree (Z * A) -> Prop :=
  | well_ordered_leaf : well_ordered leaf
  | well_ordered_node : forall k v l r,
      bin_tree_forall l (fun n => fst n < k) ->
      bin_tree_forall r (fun n => fst n > k) ->
      well_ordered l ->
      well_ordered r ->
      well_ordered (node (k, v) l r).

Definition bst A := bin_tree (Z * A).

(* Subtrees *)

Inductive is_subtree {A} : bin_tree A -> bin_tree A -> Prop :=
  | is_subtree_refl  : forall b, is_subtree b b
  | is_subtree_left  : forall b n l r, is_subtree b l -> is_subtree b (node n l r)
  | is_subtree_right : forall b n l r, is_subtree b r -> is_subtree b (node n l r).

(* Definition proper_subtree {A} (b1 b2: bin_tree A) := b1 <> b2 /\ is_subtree b1 b2. *)

Lemma is_subtree_leaf : forall {A} (b: bin_tree A), is_subtree leaf b.
Proof.
  intros A b.
  induction b; constructor; assumption.
Qed.

Theorem subtree_forall : forall {A} sub b (p: A -> Prop),
  is_subtree sub b -> bin_tree_forall b p -> bin_tree_forall sub p.
Proof.
  intros.
  induction H;
  try (apply IHis_subtree; inv H0);
  assumption.
Qed.

Theorem subtree_well_ordered : forall {A} (b sub: bst A),
  is_subtree sub b -> well_ordered b -> well_ordered sub.
Proof.
  intros.
  induction b.
  - destruct sub.
    + constructor.
    + inv H.
  - inv H.
    + assumption.
    + inv H0; apply IHb1; assumption.
    + inv H0; apply IHb2; assumption.
Qed.

Theorem is_subtree_up_left {A}: forall (a: A) l r b,
  is_subtree (node a l r) b -> is_subtree l b.
Proof.
  intros.
  dependent induction H.
  - apply is_subtree_left. constructor.
  - apply is_subtree_left.
    eapply IHis_subtree.
    reflexivity.
  - apply is_subtree_right.
    eapply IHis_subtree.
    reflexivity.
Qed.

Theorem is_subtree_up_right {A}: forall (a: A) l r b,
  is_subtree (node a l r) b -> is_subtree r b.
Proof.
  intros.
  dependent induction H.
  - apply is_subtree_right. constructor.
  - apply is_subtree_left.
    eapply IHis_subtree.
    reflexivity.
  - apply is_subtree_right.
    eapply IHis_subtree.
    reflexivity.
Qed.

Lemma no_infinite_node_left {A} : forall (a: A) l r,
  node a l r <> l.
Proof.
  unfold not.
  intros.
  induction l.
  - discriminate.
  - apply IHl1.
    inv H.
    rewrite H2 at 1.
    reflexivity.
Qed.

Lemma no_infinite_node_right {A} : forall (a: A) l r,
  node a l r <> r.
Proof.
  unfold not.
  intros.
  induction r.
  - discriminate.
  - apply IHr2.
    inv H.
    rewrite H3 at 1.
    reflexivity.
Qed.

Fixpoint depth {A} (b: bin_tree A) : nat :=
  match b with
  | leaf => 0
  | node a l r => S (max (depth l) (depth r))
  end.

Theorem subtree_depth_monotonic {A} : forall (b1 b2: bin_tree A),
  is_subtree b1 b2 -> (depth b1 <= depth b2)%nat.
Proof.
  intros.
  dependent induction H; simpl; lia.
Qed.

Theorem no_subtree_cycle_left {A} : forall (a: A) l r,
  not (is_subtree (node a l r) l).
Proof.
  unfold not.
  intros.
  apply subtree_depth_monotonic in H.
  simpl in H.
  lia.
Qed.

Theorem no_subtree_cycle_right {A} : forall (a: A) l r,
  not (is_subtree (node a l r) r).
Proof.
  unfold not.
  intros.
  apply subtree_depth_monotonic in H.
  simpl in H.
  lia.
Qed.

Lemma wo_node_eq {A} : forall k (v1 v2: A) l1 l2 r1 r2,
  well_ordered (node (k,v1) l1 r1) ->
  is_subtree (node (k,v2) l2 r2) (node (k,v1) l1 r1) ->
  node (k,v1) l1 r1 = node (k,v2) l2 r2.
Proof.
  intros.
  inv H0.
  - reflexivity.
  - inv H.
    eapply subtree_forall in H3; [|eassumption].
    inv H3.
    simpl in H5. lia.
  - inv H.
    eapply subtree_forall in H3; [|eassumption].
    inv H3.
    simpl in H5. lia.
Qed.

Lemma wo_subtree_left {A} : forall k1 k2 (v1 v2: A) l1 l2 r1 r2,
  well_ordered (node (k1,v1) l1 r1) ->
  is_subtree (node (k2,v2) l2 r2) (node (k1,v1) l1 r1) ->
  k2 < k1 ->
  is_subtree (node (k2,v2) l2 r2) l1.
Proof.
  intros.
  inv H0.
  - lia.
  - assumption.
  - inv H.
    eapply subtree_forall in H4; [|eassumption].
    inv H4.
    simpl in H6. lia.
Qed.

Lemma wo_subtree_right {A} : forall k1 k2 (v1 v2: A) l1 l2 r1 r2,
  well_ordered (node (k1,v1) l1 r1) ->
  is_subtree (node (k2,v2) l2 r2) (node (k1,v1) l1 r1) ->
  k2 > k1 ->
  is_subtree (node (k2,v2) l2 r2) r1.
Proof.
  intros.
  inv H0.
  - lia.
  - inv H.
    eapply subtree_forall in H4; [|eassumption].
    inv H4.
    simpl in H6. lia.
  - assumption.
Qed.

(* Search *)

Fixpoint search {A} (k: Z) (b: bst A) : bst A :=
  match b with
  | leaf => leaf
  | node (k', v) l r =>
      match k ?= k' with
      | Eq => b
      | Lt => search k l
      | Gt => search k r
      end
  end.

Theorem search_spec {A} : forall (b: bst A) k v l r,
  well_ordered b ->
  is_subtree (node (k,v) l r) b ->
  search k b = node (k,v) l r.
Proof.
  intros.
  induction b.
  - inv H0.
  - inv H.
    simplify_assumps.
    simpl.
    find_Z_compare_destruct.
    + eapply wo_node_eq; assumption.
    + apply IHb1.
      eapply wo_subtree_left; eassumption.
    + apply IHb2.
      eapply wo_subtree_right; eassumption.
Qed.

Theorem search_is_subtree : forall {A} k (b sub: bst A),
  search k b = sub -> is_subtree sub b.
Proof.
  intros A k b sub.
  induction b; try destruct_pair; simpl; intro H.
  - subst. constructor.
  - find_Z_compare_destruct.
    + constructor.
    + apply is_subtree_left.
      apply IHb1.
      assumption.
    + apply is_subtree_right.
      apply IHb2.
      assumption.
Qed.

Lemma search_well_ordered : forall {A} k (b sub: bst A),
  search k b = sub -> well_ordered b -> well_ordered sub.
Proof.
  intros.
  eapply subtree_well_ordered.
  eapply search_is_subtree.
  eassumption.
  assumption.
Qed.

(* Insert *)

Fixpoint insert {A} (k: Z) (v: A) (b: bst A) : bst A :=
  match b with
  | leaf => node (k, v) leaf leaf
  | node (k', v') l r =>
      match k ?= k' with
      | Eq => node (k', v) l r
      | Lt => node (k', v') (insert k v l) r
      | Gt => node (k', v') l (insert k v r)
      end
  end.

Lemma insert_forall {A} : forall (p: (Z * A) -> Prop) k v bst,
  p (k, v) -> bin_tree_forall bst p -> bin_tree_forall (insert k v bst) p.
Proof.
  intros p k v b H.
  induction b; intro H0; simpl.
  - constructor; assumption.
  - destruct_pair. find_Z_compare_destruct;
    inv H0; constructor;
    try (apply IHb1 + apply IHb2);
    assumption.
Qed.

Theorem insert_well_ordered {A}: forall (b: bst A) k v,
  well_ordered b -> well_ordered (insert k v b).
Proof.
  intro b; induction b; intros k v H; simpl.
  - repeat constructor.
  - inv H.
    find_Z_compare_destruct;
    constructor; try (apply insert_forall + apply IHb1 + apply IHb2); assumption.
Qed.

Theorem search_insert {A}: forall k v (b: bst A),
  exists l r, search k (insert k v b) = node (k, v) l r.
Proof.
  intros k v b.
  induction b.
  - simpl.
    rewrite Z.compare_refl.
    unify_goal.
  - simpl. destruct_pair.
    find_Z_compare_destruct;
    simpl; rewrite Heqc; assumption + unify_goal.
Qed.

(* Delete *)

Fixpoint get_min {A} (a: Z * A) (l r: bst A) : Z * A :=
  match l with
  | leaf => a
  | node a' l' r' => get_min a' l' r'
  end.

Fixpoint rm_min {A} (a: Z * A) (l r: bst A) : bst A :=
  match l with
  | leaf => r
  | node a' l' r' => node a (rm_min a' l' r') r
  end.

Lemma get_min_forall {A} : forall (p: (Z * A) -> Prop) a l r,
  bin_tree_forall (node a l r) p -> p (get_min a l r).
Proof.
  intros p a l; revert p a.
  induction l; intros; simpl.
  - inv H; assumption.
  - apply IHl1.
    inv H; assumption.
Qed.

Lemma rm_min_forall {A} : forall (p: (Z * A) -> Prop) a l r,
  bin_tree_forall (node a l r) p -> bin_tree_forall (rm_min a l r) p.
Proof.
  intros p a l; revert p a.
  induction l; intros; simpl.
  - inv H; assumption.
  - constructor.
    + inv H; assumption.
    + apply IHl1. inv H; assumption.
    + inv H; assumption.
Qed.

Lemma get_min_is_min {A} : forall (a: Z * A) l r,
  well_ordered (node a l r) ->
  bin_tree_forall (rm_min a l r) (fun n => fst n > fst (get_min a l r)).
Proof.
  intros a l; revert a.
  induction l; intros; simpl.
  - inv H; assumption.
  - constructor.
    + inv H.
      apply get_min_forall in H3.
      simpl. lia.
    + apply IHl1. inv H; assumption.
    + inv H.
      eapply bin_tree_forall_strengthen; [|eassumption].
      intros [x].
      simpl.
      enough (k > fst (get_min a l1 l2)); [lia|].
      apply get_min_forall in H3.
      lia.
Qed.

Lemma get_min_is_min_2 {A} : forall (a: Z * A) l r,
  well_ordered (node a l r) ->
  bin_tree_forall (node a l r) (fun n => fst n >= fst (get_min a l r)).
Proof.
  intros a l; revert a.
  induction l; intros; simpl.
  - inv H.
    constructor.
    + lia.
    + constructor.
    + simpl.
      eapply bin_tree_forall_strengthen; [|eassumption].
      intros [x].
      lia.
  - inv H.
    constructor.
    + specialize (IHl1 a l2 H5).
      inv IHl1.
      simpl.
      inv H3.
      lia.
    + apply IHl1.
      assumption.
    + eapply bin_tree_forall_strengthen; [|eassumption].
      intros [x].
      simpl.
      enough (k > fst (get_min a l1 l2)); [lia|].
      apply get_min_forall in H3.
      lia.
Qed.

Theorem rm_min_well_ordered {A} : forall (a: Z * A) l r,
  well_ordered (node a l r) -> well_ordered (rm_min a l r).
Proof.
  intros a l; revert a.
  induction l; intros; simpl.
  - inv H; assumption.
  - destruct a0; constructor.
    + apply rm_min_forall. inv H; assumption.
    + inv H; assumption.
    + apply IHl1. inv H; assumption.
    + inv H; assumption.
Qed.

Fixpoint delete {A} (k: Z) (b: bst A) : bst A :=
  match b with
  | leaf => leaf
  | node (k', v) l r =>
      match k ?= k' with
      | Eq => match l with
          | leaf => r
          | _ => match r with
              | leaf => leaf
              | node ra rl rr => node (get_min ra rl rr) l (rm_min ra rl rr)
              end
          end
      | Lt => delete k l
      | Gt => delete k r
      end
  end.

Lemma delete_forall {A} : forall (p: (Z * A) -> Prop) k bst,
  bin_tree_forall bst p -> bin_tree_forall (delete k bst) p.
Proof.
  intros p k b.
  induction b as [|[k' v] l IH1 r IH2]; intro H; simpl; [assumption|].
  find_Z_compare_destruct.
  - destruct l, r; try (inv H; assumption).
    constructor.
    + apply get_min_forall.
      inv H; assumption.
    + inv H; assumption.
    + apply rm_min_forall.
      inv H; assumption.
  - apply IH1. inv H; assumption.
  - apply IH2. inv H; assumption.
Qed.

Theorem delete_well_ordered {A}: forall (b: bst A) k,
  well_ordered b -> well_ordered (delete k b).
Proof.
  intros b; induction b as [|[k' v] l IH1 r IH2]; intros k H; simpl; [constructor|].
  find_Z_compare_destruct.
  - destruct l, r; try (inv H; assumption).
    destruct (get_min p0 r1 r2) eqn:H_min.
    constructor.
    + inv H; subst.
      eapply bin_tree_forall_strengthen; [|eassumption].
      intros [x].
      simpl.
      enough (k' < z); [lia|].
      apply get_min_forall in H5.
      rewrite H_min in H5; simpl in H5.
      lia.
    + replace z with (fst (get_min p0 r1 r2)) by (rewrite H_min; reflexivity).
      apply get_min_is_min.
      inv H; assumption.
    + inv H; assumption.
    + apply rm_min_well_ordered.
      inv H; assumption.
  - apply IH1. inv H; assumption.
  - apply IH2. inv H; assumption.
Qed.

(* search_path: This describes a point in a key-search traversal, commonly used to express
   loop invariants *)

(* The direction of transitivity here is nice for induction, but doesn't correspond
   to the intuitive direction in which a path grows. *)
Inductive search_path : Z -> bst Z -> bst Z -> Prop :=
  | path_refl : forall k b, search_path k b b
  | path_step_l : forall k k' v l r b,
      search_path k l b -> k < k' -> search_path k (node (k',v) l r) b
  | path_step_r : forall k k' v l r b,
      search_path k r b -> k > k' -> search_path k (node (k',v) l r) b.

(* This is the direction a path will actually grow in *)
Lemma path_step_down_l : forall k head k' v l r,
  search_path k head (node (k',v) l r) -> k < k' -> search_path k head l.
Proof.
  intros. dependent induction H.
  - apply path_step_l.
    + constructor.
    + assumption.
  - apply path_step_l.
    + eapply IHsearch_path; trivial.
    + assumption.
  - apply path_step_r.
    + eapply IHsearch_path; trivial.
    + assumption.
Qed.

Lemma path_step_down_r : forall k head k' v l r,
  search_path k head (node (k',v) l r) -> k > k' -> search_path k head r.
Proof.
  intros. dependent induction H.
  - apply path_step_r.
    + constructor.
    + assumption.
  - apply path_step_l.
    + eapply IHsearch_path; trivial.
    + assumption.
  - apply path_step_r.
    + eapply IHsearch_path; trivial.
    + assumption.
Qed.

Theorem search_path_fail : forall k b, search_path k b leaf -> search k b = leaf.
Proof.
  intros. dependent induction H.
  - reflexivity.
  - simpl.
    rewrite Zaux.Zcompare_Lt by assumption.
    apply IHsearch_path.
    reflexivity.
  - simpl.
    rewrite Zaux.Zcompare_Gt by lia.
    apply IHsearch_path.
    reflexivity.
Qed.

Theorem search_path_success: forall k b v l r,
  search_path k b (node (k,v) l r) -> search k b = (node (k,v) l r).
Proof.
  intros. dependent induction H.
  - simpl.
    rewrite Z.compare_refl.
    reflexivity.
  - simpl.
    rewrite Zaux.Zcompare_Lt by assumption.
    apply IHsearch_path.
    reflexivity.
  - simpl.
    rewrite Zaux.Zcompare_Gt by lia.
    apply IHsearch_path.
    reflexivity.
Qed.

Lemma search_path_constant : forall k b1 b2,
  search_path k b1 b2 -> search k b1 = search k b2.
Proof.
  intros k b1 b2 H.
  dependent induction H; simpl.
  - reflexivity.
  - rewrite Zaux.Zcompare_Lt; assumption.
  - rewrite Zaux.Zcompare_Gt by lia. assumption.
Qed.

Theorem search_path_is_subtree: forall k b sub, search_path k b sub -> is_subtree sub b.
Proof.
  intros.
  induction H.
  - constructor.
  - apply is_subtree_left. assumption.
  - apply is_subtree_right. assumption.
Qed.

Theorem path_shrink_l : forall k_search k k' v v' l l' r r',
  well_ordered (node (k,v) l r) ->
  k' < k ->
  search_path k_search (node (k,v) l r) (node (k',v') l' r') ->
  search_path k_search l (node (k',v') l' r').
Proof.
  intros.
  inv H1.
  - lia.
  - assumption.
  - apply search_path_is_subtree in H8.
    inv H.
    eapply subtree_forall in H8; [|eassumption].
    inv H8.
    simpl in *.
    lia.
Qed.

Theorem path_shrink_r : forall k_search k k' v v' l l' r r',
  well_ordered (node (k,v) l r) ->
  k < k' ->
  search_path k_search (node (k,v) l r) (node (k',v') l' r') ->
  search_path k_search r (node (k',v') l' r').
Proof.
  intros.
  inv H1.
  - lia.
  - apply search_path_is_subtree in H8.
    inv H.
    eapply subtree_forall in H8; [|eassumption].
    inv H8.
    simpl in *.
    lia.
  - assumption.
Qed.

Theorem path_extract_ord_l : forall k_search k k' v v' l l' r r',
  well_ordered (node (k,v) l r) ->
  k' < k ->
  search_path k_search (node (k,v) l r) (node (k',v') l' r') ->
  k_search < k.
Proof.
  intros.
  inv H1.
  - lia.
  - assumption.
  - apply search_path_is_subtree in H8.
    inv H.
    eapply subtree_forall in H8; [|eassumption].
    inv H8.
    simpl in *.
    lia.
Qed.

Theorem path_extract_ord_r : forall k_search k k' v v' l l' r r',
  well_ordered (node (k,v) l r) ->
  k < k' ->
  search_path k_search (node (k,v) l r) (node (k',v') l' r') ->
  k < k_search.
Proof.
  intros.
  inv H1.
  - lia.
  - apply search_path_is_subtree in H8.
    inv H.
    eapply subtree_forall in H8; [|eassumption].
    inv H8.
    simpl in *.
    lia.
  - lia.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* A general purpose array indexed by an arbitrary type *)

Set Implicit Arguments.
Require Import FCF.Crypto.
Require Import FCF.Fold.
Require Import Permutation.

Local Open Scope list_scope.

Section ListArray.

  Variable D R : Set.
  Hypothesis D_EqDec : EqDec D.

  Definition Array := list (D * R).

  Fixpoint arrayLookup(ls : list (D * R)) d :=
    match ls with
      | nil => None
      | (d', r') :: ls' =>
        if (eqb d d')
          then Some r'
          else (arrayLookup ls' d)
    end.

  Definition arrayEquiv(arr1 arr2 : Array) :=
    forall d,
      (arrayLookup arr1 d) = (arrayLookup arr2 d).

  Definition arrayLookupDef(ls : list (D * R)) d def :=
    match arrayLookup ls d with
        | None => def
        | Some r => r
    end.

  Definition arrayUpdate (arr_opt : option Array) d r_opt :=
    let arr := match arr_opt with
                 | None => nil
                 | Some arr => arr
               end in
    match r_opt with
        | None => arr
        | Some r =>
          (d, r) :: arr
    end.

  Lemma arrayLookup_app_some_eq : forall ls d v,
    arrayLookup ls d = None ->
    arrayLookup (ls ++ (d, v) :: nil) d = Some v.

    induction ls; intuition; simpl in *.
    rewrite eqb_refl.
    trivial.

    case_eq (eqb d a0); intuition;
      rewrite H0 in H.
    discriminate.
    eauto.

  Qed.

  Lemma arrayLookup_app_none : forall ls d d' v',
    arrayLookup ls d = None ->
    arrayLookup (ls ++ (d, v') :: nil) d' = arrayLookup ((d, v') :: ls) d'.

    induction ls; intuition; simpl in *.

    case_eq (eqb d a0); intuition;
    rewrite H0 in H.
    discriminate.
    case_eq (eqb d' d); intuition.
    rewrite eqb_leibniz in H1.
    subst.
    case_eq (eqb d a0); intuition.
    rewrite eqb_leibniz in H1.
    subst.
    rewrite eqb_refl in H0.
    discriminate.

    eapply arrayLookup_app_some_eq.
    trivial.

    specialize (IHls d d').
    case_eq (eqb d' a0); intuition.
    rewrite H1 in IHls.
    eapply IHls.
    trivial.

  Qed.

  Lemma arrayLookup_app_ne : forall ls d r d',
    d <> d' ->
    arrayLookup (ls ++ (d, r) :: nil) d' = arrayLookup ls d'.

    induction ls; intuition; simpl in *.
    case_eq (eqb d' d); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.

    case_eq (eqb d' a0); intuition.

  Qed.

  Lemma arrayLookup_app_some : forall ls d d' v v',
    arrayLookup ls d = Some v ->
    arrayLookup (ls ++ (d, v') :: nil) d' = arrayLookup ls d'.

    induction ls; intuition; simpl in *.
    discriminate.

    case_eq (eqb d a0); intuition.
    rewrite H0 in H.
    inversion H; clear H; subst.
    rewrite eqb_leibniz in H0. subst.
    case_eq (eqb d' a0); intuition.

    eapply arrayLookup_app_ne.
    intuition.
    subst.
    rewrite eqb_refl in H.
    discriminate.
    rewrite H0 in H.

    case_eq (eqb d' a0); intuition.
    eapply IHls; eauto.
  Qed.

  Theorem arrayLookup_arrayUpdate_eq :
    forall arr p v,
      arrayLookup (arrayUpdate arr p (Some v)) p = (Some v).

    intuition.
    unfold arrayUpdate.
    destruct arr.
    simpl.
    rewrite eqb_refl.
    trivial.

    simpl.
    rewrite eqb_refl.
    trivial.
  Qed.

   Theorem arrayLookup_arrayUpdate_ne :
    forall arr p1 p2 v,
      p1 <> p2 ->
      arrayLookup (arrayUpdate (Some arr) p1 (Some v)) p2 = arrayLookup arr p2.

    intuition.
    unfold arrayUpdate.
    simpl.
    case_eq (eqb p2 p1); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.
  Qed.

   Theorem arrayLookup_arrayUpdate_None_ne :
     forall p1 p2 v,
       p1 <> p2 ->
       arrayLookup (arrayUpdate None p1 (Some v)) p2 = None.

     intuition.
     unfold arrayUpdate.
     simpl.
     case_eq (eqb p2 p1); intuition.
     rewrite eqb_leibniz in H0.
     subst.
     intuition.
  Qed.

End ListArray.

(* Some notation for array lookups *)
Declare Scope array_scope.
Notation "f '#' i " := (arrayLookup _ f i) (at level 70) : array_scope.

Local Open Scope array_scope.

(* A special case for array lookup when the range is lists -- returns nil instead of None when not found.  This is useful for multidimensional arrays. *)
Definition arrayLookupList(A B : Set)(eqd : EqDec A)(ls : list (A * (list B)))(a : A) :=
    match (arrayLookup _ ls a) with
      | None => nil
      | Some ls => ls
    end.

Require Import FCF.CompFold.

Lemma arrayLookup_Some_In_unzip :
  forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a b,
    (arr # a) = Some b ->
    In a (fst (unzip arr)).

  induction arr; intuition; simpl in *.
  discriminate.

  case_eq (eqb a a0); intuition;
  rewrite H0 in *.
  inversion H; clear H; subst.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.
  right.
  eapply IHarr.
  eauto.

Qed.

Lemma notInArrayLookupNone_unzip :
  forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a,
    (~ In a (fst (unzip arr))) ->
    (arr # a) = None.

  induction arr; intuition; simpl in *.

  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.

Qed.

Fixpoint arrayLookupOpt(A B : Set)(eqd : EqDec A)(ls : list (option (A * B)))(a : A) :=
  match ls with
    | nil => None
      | o :: ls' =>
        match o with
          | None => arrayLookupOpt _ ls' a
          | Some (a', b') =>
            if (eqb a a') then (Some b') else (arrayLookupOpt _ ls' a)
        end
  end.

Theorem list_pred_arrayLookupOpt :
  forall (A B C : Set)(P : B -> C -> Prop)(eqda : EqDec A)(ls1 : list (option (A * B)))(ls2 : list (option (A * C))),
    list_pred (fun o1 o2 =>
                 match o1 with
                   | None => o2 = None
                   | Some x =>
                     match o2 with
                       | None => False
                       | Some y =>
                         fst x = fst y /\ P (snd x) (snd y)
                     end
                 end) ls1 ls2 ->
    forall a,
      match (arrayLookupOpt _ ls1 a) with
        | None => (arrayLookupOpt _ ls2 a) = None
        | Some x => exists y, (arrayLookupOpt _ ls2 a) = Some y /\ P x y
      end.

  induction 1; intuition; simpl in *.
  trivial.

  destruct a1.
  destruct a2.
  destruct p.
  simpl in *.
  intuition.
  subst.
  destruct p0. simpl in *.
  case_eq (eqb a a0); intuition.
  econstructor.
  intuition.
  eapply IHlist_pred.
  destruct p.
  case_eq (eqb a a0); intuition.

  subst.
  eapply IHlist_pred.

Qed.

Theorem arrayLookupOpt_getSomes_eq :
  forall (A B : Set)(eqda : EqDec A)(ls : list (option (A * B)))(a : A),
       arrayLookupOpt _ ls a = arrayLookup _ (getSomes ls) a.

  induction ls; intuition; simpl in *.
  destruct a.
  destruct p.
  simpl.
  case_eq (eqb a0 a); intuition.

  eapply IHls.

Qed.

Theorem arrayLookup_app_Some :
  forall (A B : Set)(eqd : EqDec A)(ls1 ls2 : list (A * B))(a : A)(b : B),
    arrayLookup eqd ls1 a = Some b ->
    arrayLookup eqd (ls1 ++ ls2) a = Some b.

  induction ls1; intuition; simpl in *.
  discriminate.

  case_eq (eqb a a0); intuition.
  rewrite H0 in H.
  trivial.

  rewrite H0 in H.
  eauto.

Qed.

Theorem arrayLookup_app_None :
  forall (A B : Set)(eqd : EqDec A)(ls1 ls2 : list (A * B))(a : A),
    arrayLookup eqd ls1 a = None ->
    arrayLookup eqd (ls1 ++ ls2) a =
    arrayLookup eqd ls2 a.

  induction ls1; intuition; simpl in *.
  case_eq (eqb a a0); intuition;
  rewrite H0 in H.
  discriminate.

  eauto.

Qed.

Theorem arrayLookupList_pred :
  forall (A B : Set) (eqda : EqDec A)P (ls : list (A * list B)) a,
    (forall x, In x ls -> P (snd x)) ->
    P nil ->
    P (arrayLookupList _ ls a).

  induction ls; intuition; simpl in *.
  unfold arrayLookupList.
  simpl.
  case_eq (eqb a a0); intuition.
  specialize (X (a0, b)).
  intuition.

  eapply IHls; intuition.

Qed.

Theorem arrayLookup_Some_impl_In :
  forall (A B : Set)(eqd : EqDec A)(ls : list (A * B)) a b,
    arrayLookup _ ls a = Some b ->
    In (a, b) ls.

  induction ls; intuition; simpl in *.
  discriminate.
  case_eq (eqb a a0); intuition;
  rewrite H0 in H.
  inversion H; clear H; subst.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.

  right.
  eauto.
Qed.

Theorem list_pred_impl_arrayLookup :
  forall (A B C : Set) P (eqda : EqDec A)(ls1 : list (A * B))(ls2 : list (A * C)),
    list_pred (fun x y => fst x = fst y /\ P (snd x) (snd y)) ls1 ls2 ->
    (forall v z, arrayLookup _ ls1 v = Some z -> exists z', arrayLookup _ ls2 v = Some z' /\ P z z') /\
    (forall v, arrayLookup _ ls1 v = None -> arrayLookup _ ls2 v = None).

  induction 1; intros; simpl in *.

  intuition.
  discriminate.

  destruct a1.
  destruct a2.
  destruct H.
  simpl in *.
  subst.

  intuition.

  case_eq (eqb v a0); intuition.
  rewrite H4 in H3.
  inversion H3; clear H3; subst.
  econstructor; eauto.
  rewrite H4 in H3.
  edestruct H.
  eauto.
  intuition.

  case_eq (eqb v a0); intuition.
  rewrite H4 in H3.
  discriminate.
  rewrite H4 in H3.
  eauto.

Qed.

Theorem arrayLookup_In_NoDup :
  forall (A B : Set)(eqda : EqDec A)(ls : list (A * B)) a b,
    In (a, b) ls ->
    NoDup (fst (split ls)) ->
    arrayLookup _ ls a = Some b.

  induction ls; intuition; simpl in *.
  intuition.

  remember (split ls) as z.
  destruct z.
  intuition.
  pairInv.
  simpl in *.
  inversion H0; clear H0; subst.
  rewrite eqb_refl.
  trivial.

  simpl in *.
  inversion H0; clear H0; subst.
  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H.
  subst.
  eapply in_split_l in H1.
  rewrite <- Heqz in H1.
  simpl in *.
  intuition.

Qed.

Theorem arrayLookup_None_not_In :
  forall (A B : Set)(eqda : EqDec A)(ls : list (A * B)) a,
    arrayLookup _ ls a = None ->
    In a (fst (split ls)) -> False.

  induction ls; intuition; simpl in *.
  remember (split ls) as z.
  destruct z.
  simpl in *.
  intuition; subst.
  rewrite eqb_refl in H.
  discriminate.
  destruct (eqb a a0).
  discriminate.
  eauto.
Qed.

Theorem arrayLookup_pair_None :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B) (ls : list (A * B * C)) a b,
    (forall x, In x ls -> fst (fst x) <> a) ->
    arrayLookup _ ls (a, b) = None.

  induction ls; intuition; simpl in *.
  case_eq (eqbPair eqda eqdb (a0, b1) (a, b0)); intuition.
  exfalso.
  unfold eqbPair in *.
  simpl in *.
  apply andb_true_iff in H0.
  intuition.
  rewrite eqb_leibniz in H1.
  subst.
  eapply H.
  left.
  reflexivity.
  trivial.
  eauto.

Qed.

Theorem arrayLookup_pair_flatten_none :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B) keys (ls : list (list (A * B * C))) a b,
    list_pred (fun a b => forall x, In x b -> fst (fst x) = a) keys ls ->
    (~ In a keys) ->
    arrayLookup (pair_EqDec eqda eqdb) (flatten ls) (a, b) = None.

  induction keys; intuition; simpl in *.
  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  intuition.
  simpl.

  case_eq (arrayLookup (pair_EqDec eqda eqdb) a2 (a0, b)); intuition.
  rewrite  arrayLookup_pair_None in H0.
  discriminate.
  intuition.
  subst.
  eapply H.
  symmetry.
  eapply H3.
  trivial.

  rewrite arrayLookup_app_None; trivial.
  eauto.

Qed.

Theorem arrayLookup_flatten_eq :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B)(ls : list (list (A * B * C))) keys a b,
    list_pred (fun a b => forall x, In x b -> fst (fst x) = a) keys ls ->
    NoDup keys ->
    arrayLookup _ (flatten ls) (a, b) =
    arrayLookup _ (arrayLookupList _ (combine keys ls) a) (a, b).

  induction ls; intuition; simpl in *.
  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  simpl.
  unfold arrayLookupList.
  simpl.
  inversion H0; clear H0; subst.
  case_eq (eqb a0 a1); intuition.

  case_eq (arrayLookup (pair_EqDec eqda eqdb) a (a0, b)); intuition.
  eapply arrayLookup_app_Some.
  trivial.

  rewrite eqb_leibniz in H.
  subst.

  rewrite arrayLookup_app_None; intuition.

  eapply arrayLookup_pair_flatten_none.
  eauto.
  intuition.

  case_eq ( arrayLookup _ a (a0, b) ); intuition.
  rewrite  arrayLookup_pair_None in H0.
  discriminate.
  intuition.
  subst.
  eapply eqb_false_iff in H.
  intuition.
  rewrite arrayLookup_app_None.
  eapply IHls; intuition.
  trivial.
Qed.

Theorem arrayLookup_pair_snd :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B)(ls1 : list (A * B * C))(ls2 : list (B * C)) a b,
    list_pred (fun x y => fst (fst x) = a /\ snd (fst x) = fst y /\ snd x = snd y) ls1 ls2 ->
    arrayLookup _ ls1 (a, b) =
    arrayLookup _ ls2 b.

  induction ls1; intuition; simpl in *.
  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  simpl.
  intuition.
  subst.
  simpl in *.
  subst.
  destruct a2.
  simpl in *.
  unfold eqbPair.
  simpl.
  rewrite eqb_refl.
  simpl.
  case_eq (eqb b1 b); intuition.

Qed.

Theorem arrayLookup_pred_2 :
  forall (A B C: Set)(eqda : EqDec A) (P : list B -> list C -> Prop) (ls1 : list (A * list B))(ls2 : list (A * list C)) a,
    list_pred (fun x y => (fst x = a \/ fst y = a) -> (fst x = a /\ fst y = a /\ P (snd x) (snd y))) ls1 ls2 ->
    P nil nil ->
    P (arrayLookupList _ ls1 a) (arrayLookupList _ ls2 a).

  induction ls1; intuition; simpl in *.
  inversion H; clear H; subst.
  unfold arrayLookupList.
  simpl.
  trivial.

  inversion H; clear H; subst.
  unfold arrayLookupList.
  simpl.
  destruct a2.

  simpl in *.
  intuition.

  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H2.
  subst.
  intuition.
  subst.
  rewrite eqb_refl.
  trivial.

  case_eq (eqb a a1); intuition.
  rewrite eqb_leibniz in H3.
  subst.
  intuition.
  subst.
  rewrite eqb_refl in H2.
  discriminate.

  eapply IHls1; intuition.
Qed.

Theorem In_arrayLookupList :
  forall (A B : Set)(eqda : EqDec A)(a : A)(b : B) ls,
    In b (arrayLookupList _ ls a) ->
    exists ls', In (a, ls') ls /\
                In b ls'.

  intuition.
  unfold arrayLookupList in *.
  case_eq (arrayLookup eqda ls a); intuition;
  rewrite H0 in H.
  eapply arrayLookup_Some_impl_In in H0.
  econstructor.
  split.
  eauto.
  trivial.

  simpl in *.
  intuition.

Qed.

Theorem arrayLookupList_pred'
: forall (A B : Set) (eqda : EqDec A) (P : list B -> Type)
         (ls : list (A * list B)) (a : A),
    (forall x : list B, In (a, x) ls -> P x) ->
    (arrayLookup _ ls a = None -> P nil) ->
    P (arrayLookupList eqda ls a).

  induction ls; intuition; simpl in *.
  unfold arrayLookupList.
  simpl.
  case_eq (eqb a a0); intuition.
  eapply X.
  rewrite eqb_leibniz in H.
  subst.
  intuition.

  case_eq (arrayLookup eqda ls a); intuition.
  specialize (IHls a).
  unfold arrayLookupList in *.
  rewrite H0 in IHls.
  eapply IHls; eauto.
  intuition.
  discriminate.

  rewrite H in X0.
  intuition.
Qed.
Theorem arrayLookup_allNats_eq :
  forall (B : Set)(ls : list (nat * B)) i,
    fst (split ls) = allNatsLt (length ls) ->
    arrayLookup _ ls i =
    match nth_option ls i with
      | Some (_, v) => Some v
              | None => None
    end.

  induction ls using rev_ind; intuition; simpl in *.
  rewrite app_length in H.
  rewrite fst_split_app_eq in H.
  simpl in *.
  rewrite plus_comm in H.
  simpl in *.
  eapply app_inj_tail in H.
  intuition.
  subst.

  case_eq (nth_option ls i); intuition.

  erewrite nth_option_app_Some ; eauto.
  destruct p.

  case_eq (arrayLookup nat_EqDec ls i); intuition.
  erewrite arrayLookup_app_Some; eauto.
  rewrite IHls.
  rewrite H.
  trivial.
  trivial.

  eapply arrayLookup_None_not_In in H1.
  intuition.
  rewrite H0.
  eapply allNatsLt_lt_if.

  eapply nth_option_Some_lt.
  eauto.

  rewrite nth_option_app_None.
  simpl.
  case_eq (i - length ls); intuition.

  eapply nth_option_None_ge in H.
  assert (i = length ls).
  lia.
  subst.

  case_eq (arrayLookup _ ls (length ls)); intuition.
  exfalso.
  eapply arrayLookup_Some_impl_In in H2.
  eapply in_split_l in H2.
  simpl in *.
  rewrite H0 in H2.
  eapply allNatsLt_lt in H2.
  lia.
  rewrite arrayLookup_app_None; eauto.
  simpl.
  rewrite eqb_refl.
  trivial.

  case_eq (arrayLookup _ ls i); intuition.
  eapply arrayLookup_Some_impl_In in H2.
  eapply in_split_l in H2.
  simpl in *.
  rewrite H0 in H2.
  eapply allNatsLt_lt in H2.
  lia.

  rewrite arrayLookup_app_None; eauto.
  simpl.
  case_eq ( eqb i (length ls)); intuition.
  rewrite eqb_leibniz in H3.
  subst.
  lia.
  trivial.

Qed.

Theorem notInArrayLookupNone:
  forall (A B : Set) (eqd : EqDec A)
    (arr : Array A B) (a : A),
  ~ In a (fst (split arr)) ->
  arrayLookup eqd arr a = None.

  induction arr; intuition; simpl in *.
  remember (split arr) as z. destruct z.
  simpl in *.
  intuition idtac.
  case_eq (eqb a a0); intros.
  rewrite eqb_leibniz in H.
  subst.
  intuition idtac.
  eauto.

Qed.

Theorem arrayLookup_In_split : forall (A B : Set)(eqd : EqDec A)(ls : list (A * B)) a b,
  arrayLookup _ ls a = Some b ->
  In a (fst (split ls)).

  induction ls; intuition idtac; simpl in *.
  discriminate.
  remember (split ls) as z.
  destruct z.
  simpl.
  case_eq (eqb a a0); intros.
  rewrite eqb_leibniz in H0.
  subst.
  intuition idtac.
  rewrite H0 in H.
  eauto.

Qed.

Theorem arrayLookup_perm_eq : forall (A B : Set)(eqd : EqDec A)(ls1 ls2 : list (A * B)),
  Permutation ls1 ls2 ->
  NoDup (fst (split ls1)) -> NoDup (fst (split ls2)) ->
  (forall x, arrayLookup _ ls1 x = arrayLookup _ ls2 x).

  induction 1; intuition idtac; simpl in *.
  destruct x.
  case_eq (eqb x0 a); intros.
  trivial.
  remember (split l') as z. destruct z.
  remember (split l) as z. destruct z.
  simpl in *.
  inversion H0; clear H0; subst.
  inversion H1; clear H1; subst.
  eapply IHPermutation; eauto.

  destruct y.
  destruct x.
  remember (split l) as z. destruct z.
  simpl in *.
  case_eq (eqb x0 a); intros.
  rewrite (eqb_leibniz) in H1. subst.
  case_eq (eqb a a0); intros.
  rewrite eqb_leibniz in H1.
  subst.
  inversion H0; clear H0; subst.
  simpl in *.
  intuition idtac.
  trivial.
  reflexivity.

  rewrite H3.
  rewrite IHPermutation2.
  trivial.
  eapply Permutation_NoDup.
  eapply fst_split_perm; eauto.
  trivial.
  trivial.
  eapply Permutation_NoDup.
  eapply fst_split_perm; eauto.
  trivial.

Qed.


Require Import BinPos.
Require Import ZArith.
Require Import FMapPositive.
Require Import String.

Require Import Setoid.

Set Implicit Arguments.

(** * Maps

  Define maps, by making constructors for
  empty and singleton maps and map union,
  and defining a suitable equivalence relation *)

(* TODO:
   define a well-formedness predicate saying keys are not repeated,
   augment language definition with a proof that all evaluation
   steps preserve it
 *)

Inductive Map (Key Elt : Type) : Type :=
| mapEmpty
| mapItem (k : Key) (v : Elt)
| mapJoin (m1 m2 : Map Key Elt)
.
Arguments mapEmpty [Key Elt].

(** ** Map notations
 *)
Delimit Scope Map with Map.
Bind Scope Map with Map.

Open Scope Map.

Arguments mapJoin (_ _)%type (m1 m2)%Map.
Infix "|->" := mapItem (at level 50, no associativity) : Map.
Infix ":*" := mapJoin (at level 60, right associativity) : Map.

(** ** Map equivalence

  Map equivalence is axiomatized by
  identitiy, associativity, commutativity, and congruence of union,
  closed under reflexivity, symmetry, and transitivity.
 *)
Inductive MapEquiv {K E : Type} : Map K E -> Map K E -> Prop :=
| equivUnit : forall m, MapEquiv (m :* mapEmpty) m
| equivComm : forall m1 m2, MapEquiv (m1 :* m2) (m2 :* m1)
| equivAssoc : forall m1 m2 m3, MapEquiv ((m1 :* m2) :* m3) (m1 :* (m2 :* m3))

| equivJoin : forall l1 r1 l2 r2, MapEquiv l1 l2 -> MapEquiv r1 r2 -> MapEquiv (l1 :* r1) (l2 :* r2)
| equivTrans : forall m1 m2 m3, MapEquiv m1 m2 -> MapEquiv m2 m3 -> MapEquiv m1 m3
| equivSym : forall m1 m2, MapEquiv m1 m2 -> MapEquiv m2 m1
| equivRefl : forall m, MapEquiv m m
.

Infix "~=" := MapEquiv (at level 70, no associativity) : Map.

(** Registering map equivalence as an equivalence relation *)

Add Parametric Relation (K E : Type) : (Map K E) MapEquiv
  reflexivity proved by equivRefl
  symmetry proved by equivSym
  transitivity proved by equivTrans
  as map_equiv_rel.

Add Parametric Morphism K E : (@mapJoin K E) with
  signature MapEquiv ==> MapEquiv ==> MapEquiv as map_join_mor.
Proof. auto using equivJoin. Qed.

(** Some derived equivalences *)

(** A unit law with the unit on the left *)
Lemma equivUnitL : forall {K V} (m : Map K V), MapEquiv (mapEmpty :* m) m.
intros. rewrite equivComm. apply equivUnit.
Qed.

(** Switching the first two maps in a right-associated sequence *)
Lemma equivComAssoc : forall {K V} (m1 m2 m3 : Map K V), m1 :* m2 :* m3 ~= m2 :* m1 :* m3.
intros. rewrite <- equivAssoc, (equivComm m1 m2), equivAssoc. reflexivity. Qed.

(** ** Map Equality Tactic

  The map equality tactic [equate_maps] tries to solve map equations involving
  at most one map-typed evar.

  The general approach is to put both maps into a standard form,
  as a sequence of singleton items and residual map-typed variables,
  then cancel entries between the sides, until everything that's
  left can be absorbed into the evar (or we're stuck with
  a residual equation).
 *)

(** *** Finding items in a map
    These are the tactics for commuting target items to the
    head of a map *)

(** Specializing congruence for the find tactic *)
Definition equivJoinL {K V} (r : Map K V) l1 l2 pfl : l1 :* r ~= l2 :* r :=
  equivJoin pfl (equivRefl r).
Definition equivJoinR {K V} (l : Map K V) r1 r2 pfr :  l :* r1 ~= l :* r2 :=
  equivJoin (equivRefl l) pfr.

(** Find an entry with key [x] in map [map].
    If found, it calls the continuation tactic [k] on
    an equality of the form [map ~= x |-> _ :* _],
    otherwise it simply fails.
 *)
Ltac find x map k :=
  match map with
    | (x |-> _) => let pf := constr:(equivSym (equivUnit map)) in k pf
    | (x |-> _ :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* (x |-> ?v)) => let pf := constr:(equivComm mapl (x |-> v)) in k pf
    | ?mapl :* ?mapr =>
           find x mapl ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc (x |-> _) _ mapr))
                                        in k pf)
        || find x mapr ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl (x |-> _) _))
                                        in k pf)
  end.

(** Find an entire map [submap] appearing exactly all or part of a map [map].
    It's expeted that [submap] be a variable, this tactic makes no attempt
    to search search up to map equality if [submap] is a more complicated
    map expression.
    If found, calls the continuation tactic [k] on an equality of the form
    [map ~= submap :* _]
 *)
Ltac find_submap map submap k :=
  match map with
    | submap => let pf := constr:(equivSym (equivUnit map)) in k pf
    | (submap :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* submap) => let pf := constr:(equivComm mapl submap) in k pf
    | ?mapl :* ?mapr =>
           find_submap mapl submap

                       ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc submap _ mapr))
                                        in k pf)
        || find_submap mapr submap
                       ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl submap _))
                                        in k pf)
  end.

(** *** Map well-formedness predicates

    [check_maps] checks that each map is right associated,
    has items before map-typed ordinary variables before
    evars, and that there is at most one evar, on the right side.

    [is_map_exp] is also used elsewhere, and succeeds only if the given
    map is neither an evar nor any of the map constructors.
 *)

Ltac is_map_exp m :=
  match m with
    | (_ |-> _) => fail 1
    | (_ :* _) => fail 1
    | mapEmpty => fail 1
    | _ => try (is_evar m;fail 2)
  end.
Ltac check_left_var_map m :=
  match m with
    | (?l :* ?m') => is_map_exp l;check_left_var_map m'
    | _ => is_map_exp m
  end.
Ltac check_left_map m :=
  match m with
    | mapEmpty => idtac
    | _ |-> _ => idtac
    | (_ |-> _ :* ?m') => check_left_map m'
    | _ => check_left_var_map m
  end.
Ltac check_right_var_map m :=
  match m with
    | (?l :* ?m') => is_map_exp l;check_right_var_map m'
    | _ => first [is_evar m | is_map_exp m]
  end.
Ltac check_right_map m :=
  match m with
    | mapEmpty => idtac
    | _ |-> _ => idtac
    | (_ |-> _ :* ?m') => check_right_map m'
    | _ => check_right_var_map m
  end.
Ltac check_maps :=
  match goal with
    | [|- ?l ~= ?r] => check_left_map l;check_right_map r
  end.

(** *** Preparing maps.

    An equation is prepared by using any map equation hypotheses to
    expand variables in the maps involed,
    then using map equalities to remove empties, right-associate
    unions, and move singleton items to the front.

    This tactic isn't entirely careful about locating evars,
    but they are checked afterwards.
 *)
Ltac expand_map m :=
  match m with
    | ?l :* ?r => expand_map l; expand_map r
    | ?v => is_var v;
           match goal with
             | [H : v ~= ?m |- _] => rewrite !H;try (clear v H);expand_map m
             | [H : ?m ~= v |- _] => rewrite <- !H;try (clear v H);expand_map m
           end
    | _ => idtac
  end.

(* maybe do by reflection? *)
Ltac prepare_maps :=
  match goal with
    | [|- ?l ~= ?r] => expand_map l;expand_map r
  end;
  repeat
    match goal with
        | [|- context [mapEmpty :* ?m]] => rewrite (equivUnitL m)
        | [|- context [?m :* mapEmpty]] => rewrite (equivUnit m)
        | [|- context [(?m1 :* ?m2) :* ?m3]] => rewrite (equivAssoc m1 m2 m3)
  end;
  (* switch if left side has a map evar *)
  match goal with
    | [|- ?l ~= ?r] =>
        match l with
          | context [?v] => is_evar v;
            match type of v with Map _ _  => symmetry end
        end
    | _ => idtac
  end;
  (* Now commute items to the front things *)
  repeat match goal with
           | [|- context [?m1 :* ?m2 :* ?m3]] =>
             match m2 with _ |-> _ => is_map_exp m1; rewrite (equivComAssoc m1 m2 m3)
             end
           | [|- context [?m1 :* ?m2]] =>
             match m2 with _ |-> _ => is_map_exp m1; rewrite (equivComm m1 m2)
             end
         end
  .

(* *** Solving the map equation

   After preparing the maps, the left side has no evars, so the non-evar
   part of the RHS must appear as a submap of the left side.

   This tactic proceeds item by item, finding and cancelling identical
   items between sides.
   If this ends with an equation between a map and an evar it is
   instantiated.

   If the equation isn't completely solved, the tactic still succeeds,
   leaving the reduced equation.
 *)
Ltac equate_maps :=
  prepare_maps;
  first[check_maps| fail 1];
  (* Find item or submap when rhs has a join *)
  repeat match goal with
  | [|- MapEquiv ?map (?x |-> _ :* _)] => find x map
      ltac:(fun pf => apply (equivTrans pf);apply equivJoinR)
  | [|- MapEquiv ?map (?submap :* _)] => find_submap map submap
      ltac:(fun pf => apply (equivTrans pf);apply equivJoinR)
  end;
  (* If we're not failing, the rhs is down to a join-free map.
     Because the lhs is still in prepared form, reflexivity
     can handle all the remaining solvable possibilities.
    *)
  try reflexivity.