(** This file defines the general requirements imposed on the syntax of OLs to prove cut-elimination. *)

Require Export LL.Misc.UtilsForall.
Require Export LL.SL.FLL.Specifications.OL2FLL.
Require Export LL.SL.FLL.Tactics.

Set Implicit Arguments.

Section OLSyntax.
Context `{OL:OLSyntax}.

Section PositiveAtoms.

Lemma  positiveIsAtom A: IsPositiveAtomFormula A -> IsPositiveAtom A.
Proof with subst;auto.
  intros.
  inversion H...
Qed.

Lemma  OLFormula2PosUPFormulaL A: isOLFormula A ->IsPositiveAtomFormulaL [atom (up A)].
Proof with subst;auto.
  intros.
  constructor...
Qed.

Lemma  OLFormula2PosDWFormulaL A: isOLFormula A ->IsPositiveAtomFormulaL [atom (down A)].
Proof with subst;auto.
  intros.
  constructor...
Qed.

Global Instance perm_IsPositiveAtomFormulaL  :
      Proper (@Permutation oo ==> Basics.impl)
             (IsPositiveAtomFormulaL ).
Proof.
  unfold Proper; unfold respectful; unfold Basics.impl.
  intros.
  unfold IsPositiveAtomFormulaL.
  rewrite <- H;auto.
Qed.

Global Instance perm_IsPositiveAtomBFormulaL  :
      Proper (@Permutation oo ==> Basics.impl)
             (IsPositiveAtomBFormulaL ).
Proof.
  unfold Proper; unfold respectful; unfold Basics.impl.
  intros.
  unfold IsPositiveAtomBFormulaL.
  rewrite <- H;auto.
Qed.

Global Instance perm_IsOLFormulaL  :
      Proper (@Permutation uexp ==> Basics.impl)
             (isOLFormulaL ).
Proof.
  unfold Proper; unfold respectful; unfold Basics.impl.
  intros.
  unfold isOLFormulaL.
  rewrite <- H;auto.
Qed.

End PositiveAtoms.

Section OLEncodings.

Lemma LEncodeApp  L1 L2 : LEncode (L1++L2) = LEncode L1 ++ LEncode  L2.
Proof with sauto.
 unfold LEncode;
 rewrite map_app;auto.
Qed.

Lemma REncodeApp  L1 L2 : REncode (L1++L2) = REncode L1 ++ REncode  L2.
Proof with sauto.
  autounfold.
  rewrite map_app;auto.
Qed.

Lemma REncodeBApp  L1 L2 : REncodeB (L1++L2) = REncodeB L1 ++ REncodeB  L2.
Proof with sauto.
  autounfold.
  rewrite map_app;auto.
Qed.

Lemma LEncodePerm L1 L2 : Permutation L1 L2 -> Permutation (LEncode L1) (LEncode L2).
Proof.
   intros.
   apply Permutation_map;auto.
Qed.

Lemma REncodePerm L1 L2 : Permutation L1 L2 -> Permutation (REncode L1) (REncode L2).
Proof.
   intros.
   apply Permutation_map;auto.
Qed.

Lemma REncodeBPerm L1 L2 : Permutation L1 L2 -> Permutation (REncodeB L1) (REncodeB L2).
Proof.
   intros.
   apply Permutation_map;auto.
Qed.

 Theorem posDestruct' K: IsPositiveAtomFormulaL K -> exists K1 K2, Permutation K (LEncode K1 ++ REncode K2).
 Proof with sauto.
 induction K;intros...
 exists [], [].
 simpl;auto.
 inversion H...
 inversion H2...
 - destruct IHK...
   exists (A::x), x0.
   simpl...
 - destruct IHK...
   exists x, (A::x0).
   simpl.
   rewrite H1...
 Qed.

(*  Theorem posDestructB' K: IsPositiveAtomBFormulaL K -> exists K1 K2, Permutation K (LEncode K1 ++ REncodeB K2).
 Proof with sauto.
 induction K;intros...
 exists [], [].
 simpl;auto.
 inversion H...
 inversion H2...
 - destruct IHK...
   exists (A::x), x0.
   simpl...
 - destruct IHK...
   exists x, (A::x0).
   simpl.
   rewrite H1...
 Qed.

 *) Theorem destructREncode C: forall D1 D2, Permutation (REncode C) (D1++D2) ->
       exists X Y, Permutation D1 (REncode X) /\ Permutation D2 (REncode Y) /\ Permutation C (X++Y).
Proof with sauto.
  induction C;intros...
  simpl in H...
  exists [], []...
  simpl in H.
  checkPermutationCases H.
  - symmetry in H1.
    eapply IHC in H1...
    exists (a::x0), x1.
    simpl.
    rewrite <- H0...
 - symmetry in H1.
   eapply IHC in H1...
   exists x0, (a::x1).
   simpl...
   rewrite H4...
Qed.

 Theorem destructREncodeB C: forall D1 D2, Permutation (REncodeB C) (D1++D2) ->
       exists X Y, Permutation D1 (REncodeB X) /\ Permutation D2 (REncodeB Y) /\ Permutation C (X++Y).
Proof with sauto.
  induction C;intros...
  simpl in H...
  exists [], []...
  simpl in H.
  checkPermutationCases H.
  - symmetry in H1.
    eapply IHC in H1...
    exists (a::x0), x1.
    simpl.
    rewrite <- H0...
 - symmetry in H1.
   eapply IHC in H1...
   exists x0, (a::x1).
   simpl...
   rewrite H4...
Qed.

Theorem destructLEncode C: forall D1 D2, Permutation (LEncode C) (D1++D2) ->
       exists X Y, Permutation D1 (LEncode X) /\ Permutation D2 (LEncode Y) /\ Permutation C (X++Y).
Proof with sauto.
  induction C;intros...
  simpl in H...
  exists [], []...
  simpl in H.
  checkPermutationCases H.
  - symmetry in H1.
    eapply IHC in H1...
    exists (a::x0), x1...
    simpl.
    rewrite H...
    rewrite H4...
 - symmetry in H1.
   eapply IHC in H1...
   exists x0, (a::x1)...
   rewrite H...
   simpl...
   rewrite H4...
Qed.

Theorem destructEncode C1 C1' C2 C2':
    Permutation (LEncode C1 ++ REncode C2) (C1' ++ C2') ->
    exists K4_1 K4_2 K4_3 K4_4,
    Permutation C1' (LEncode K4_1 ++ REncode K4_2) /\
    Permutation C2' (LEncode K4_3 ++ REncode K4_4) /\
    Permutation C1 (K4_1 ++ K4_3) /\
    Permutation C2 (K4_2 ++ K4_4).
Proof with sauto.
  intros.
  revert dependent C1'.
  revert dependent C2.
  revert dependent C2'.
  induction C1;intros...
  * simpl in *...
     apply destructREncode in H...
     eexists [], x, [], x0...
  *
     simpl in H.
     checkPermutationCases H.
     - symmetry in H1.
       eapply IHC1 in H1...
       eexists (a::x0), x1, x2, x3...
       rewrite H...
       rewrite H0...
       rewrite <- app_comm_cons.
       rewrite H2...
    - symmetry in H1.
       eapply IHC1 in H1...
       eexists x0, x1, (a::x2), x3...
       rewrite H...
       simpl.
       rewrite H3...
       rewrite H2...
 Qed.

Theorem destructEncodeB C1 C1' C2 C2':
    Permutation (LEncode C1 ++ REncodeB C2) (C1' ++ C2') ->
    exists K4_1 K4_2 K4_3 K4_4,
    Permutation C1' (LEncode K4_1 ++ REncodeB K4_2) /\
    Permutation C2' (LEncode K4_3 ++ REncodeB K4_4) /\
    Permutation C1 (K4_1 ++ K4_3) /\
    Permutation C2 (K4_2 ++ K4_4).
Proof with sauto.
  intros.
  revert dependent C1'.
  revert dependent C2.
  revert dependent C2'.
  induction C1;intros...
  * simpl in *...
     apply destructREncodeB in H...
     eexists [], x, [], x0...
  *
     simpl in H.
     checkPermutationCases H.
     - symmetry in H1.
       eapply IHC1 in H1...
       eexists (a::x0), x1, x2, x3...
       rewrite H...
       rewrite H0...
       rewrite <- app_comm_cons.
       rewrite H2...
    - symmetry in H1.
       eapply IHC1 in H1...
       eexists x0, x1, (a::x2), x3...
       rewrite H...
       simpl.
       rewrite H3...
       rewrite H2...
 Qed.

Lemma PositiveAtomREOLFormula L : IsPositiveAtomFormulaL (REncode L) -> isOLFormulaL L.
Proof with sauto.
  intros.
  induction L;intros...
  inversion H...
  apply IHL in H3...
  apply Forall_cons;auto.
  inversion H2...
Qed.

Lemma PositiveAtomREOLFormulaB L : IsPositiveAtomFormulaL (REncodeB L) -> isOLFormulaL L.
Proof with sauto.
  intros.
  induction L;intros...
  inversion H...
  apply IHL in H3...
  apply Forall_cons;auto.
  inversion H2...
Qed.

Lemma PositiveAtomLEOLFormula L : IsPositiveAtomFormulaL (LEncode L) -> isOLFormulaL L.
Proof with sauto.
  intros.
  induction L;intros...
  inversion H...
  apply IHL in H3...
  apply Forall_cons;auto.
  inversion H2...
Qed.

Lemma PositiveAtomLEOLFormulaB L : IsPositiveAtomBFormulaL (LEncode L) -> isOLFormulaL L.
Proof with sauto.
  intros.
  induction L;intros...
  inversion H...
  apply IHL in H3...
  apply Forall_cons;auto.
  inversion H2...
Qed.

Lemma isOLLEncode : forall L, isOLFormulaL L -> IsPositiveAtomFormulaL (LEncode L).
Proof with subst;auto.
  intros.
  induction L; simpl...
  constructor.
  inversion H...
  apply IHL...
  inversion H...
Qed.

Lemma isOLLEncodeB : forall L, isOLFormulaL L -> IsPositiveAtomBFormulaL (LEncode L).
Proof with subst;auto.
  intros.
  induction L; simpl...
  constructor.
  inversion H...
  apply IHL...
  inversion H...
Qed.

Lemma isOLREncode : forall L, isOLFormulaL L -> IsPositiveAtomFormulaL (REncode L).
Proof with sauto.
  intros.
  induction L; simpl...
  constructor.
  inversion H...
  apply IHL...
  inversion H...
Qed.

Lemma isOLREncodeB : forall L, isOLFormulaL L -> IsPositiveAtomBFormulaL (REncodeB L).
Proof with sauto.
  intros.
  induction L; simpl...
  constructor. simpl.
  inversion H...
  apply IHL...
  inversion H...
Qed.

Lemma PermutationLEncode : forall L a x x1,
      Permutation (LEncode L) (atom (down  a ) :: x) -> Permutation (a :: x1) L -> Permutation x (LEncode x1).
Proof with sauto.
    intros.
    assert(Permutation (atom (down  a )  :: x) (LEncode ((a :: x1)))).
    {  symmetry.
       symmetry in H.
       apply Permutation_map_inv in H.
       do 2 destruct H.
       rewrite H.
       apply Permutation_map.
       simpl.
       rewrite <- H1.
       unfold LEncode.
       rewrite <- H0;auto.
      }
    simpl in H1.
    eapply (Permutation_cons_inv H1).
  Qed.

Lemma PermutationREncode : forall L a x x1,
      Permutation (REncode L) (atom (up  a ) :: x) -> Permutation (a :: x1) L -> Permutation x (REncode x1).
Proof with sauto.
    intros.
    assert(Permutation (atom (up  a )  :: x) (REncode ((a :: x1)))).
    {  symmetry.
       symmetry in H.
       apply Permutation_map_inv in H.
       do 2 destruct H.
       rewrite H.
       apply Permutation_map.
       simpl.
       rewrite <- H1.
       unfold REncode.
       rewrite <- H0;auto.
      }
    simpl in H1.
    eapply (Permutation_cons_inv H1).
  Qed.

Lemma PermutationREncodeB : forall L a x x1,
      Permutation (REncodeB L) (Bang (atom (up  a )) :: x) -> Permutation (a :: x1) L -> Permutation x (REncodeB x1).
Proof with sauto.
    intros.
    assert(Permutation (Bang (atom (up  a) )  :: x) (REncodeB ((a :: x1)))).
    {  symmetry.
       symmetry in H.
       apply Permutation_map_inv in H.
       do 2 destruct H.
       rewrite H.
       apply Permutation_map.
       simpl.
       rewrite <- H1...
      }
    simpl in H1.
    eapply (Permutation_cons_inv H1).
  Qed.

Lemma InLEncode : forall L a,
      In (atom (down  a ) ) (LEncode L) <-> In a L.
Proof with sauto.
  split;induction L;simpl;intros...
  inversion H0...
Qed.

Lemma InREncode : forall L a,
      In (atom (up  a ) ) (REncode L) <-> In a L.
Proof with sauto.
  split;induction L;simpl;intros...
  inversion H0...
Qed.

Lemma InREncodeB : forall L a,
      In (Bang (atom (up  a )) ) (REncodeB L) <-> In a L.
Proof with sauto.
  split;induction L;simpl;intros...
  inversion H0...
Qed.

Lemma isOLFormulaIn : forall F L,
      isOLFormulaL L -> In F L -> isOLFormula F.
Proof.
  intros.
  unfold isOLFormulaL in H.
  generalize (Forall_forall isOLFormula L );intro.
  destruct H1.
  apply H1 with (x:= F) in H ;auto.
 Qed.

Theorem NoDinR : forall F L, In (atom (down  F ) ) (REncode L) -> False .
Proof with sauto.
  intros.
  induction L;auto.
  simpl in H...
Qed.

Theorem NoDinRB : forall F L, In (atom (down  F ) ) (REncodeB L) -> False .
Proof with sauto.
  intros.
  induction L;auto.
  simpl in H...
Qed.

Theorem NoUinL : forall F L, In (atom (up  F ) ) (LEncode L) -> False .
Proof with sauto.
  intros.
  induction L;auto.
  simpl in H...
Qed.

Theorem NoUinLB : forall F L, In (Bang (atom (up  F )) ) (LEncode L) -> False .
Proof with sauto.
  intros.
  induction L;auto.
  simpl in H...
Qed.

Theorem NoDinR' : forall F L x, Permutation (REncode L) (atom (down  F ) ::x) -> False .
Proof with sauto.
  intros.
  eapply NoDinR with (F:=F) (L:=L).
  rewrite H...
Qed.

Theorem NoDinRB' : forall F L x, Permutation (REncodeB L) (atom (down  F ) ::x) -> False .
Proof with sauto.
  intros.
  eapply NoDinRB with (F:=F) (L:=L).
  rewrite H...
Qed.

Theorem NoUinL' : forall F L x, Permutation (LEncode L) (atom (up  F ) ::x)  -> False .
Proof with sauto.
  intros.
  eapply NoUinL with (F:=F) (L:=L).
  rewrite H...
Qed.

Theorem NoUinLB' : forall F L x, Permutation (LEncode L) (Bang (atom (up  F )) ::x)  -> False .
Proof with sauto.
  intros.
  eapply NoUinLB with (F:=F) (L:=L).
  rewrite H...
Qed.

Theorem downLeft : forall L L' F,
      In (atom (down  F ) ) (LEncode L ++ REncode L') ->
      In (atom (down  F ) ) (LEncode L).
Proof with sauto.
  intros.
  apply in_app_or in H...
  apply NoDinR in H0...
Qed.

Theorem downLeftB : forall L L' F,
      In (atom (down  F ) ) (LEncode L ++ REncodeB L') ->
      In (atom (down  F ) ) (LEncode L).
Proof with sauto.
  intros.
  apply in_app_or in H...
  apply NoDinRB in H0...
Qed.

Theorem upRight : forall L L' F,
    In (atom (up  F ) ) (LEncode L ++ REncode L') ->
    In (atom (up  F ) ) (REncode L').
Proof with sauto.
  intros.
  apply in_app_or in H...
  apply NoUinL in H0...
Qed.

Theorem upRightD : forall L L' F,
    In (Bang (atom (up  F )) ) (LEncode L ++ REncodeB L') ->
    In (Bang (atom (up  F )) ) (REncodeB L').
Proof with sauto.
  intros.
  apply in_app_or in H...
  apply NoUinLB in H0...
Qed.

Theorem OLInPermutation: forall L F,
      In (atom (up  F )) (REncode L) ->
      exists L', Permutation L (F:: L').
Proof with sauto.
  induction L;intros...
  inversion H.
  simpl in H.

  inversion H...
  inversion H1...
  eexists;eauto.
  inversion H0...
  eexists;eauto.
  inversion H1...
  eexists;eauto.
  apply IHL in H1...
  exists (a::x).
  rewrite perm_takeit_6...
Qed.

Theorem OLInPermutationB: forall L F,
      In (Bang (atom (up  F ))) (REncodeB L) ->
      exists L', Permutation L (F:: L').
Proof with sauto.
  induction L;intros...
  inversion H.
  simpl in H.

  inversion H...
  inversion H1...
  eexists;eauto.
  inversion H0...
  eexists;eauto.
  inversion H1...
  eexists;eauto.
  apply IHL in H1...
  exists (a::x).
  rewrite perm_takeit_6...
Qed.

Lemma MapREncodeEqual: forall L L', (REncode L) = (REncode L') -> L = L'.
Proof with sauto.
  induction L;intros;simpl in *...
  erewrite map_eq_nil...
  exact (symmetry H).
  destruct L'...
  simpl in H.
  inversion H...
  erewrite IHL;auto.
Qed.

Lemma MapREncodeEqualB: forall L L', (REncodeB L) = (REncodeB L') -> L = L'.
Proof with sauto.
  induction L;intros;simpl in *...
  erewrite map_eq_nil...
  exact (symmetry H).
  destruct L'...
  simpl in H.
  inversion H...
  erewrite IHL;auto.
Qed.

Lemma MapLEncodeEqual: forall L L', (LEncode L) = (LEncode L') -> L = L'.
Proof with sauto.
  induction L;intros;simpl in *...
  erewrite map_eq_nil...
  exact (symmetry H).
  destruct L'...
  simpl in H.
  inversion H...
  erewrite IHL;auto.
Qed.

Lemma UpREncode P1 P2 L1 L2 :
    Permutation (atom (up  P1 )::REncode L1) (atom (up  P2 ):: REncode L2) ->
    (
      P1 = P2 /\ Permutation (REncode L1) (REncode L2)
    ) \/ (
      exists L2',
        Permutation (REncode L2) (atom (up  P1 )::REncode L2') /\
        Permutation (REncode L1) (atom (up  P2 )::REncode L2')
    ).
Proof with sauto.
  intro HP.
  assert (HI:=in_eq  (atom (up  P1 )) (REncode L1)).
  rewrite HP in HI.
  destruct HI as [HI|HI].
  - inversion HI...
    left.
    split;auto.
    apply Permutation_cons_inv in HP;auto.
  - right.
    apply in_map_iff in HI...
    inversion H...
    destruct (in_split _ _ H0) as (L2A,(L2B,HL2)).
    exists (L2A++L2B).
    split.
    + rewrite HL2.
      rewrite !REncodeApp.
      simpl...
    +
      rewrite HL2 in HP.
      rewrite REncodeApp in HP.
      simpl in HP.
      rewrite app_comm_cons in HP.
      eapply Permutation_cons_app_inv  in HP...
      rewrite HP.
      rewrite !REncodeApp.
      simpl...
 Qed.

Lemma UpREncodeB P1 P2 L1 L2 :
    Permutation (Bang (atom (up  P1 ))::REncodeB L1) (Bang (atom (up  P2 )):: REncodeB L2) ->
    (
      P1 = P2 /\ Permutation (REncodeB L1) (REncodeB L2)
    ) \/ (
      exists L2',
        Permutation (REncodeB L2) (Bang (atom (up  P1 ))::REncodeB L2') /\
        Permutation (REncodeB L1) (Bang (atom (up  P2 ))::REncodeB L2')
    ).
Proof with sauto.
  intro HP.
  assert (HI:=in_eq  (Bang (atom (up  P1 ))) (REncodeB L1)).
  rewrite HP in HI.
  destruct HI as [HI|HI].
  - inversion HI...
    left.
    split;auto.
    apply Permutation_cons_inv in HP;auto.
  - right.
    apply in_map_iff in HI...
    inversion H...
    destruct (in_split _ _ H0) as (L2A,(L2B,HL2)).
    exists (L2A++L2B).
    split.
    + rewrite HL2.
      rewrite !REncodeBApp.
      simpl...
    +
      rewrite HL2 in HP.
      rewrite REncodeBApp in HP.
      simpl in HP.
      rewrite app_comm_cons in HP.
      eapply Permutation_cons_app_inv  in HP...
      rewrite HP.
      rewrite !REncodeBApp.
      simpl...
 Qed.

Lemma DwLEncode P1 P2 L1 L2 :
    Permutation (atom (down  P1 )::LEncode L1) (atom (down  P2 )::LEncode L2) ->
    (
      P1 = P2 /\ Permutation (LEncode L1) (LEncode L2)
    ) \/ (
      exists L2',
        Permutation (LEncode L2) (atom (down  P1 )::LEncode L2') /\
        Permutation (LEncode L1) (atom (down  P2 )::LEncode L2')
    ).
Proof with sauto.
  intro HP.
  assert (HI:=in_eq  (atom (down  P1 )) (LEncode L1)).
  rewrite HP in HI.
  destruct HI as [HI|HI].
  - inversion HI...
    left.
    split;auto.
    apply Permutation_cons_inv in HP;auto.
  - right.
    apply in_map_iff in HI...
    inversion H...
    destruct (in_split _ _ H0) as (L2A,(L2B,HL2)).
    exists (L2A++L2B).
    split.
    + rewrite HL2.
      rewrite !LEncodeApp.
      simpl...
    +
      rewrite HL2 in HP.
      rewrite LEncodeApp in HP.
      simpl in HP.
      rewrite app_comm_cons in HP.
      eapply Permutation_cons_app_inv  in HP...
      rewrite HP.
      rewrite !LEncodeApp.
      simpl...
Qed.

Theorem OLInPermutation': forall L x F,
     Permutation (REncode L) (atom (up F ):: REncode x) ->
     Permutation L (F:: x).
Proof with sauto.
   induction L;intros...
   simpl in H...
   simpl in H...
   apply UpREncode in H...
   - apply Permutation_cons...
     apply Permutation_map_inv in H2...
     apply MapREncodeEqual in H...
   - apply IHL in H1.
     assert(Permutation (REncode x) (REncode (a :: x0))).
     rewrite H...
     apply Permutation_map_inv in H0...
     apply MapREncodeEqual in H2...
     rewrite H1.
     rewrite <- H3...
Qed.

Theorem OLInPermutationB': forall L x F,
     Permutation (REncodeB L) (Bang (atom (up F )):: REncodeB x) ->
     Permutation L (F:: x).
Proof with sauto.
   induction L;intros...
   simpl in H...
   simpl in H...
   apply UpREncodeB in H...
   - apply Permutation_cons...
     apply Permutation_map_inv in H2...
     apply MapREncodeEqualB in H...
   - apply IHL in H1.
     assert(Permutation (REncodeB x) (REncodeB (a :: x0))).
     rewrite H...
     apply Permutation_map_inv in H0...
     apply MapREncodeEqualB in H2...
     rewrite H1.
     rewrite <- H3...
Qed.

Theorem OLInPermutationL: forall L F,
      In (atom (down  F)) (LEncode L) ->
      exists L', Permutation L (F:: L').
Proof with sauto.
  induction L;intros.
  inversion H.
  simpl in H.
  destruct H.
  inversion H...
  eexists;eauto.
  apply IHL in H...
  exists (a:: x).
  rewrite H...
Qed.

Theorem OLInPermutationL': forall L x F,
     Permutation (LEncode L) (atom (down  F):: LEncode x) ->
     Permutation L (F:: x).
 Proof with sauto.
   induction L;intros...
   simpl in H...
   simpl in H...
   apply DwLEncode in H...
   - apply Permutation_cons...
     apply Permutation_map_inv in H2...
     apply MapLEncodeEqual in H...
   - apply IHL in H1.
     assert(Permutation (LEncode x) (LEncode (a :: x0))).
     rewrite H...
     apply Permutation_map_inv in H0...
     apply MapLEncodeEqual in H2...
     rewrite H1.
     rewrite <- H3...
Qed.

Theorem LEncodePermutation: forall L M,
     Permutation (LEncode L) (LEncode M) ->
     Permutation L M.
 Proof with sauto.
   induction M;intros...
   simpl in H...
  apply map_eq_nil in H...
  apply OLInPermutationL' in H...
Qed.

Theorem REncodePermutation: forall L M,
     Permutation (REncode L) (REncode M) ->
     Permutation L M.
 Proof with sauto.
   induction M;intros...
   simpl in H...
  apply map_eq_nil in H...
  apply OLInPermutation' in H...
Qed.

Theorem REncodeBPermutation: forall L M,
     Permutation (REncodeB L) (REncodeB M) ->
     Permutation L M.
 Proof with sauto.
   induction M;intros...
   simpl in H...
  apply map_eq_nil in H...
  apply OLInPermutationB' in H...
Qed.

Lemma LEncodePositiveAtom F L : In (F) (LEncode L) -> IsPositiveAtom F.
Proof with sauto.
  induction L;intros...
  inversion H.
  inversion H...
Qed.

Lemma REncodePositiveAtom F L : In (F) (REncode L) -> IsPositiveAtom F.
Proof with sauto.
  induction L;intros...
  inversion H.
  inversion H...
Qed.

Lemma InIsPositive : forall F L L', In F (LEncode L ++ REncode L') -> IsPositiveAtom F.
  Proof with sauto.
  intros.
  apply in_app_or in H...
  apply LEncodePositiveAtom in H0;auto.
  apply REncodePositiveAtom in H0;auto.
Qed.

Theorem checkEncodeCasesU L L' x F :
      Permutation (LEncode L ++ REncode L') (atom (up  F) :: x) ->
      exists x1, Permutation (REncode L') (atom (up  F) :: REncode x1) /\ Permutation (LEncode L++ REncode x1 ) x.
Proof with sauto.
  intros.
  checkPermutationCases H...
  apply NoUinL' in H...
  assert(In (atom (up  F)) (REncode L')).
  rewrite H...
  apply in_map_iff in H0...
  inversion H2...
  apply InPermutation in H3...
  assert(Permutation (REncode L') (REncode (F :: x1))).
  apply Permutation_map...
  assert(Permutation x0 (REncode x1)).
  rewrite H0 in H.
  simpl in H...
  apply Permutation_cons_inv in H...
   exists x1...
   rewrite <- H2...
 Qed.

 Theorem checkEncodeCasesD L L' x F :
      Permutation (LEncode L ++ REncode L') (atom (down  F):: x) ->
      exists x1, Permutation (LEncode L) (atom (down  F):: LEncode x1) /\ Permutation (LEncode x1++ REncode L' ) x.
Proof with sauto.
  intros.
  checkPermutationCases H...
  2:{ apply NoDinR' in H... }
  assert(In (atom (down  F)) (LEncode L)).
  rewrite H...
  apply in_map_iff in H0...
  inversion H2...
  apply InPermutation in H3...
  assert(Permutation (LEncode L) (LEncode (F :: x1))).
  apply Permutation_map...
  assert(Permutation x0 (LEncode x1)).
  rewrite H0 in H.
  simpl in H...
  apply Permutation_cons_inv in H...
   exists x1...
   rewrite <- H2...
 Qed.

  Lemma IsOLPositiveLREnc : forall L L',
      isOLFormulaL L -> isOLFormulaL L' ->
      IsPositiveAtomFormulaL (LEncode L ++ REncode L').
Proof.
  intros L L' HisL HisL'.
  apply isOLLEncode in HisL.
  apply isOLREncode in HisL'.
  apply Forall_app;auto.
Qed.

Lemma Remove_LEncode F D D' : Remove F D D' -> Remove (atom (down  F)) (LEncode D) (LEncode D').
Proof with sauto.
  intros.
  eapply Remove_Map in H.
  exact H.
Qed.

Lemma Remove_REncode F D D' : Remove F D D' -> Remove (atom (up F)) (REncode D) (REncode D').
Proof with sauto.
  intros.
  eapply Remove_Map in H.
  exact H.
Qed.

Lemma onlyAtomsLinear M L F :
     IsPositiveAtomFormulaL M ->
     positiveFormula F ->
     Permutation (F :: L) M -> False.
Proof with sauto;solvePolarity.
  intros HM HF HP.
  rewrite <- HP in HM.
  inversion HM...
  inversion H1...
Qed.

Lemma onlyAtomsLinearB M L F :
     IsPositiveAtomBFormulaL M ->
     positiveFormula F ->
     Permutation (F :: L) M -> exists A, isOLFormula A /\ F= (! ⌈ A ⌉).
Proof with sauto;solvePolarity.
  intros HM HF HP.
  rewrite <- HP in HM.
  inversion HM...
  inversion H1... exists A...
Qed.

Lemma onlyAtomsClassical M F:
     IsPositiveAtomFormulaL M ->
     ~ IsPositiveAtom F ->
     In F M
 -> False.
Proof with sauto;solvePolarity.
  intros HM HF HP.
  apply InPermutation in HP...
  rewrite HP in HM.
  inversion HM...
  inversion H1...
Qed.

Lemma AtomFtoAtomB M:
     IsPositiveAtomFormulaL M -> IsPositiveAtomBFormulaL M.
Proof with sauto.
  intros.
  induction H...
  inversion H...
Qed.
End OLEncodings.
End OLSyntax.

Ltac OLSolve :=   solveFoldFALL1 IsPositiveAtomFormulaL.
Ltac OLSolveB :=   solveFoldFALL1 IsPositiveAtomBFormulaL.


Require Import Imp.
Require Import Hoare.

Inductive hoare_proof : Assertion -> com -> Assertion -> Prop :=
  | H_Skip : forall P,     hoare_proof P SKIP P
  | H_Asgn : forall P i a, hoare_proof (P [ i |-> a]) (i ::= a) P
  | H_Seq  : forall P P' P'' c1 c2,
               hoare_proof P  c1 P'  ->
               hoare_proof P' c2 P'' ->
               hoare_proof P (c1 ;; c2) P''
  | H_If   : forall P b t e P',
               hoare_proof (fun st => P st /\   bassn b st) t P' ->
               hoare_proof (fun st => P st /\ ~ bassn b st) e P' ->
               hoare_proof P (IFB b THEN t ELSE e FI) P'
  | H_While : forall P b c,
               hoare_proof (fun st => P st /\ bassn b st) c P ->
               hoare_proof P (WHILE b DO c END)
                 (fun st => P st /\ ~ bassn b st)
  | H_Consequence : forall (P Q P' Q' : Assertion) c,
               hoare_proof P' c Q' ->
               (P ->> P') -> (Q' ->> Q) ->
               hoare_proof P  c Q
.

Lemma H_Consequence_pre : forall P P' c Q,
  hoare_proof P' c Q ->
  P ->> P' ->
  hoare_proof P  c Q.
Proof.
  intros. eapply H_Consequence; try eassumption.
  intros st X. assumption.
Qed.

Lemma H_Consequence_post : forall P c Q Q',
  hoare_proof P c Q' ->
  Q' ->> Q ->
  hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence; try eassumption.
  intros st X. assumption.
Qed.

(* Exercise: 2 stars (hoare_proof_sound) *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{ P }} c {{ Q }}.
Proof.
  intros.
  induction H.
  - apply hoare_skip.
  - apply hoare_asgn.
  - eapply hoare_seq; eassumption.
  - eapply hoare_if; eassumption.
  - apply hoare_while; assumption.
  - eapply hoare_consequence; eassumption.
Qed.

(* END hoare_proof_sound. *)

Definition wp (c : com) (Q : Assertion) : Assertion :=
  fun s => forall s', c / s ⇓ s' -> Q s'.

(* Exercise: 1 star (wp_is_precondition) *)

Lemma wp_is_precondition : forall c Q,
  {{ wp c Q }} c {{ Q }}.
Proof. unfold hoare_triple. auto. Qed.

(* END wp_is_precondition. *)

(* Exercise: 1 star (wp_is_weakest) *)

Lemma wp_is_weakest : forall c Q P',
  {{ P' }} c {{ Q }} -> forall st, P' st -> wp c Q st.
Proof.
  unfold hoare_triple. unfold wp. eauto.
Qed.

(* END wp_is_weakest. *)

(* Exercise: 5 stars (hoare_proof_complete) *)

Theorem hoare_proof_complete : forall P c Q,
  {{ P }} c {{ Q }} -> hoare_proof P c Q.
Proof.
  intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* SKIP *)
    eapply H_Consequence.
    + constructor.
    + intros st H. apply H.
    + intros st H. eapply HT. constructor. assumption.
  - (* i ::= a *)
    eapply H_Consequence_pre.
    + constructor.
    + intros st H. eapply HT. constructor. assumption.
  - (* c1 ;; c2 *)
    unfold hoare_triple in HT. apply H_Seq with (wp c2 Q);
      [apply IHc1 | apply IHc2]; unfold hoare_triple.
    + unfold wp. intros.
      apply HT with st; try apply E_Seq with st'; assumption.
    + auto.
  - (* IFB *)
    apply H_If;
      [ apply H_Consequence_pre with (wp c1 Q) |
        apply H_Consequence_pre with (wp c2 Q) ];
      unfold hoare_triple in IHc1; unfold hoare_triple in IHc2; auto;
      clear IHc1 IHc2; intros st [H H0] s' H'; apply HT with st; auto.
    + apply E_IfTrue; auto.
    + apply E_IfFalse; auto.
      destruct (beval st b) eqn : bevalb. contradiction. trivial.
  - (* WHILE *)
    unfold hoare_triple in HT.
    remember (wp (WHILE b DO c END) Q) as R.
    apply H_Consequence with (P' := R) (Q' := fun st => R st /\ ~ bassn b st).
    + apply H_While. apply IHc.
      unfold hoare_triple. intros. destruct H0. subst.
      unfold wp in H0. unfold wp. intros s' H'.
      apply H0.
      apply E_WhileLoop with st'; assumption.
    + intros st H. subst. intros st' H'. apply HT with st; assumption.
    + intros st [H h']. subst. apply H.
      apply E_WhileEnd.
      destruct (beval st b) eqn: bevalb.
      * contradiction.
      * trivial.
Qed.

(* END hoare_proof_complete. *)


Require Export rational.

Ltac int_contra :=
  match goal with
  | H : PosZ _ = Zero |- _ => inv H
  | H : PosZ _ = NegZ _ |- _ => inv H
  | H : Zero = PosZ _ |- _ => inv H
  | H : Zero = NegZ _ |- _ => inv H
  | H : NegZ _ = PosZ _ |- _ => inv H
  | H : NegZ _ = Zero |- _ => inv H
  | H : S _ = 0 |- _ => inv H
  | H : 0 = S _ |- _ => inv H
  end
.

Ltac simpl_int :=
  unfold int_mul in *; unfold int_plus in *;
  unfold int_plus_inv in *; repeat match goal with
  | [ H : context [ match ?x with P _ => _ end ] |- _ ] =>
    destruct x eqn: ?
  | [ |- context [ match ?x with P _ => _ end ] ] => destruct x eqn: ?
  | [ H : context [ match ?x with 0 => _ | S _ => _ end ] |- _ ] =>
    destruct x eqn: ?
  | [ |- context [ match ?x with 0 => _ | S _ => _ end ] ] =>
    destruct x eqn: ?
  end; try int_contra
.

Ltac destruct_posz :=
  repeat match goal with
  | [ |- context [ match ?x with PosZ _ => _ | _ => _ end ] ] =>
    destruct x eqn: ?
  | [ H : context [ match ?x with PosZ _ => _ | _ => _ end ] |- _ ] =>
    destruct x eqn: ?
  end; try (simpl_int; fail)
.

Ltac simpl_eq :=
  repeat match goal with
  | H : True |- _ => clear H
  | H : S _ = S _ |- _ => inv H
  | H : P _ = P _ |- _ => inv H
  | H : PosZ _ = PosZ _ |- _ => inv H
  | H : NegZ _ = NegZ _ |- _ => inv H
  | |- S ?x = S ?y => replace y with x; refl
  | |- P ?x = P ?y => replace y with x; refl
  | |- PosZ ?x = PosZ ?y => replace y with x; refl
  | |- NegZ ?x = NegZ ?y => replace y with x; refl
  end; refl
.

Ltac reverse :=
  match goal with
  | |- ?x = ?y => replace x with y; refl
  end
.

Lemma rational_le_refl : forall x, x <=/ x.
Proof.
  intros x.
  assert (Hzero : forall x, x +- --x = Zero). {
    clear; intros. destruct x; simpl; refl; destruct p;
    destruct (Nat.leb n n) eqn: EQ; reflection; try nia;
    replace (n - n) with 0 by nia; refl.
  }
  unfold rational_le.
  unfold rational_plus; unfold rational_plus_inv;
  destruct x as [[[a] | | [a]] b]; destruct_posz; try (
    simpl in *; trivial; fail
  ); rewrite <- int_dist_back; rewrite Hzero; simpl in *; trivial.
Qed.

Lemma rational_le_antisymm : forall x y, x <=/ y -> y <=/ x -> x =/ y.
Proof.
  intros.
  destruct x as [[[a] | | [a]] [b]]; destruct y as [[[c] | | [c]] [d]];
  unfold rational_le in *; unfold rational_plus in *;
  unfold rational_plus_inv in *; destruct_posz; simpl_int; simpl in *;
  repeat match goal with
  | [ H : context [ if ?x then _ else _ ] |- _ ] => destruct x eqn: ?
  end; simpl_eq; reflection; try nia.
Qed.

Lemma rational_le_trans : forall x y z, x <=/ y -> y <=/ z -> x <=/ z.
Proof.
  intros. unfold rational_le in *.
  assert (z +/ --/ x =/ z +/ --/ y +/ (y +/ --/ x)). {
    clear. apply rational_eq_symm.
    eapply rational_eq_trans; try eapply rational_plus_assoc.
    apply rational_eq_symm.
    assert (z =/ z +/ --/ y +/ y). {
      eapply rational_eq_trans; try eapply rational_plus_assoc.
      assert (--/y +/ y =/ Rational Zero (P 0)). {
        unfold rational_plus; unfold rational_plus_inv.
        clear. destruct y. destruct_posz; try (simpl in *; trivial; fail).
        rewrite <- int_dist_back. replace (-- i +- i) with Zero by (
          clear; destruct i; simpl_int; try destruct (Nat.leb n n);
          eauto; nia
        ). simpl in *; eauto.
      } eapply (rational_plus_wd _ _ z) in H.
      eapply rational_eq_trans in H; try eapply rational_plus_comm.
      apply rational_eq_symm in H. eapply rational_eq_trans;
      try eapply H. clear. destruct z. unfold rational_plus.
      destruct_posz; try (
        simpl in *; destruct_posz; simpl in *; int_contra
      ). simpl. destruct p; destruct p0. simpl in *.
      simpl_eq. rewrite <- int_mul_assoc. simpl in *; refl.
    } eapply (rational_plus_wd _ _ (--/ x)) in H. assumption.
  }
  assert (
    forall x y, x =/ y ->
    rational_nonnegative x <-> rational_nonnegative y
  ). {
    clear; intros; split; intros;
    destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
    simpl in *; eauto; destruct_posz.
  } eapply H2; try eassumption. clear H1 H2.
  remember (y +/ --/ x) as b; remember (z +/ --/ y) as a;
  revert H0 H; clear; intros H H0.
  destruct a as [[[a] | | [a]] n]; destruct b as [[[b] | | [b]] m];
  try (simpl in *; inv H; inv H0; fail); simpl in *; destruct_posz;
  simpl_int; eauto.
Qed.

Lemma rational_le_tri : forall x y,
  rational_abs (x +/ y) <=/ rational_abs x +/ rational_abs y.
Proof.
  intros. destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  unfold rational_abs; unfold rational_le;
  unfold rational_plus; unfold rational_plus_inv; destruct_posz; simpl_int;
  try (simpl in *; int_contra);
  repeat match goal with
  | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
  | [ H : context [ if ?x then _ else _ ] |- _ ] => destruct x eqn: ?
  end; trivial; reflection; try int_contra; simpl_eq; simpl;
  remember (fun x y => x - y) as minus;
  repeat match goal with
  | [ H : context [ minus ?x ?y ] |- _ ] =>
    replace (minus x y) with (S x - S y) in H by (subst; clear; eauto)
  | [ H : context [ S (S (?x + ?y)) ] |- _ ] =>
    replace (S (S (x + y))) with (S x + S y) in H by (clear; nia)
  | [ H : context [ ?x <= ?y ] |- _ ] => apply leb_refl in H;
    replace (Nat.leb x y) with (Nat.leb (S x) (S y)) in H by (clear; eauto)
  | [ H : context [ ?x > ?y ] |- _ ] => apply leb_frefl in H;
    replace (Nat.leb x y) with (Nat.leb (S x) (S y)) in H by (clear; eauto)
  end; reflection; repeat match goal with
  | [ H : context [ S ?x ] |- _ ] => remember (S x); match goal with
    | H : _ = S x |- _ => clear H
    end
  end; subst; try nia.
Qed.

Lemma rational_lt_asymm : forall x y, ~(x </ y /\ y </ x).
Proof.
  intros x y H; destruct H.
  destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  unfold rational_lt in *; unfold rational_plus in *;
  unfold rational_plus_inv in *; destruct_posz; simpl_int;
  repeat match goal with
  | [ H : context [ if ?x then _ else _ ] |- _ ] => destruct x eqn: ?
  end; try (
    unfold rational_positive; simpl in *; match goal with
    | H : False |- _ => inv H
    end; fail
  ); reflection; nia.
Qed.

Lemma rational_lt_trans : forall x y z, x </ y -> y </ z -> x </ z.
Proof.
  intros. unfold rational_lt in *.
  assert (z +/ --/ x =/ z +/ --/ y +/ (y +/ --/ x)). {
    clear. apply rational_eq_symm.
    eapply rational_eq_trans; try eapply rational_plus_assoc.
    apply rational_eq_symm.
    assert (z =/ z +/ --/ y +/ y). {
      eapply rational_eq_trans; try eapply rational_plus_assoc.
      assert (--/y +/ y =/ Rational Zero (P 0)). {
        unfold rational_plus; unfold rational_plus_inv.
        clear. destruct y. destruct_posz; try (simpl in *; trivial; fail).
        rewrite <- int_dist_back. replace (-- i +- i) with Zero by (
          clear; destruct i; simpl_int; try destruct (Nat.leb n n);
          eauto; nia
        ). simpl in *; eauto.
      } eapply (rational_plus_wd _ _ z) in H.
      eapply rational_eq_trans in H; try eapply rational_plus_comm.
      apply rational_eq_symm in H. eapply rational_eq_trans;
      try eapply H. clear. destruct z. unfold rational_plus.
      destruct_posz; try (
        simpl in *; destruct_posz; simpl in *; int_contra
      ). simpl. destruct p; destruct p0. simpl in *.
      simpl_eq. rewrite <- int_mul_assoc. simpl in *; refl.
    } eapply (rational_plus_wd _ _ (--/ x)) in H. assumption.
  } assert (
    forall x y, x =/ y ->
    rational_positive x <-> rational_positive y
  ). {
    clear; intros; split; intros;
    destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
    simpl in *; eauto; destruct_posz.
  } eapply H2; try eassumption. clear H1 H2.
  remember (y +/ --/ x) as b; remember (z +/ --/ y) as a.
  revert H0 H; clear; intros H H0.
  destruct a as [[[a] | | [a]] n]; destruct b as [[[b] | | [b]] m]; try (
    simpl in *; repeat match goal with
    | H : False |- _ => inv H
    end; fail
  ). clear. simpl; destruct_posz; simpl_int; simpl; trivial.
Qed.

Lemma rational_abs_wd : forall x y,
  x =/ y -> rational_abs x =/ rational_abs y.
Proof.
  intros. destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  unfold rational_eq in *; unfold rational_abs; simpl_int; refl; simpl_eq.
Qed.

Ltac rational_rw H := eapply rational_eq_trans; try eapply H.

Lemma rational_plus_inv_wd : forall x y,
  x =/ y <-> --/ x =/ --/ y.
Proof.
  intros; split; intros;
  destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  unfold rational_eq in *; unfold rational_plus_inv in *; simpl_int;
  trivial; simpl_eq.
Qed.

Lemma rational_le_wd : forall x y x' y',
  x =/ x' -> y =/ y' -> x <=/ y <-> x' <=/ y'.
Proof.
  assert (
    forall x y, x =/ y ->
    rational_nonnegative x <-> rational_nonnegative y
  ). {
    clear; intros; split; intros;
    destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
    simpl in *; eauto; destruct_posz.
  }
  intros; split; intros.
  + unfold rational_le in *. eapply H; try eassumption.
    revert H0 H1; clear; intros.
    eapply (rational_plus_wd _ _ (--/ x)) in H1. eapply rational_eq_symm.
    rational_rw H1. rational_rw rational_plus_comm.
    eapply rational_eq_symm. rational_rw rational_plus_comm.
    apply -> rational_plus_wd. apply -> rational_plus_inv_wd.
    eapply rational_eq_symm; eassumption.
  + unfold rational_le in *. eapply H; try eassumption.
    clear H H2. eapply (rational_plus_wd _ _ (--/ x)) in H1.
    rational_rw H1. rational_rw rational_plus_comm.
    eapply rational_eq_symm. rational_rw rational_plus_comm.
    apply -> rational_plus_wd. apply -> rational_plus_inv_wd.
    eapply rational_eq_symm; assumption.
Qed.

Lemma rational_lt_wd : forall x y x' y',
  x =/ x' -> y =/ y' -> x </ y <-> x' </ y'.
Proof.
  assert (
    forall x y, x =/ y ->
    rational_positive x <-> rational_positive y
  ). {
    clear; intros; split; intros;
    destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
    simpl in *; eauto; destruct_posz.
  } intros; split; intros.
  + unfold rational_lt in *. eapply H; try eassumption.
    revert H0 H1; clear; intros.
    eapply (rational_plus_wd _ _ (--/ x)) in H1. eapply rational_eq_symm.
    rational_rw H1. rational_rw rational_plus_comm.
    eapply rational_eq_symm. rational_rw rational_plus_comm.
    apply -> rational_plus_wd. apply -> rational_plus_inv_wd.
    eapply rational_eq_symm; eassumption.
  + unfold rational_lt in *. eapply H; try eassumption.
    clear H H2. eapply (rational_plus_wd _ _ (--/ x)) in H1.
    rational_rw H1. rational_rw rational_plus_comm.
    eapply rational_eq_symm. rational_rw rational_plus_comm.
    apply -> rational_plus_wd. apply -> rational_plus_inv_wd.
    eapply rational_eq_symm; assumption.
Qed.

Lemma rational_eq_minus : forall x y,
  x =/ y <-> x +/ --/ y =/ Rational Zero (P 0).
Proof.
  intros; split; intros;
  destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  unfold rational_eq in *; simpl; simpl_int; try int_contra;
  repeat match goal with
  | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
  end; trivial; reflection; try (simpl in *; int_contra); simpl_eq;
  try lia; unfold rational_plus in *; unfold rational_plus_inv in *;
  simpl_int; try (simpl in *; int_contra);
  repeat match goal with
  | [ H : context [ if ?x then _ else _ ] |- _ ] => destruct x eqn: ?
  end; reflection; try lia; simpl in *; int_contra.
Qed.

Lemma rational_le_lt : forall x y, x <=/ y <-> x </ y \/ x =/ y.
Proof.
  intros; split; intros.
  + unfold rational_lt; unfold rational_le in H. remember (y +/ --/ x).
    destruct r as [[[a] | | [a]] b] eqn: ?.
    - left; simpl; trivial.
    - right. apply rational_eq_symm. eapply rational_eq_minus.
      symmetry in Heqr. eassert (Heq : y +/ --/ x =/ Rational Zero b) by (
        rewrite Heqr; apply rational_eq_refl
      ). rational_rw Heq; clear.
      unfold rational_eq; simpl_int. trivial.
    - inv H.
  + destruct H.
    - unfold rational_lt in H; unfold rational_le. remember (y +/ --/ x).
      destruct r; simpl in *; try (inv H; fail).
      destruct i; try (inv H; fail). trivial.
    - apply rational_eq_symm in H. apply rational_eq_minus in H.
      unfold rational_le. remember (y +/ --/ x).
      destruct r as [[[a] | | [a]] b]; simpl in *; trivial. inv H.
Qed.

Lemma rational_plus_inv_mul : forall x,
  --/ x =/ Rational (NegZ (P 0)) (P 0) */ x.
Proof.
  intros; destruct x as [[[a] | | [a]] b] eqn: ?;
  unfold rational_plus_inv; unfold rational_eq; unfold rational_mul;
  simpl_int; trivial; try (
    simpl in *; int_contra
  ); simpl in *; simpl_eq; nia.
Qed.

Lemma rational_lt_plus : forall a b c d,
  a </ b -> c </ d -> a +/ c </ b +/ d.
Proof.
  intros. unfold rational_lt in *.
  assert (
    forall x y, x =/ y ->
    rational_positive x <-> rational_positive y
  ). {
    clear; intros; split; intros;
    destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
    simpl in *; eauto; destruct_posz.
  } assert (
    b +/ --/ a +/ (d +/ --/ c) =/ b +/ d +/ --/ (a +/ c)
  ). {
    clear.
    assert (H : forall p q r : rational, p +/ q +/ r =/ p +/ (q +/ r)). {
      clear; intros. apply rational_eq_symm. apply rational_plus_assoc.
    } rational_rw H. apply rational_eq_symm. rational_rw H.
    rational_rw rational_plus_comm. apply rational_eq_symm.
    rational_rw rational_plus_comm. apply -> rational_plus_wd.
    assert (H0 := rational_plus_comm d (--/ c)).
    eapply (rational_plus_wd _ _ (--/ a)) in H0.
    assert (H1 := rational_plus_comm (d +/ --/ c) (--/ a)).
    apply rational_eq_symm in H1.
    assert (H2 := rational_eq_trans _ _ _ H1 H0).
    rational_rw H2. rational_rw rational_plus_comm. clear H0 H1 H2.
    rational_rw rational_plus_assoc. apply rational_eq_symm.
    rational_rw rational_plus_comm. apply -> rational_plus_wd.
    rational_rw rational_plus_inv_mul.
    rational_rw rational_dist_front.
    assert (H0 := rational_plus_inv_mul a).
    eapply (rational_plus_wd _ _ (--/ c)) in H0.
    apply rational_eq_symm in H0. rational_rw H0.
    rational_rw rational_plus_comm. apply rational_eq_symm.
    rational_rw rational_plus_comm. apply -> rational_plus_wd.
    apply rational_plus_inv_mul.
  } specialize (H1 _ _ H2). apply -> H1. clear H1 H2.
  remember (b +/ --/ a) as x. remember (d +/ --/ c) as y.
  revert H H0; clear; intros.
  destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  try (inv H; inv H0; fail). unfold rational_plus. simpl_int; try (
    simpl in *; int_contra
  ). simpl. trivial.
Qed.

Lemma rational_abs_mul : forall x y,
  rational_abs (x */ y) =/ rational_abs x */ rational_abs y.
Proof.
  intros; destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
  unfold rational_abs; unfold rational_mul; unfold rational_eq;
  destruct_posz; simpl_int; trivial; try (simpl in *; int_contra);
  simpl_eq; nia.
Qed.

Lemma rational_lt_split : forall x y, x </ y \/ x =/ y \/ x >/ y.
Proof.
  intros; unfold rational_gt; unfold rational_lt.
  destruct (y +/ --/ x) as [[[a] | | [a]] b] eqn: EQ.
  + left. simpl; trivial.
  + right; left. apply rational_eq_symm. apply rational_eq_minus.
    rewrite EQ. simpl; trivial.
  + right; right. assert (x +/ --/ y =/ --/ (y +/ --/ x)). {
      clear. apply rational_eq_symm. rational_rw rational_plus_inv_mul.
      rational_rw rational_dist_front. apply rational_eq_symm.
      rational_rw rational_plus_comm. assert (H := rational_plus_inv_mul y).
      eapply rational_plus_wd in H; rational_rw H; clear H.
      rational_rw rational_plus_comm. apply rational_eq_symm.
      rational_rw rational_plus_comm. apply -> rational_plus_wd. clear.
      destruct x as [[[a] | | [a]] b]; unfold rational_plus_inv;
      unfold rational_mul; unfold rational_eq; simpl_int; trivial; try (
        simpl in *; int_contra
      ); simpl_eq; nia.
    } rewrite EQ in H; clear EQ. simpl in H.
    assert (
      forall x y, x =/ y ->
      rational_positive x <-> rational_positive y
    ). {
      clear; intros; split; intros;
      destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
      simpl in *; eauto; destruct_posz.
    } apply rational_eq_symm in H. apply -> H0; try eassumption.
    simpl; trivial.
Qed.

Lemma rational_archimedean : forall p, exists M,
  p </ Rational (PosZ (P M)) (P 0).
Proof.
  intros. destruct p as [[[a] | | [a]] b]; try (
    exists 0; unfold rational_lt; simpl; destruct_posz; simpl_int;
    try match goal with
    | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
    end; reflection; simpl; trivial; nia
  ). exists (S a). unfold rational_lt; simpl; destruct_posz; simpl_int;
  try match goal with
  | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
  end; reflection; simpl; trivial; try nia.
Qed.

Lemma rational_finite_maximum : forall f N,
  exists M, forall n, n <= N -> f n </ Rational (PosZ (P M)) (P 0).
Proof.
  intros. induction N.
  + destruct (rational_archimedean (f 0)) as [N H]. exists N; intros.
    eassert (n = 0) by nia; subst; eassumption.
  + destruct IHN as [M1 HM1].
    destruct (rational_archimedean (f (S N))) as [M2 HM2].
    destruct (Nat.leb M1 M2) eqn: EQ; reflection.
    - exists M2. intros. inv H; try assumption.
      specialize (HM1 _ H1). inv EQ; try assumption.
      eapply rational_lt_trans; try eassumption.
      unfold rational_lt; simpl.
      replace (Nat.leb (M1 * 1) (S (m * 1))) with true by (
        symmetry; apply leb_refl; nia
      ). simpl_int; trivial. nia.
    - exists M1. intros. inv H.
      * eapply rational_lt_trans; try eassumption. unfold rational_lt.
        simpl. replace (Nat.leb (M2 * 1) (M1 * 1)) with true by (
          symmetry; apply leb_refl; nia
        ). simpl_int; trivial. nia.
      * exact (HM1 _ H1).
Qed.

Lemma rational_abs_elim : forall x y,
  rational_abs x </ y <-> --/ y </ x /\ x </ y.
Proof.
  intros; split; intros; try split;
  try match goal with
  | H : _ /\ _ |- _ => destruct H
  end; destruct x as [[[a] | | [a]] [b]]; destruct y as [[[c] | | [c]] [d]];
  unfold rational_lt in *; unfold rational_plus in *;
  unfold rational_plus_inv in *; unfold rational_abs in *;
  simpl_int; try (simpl in *; trivial; int_contra); try match goal with
  | [ H : context [ if ?x then _ else _ ] |- _ ] => destruct x eqn: ?
  | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
  end; reflection; try (
    simpl in *; trivial; try match goal with
    | H : False |- _ => inv H
    end; int_contra
  ); try lia; try match goal with
  | [ H : context [ if ?x then _ else _ ] |- _ ] => destruct x eqn: ?
  | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
  end; reflection; try (simpl in *; trivial; int_contra); nia.
Qed.

Ltac rsymm := apply rational_eq_symm.

Lemma rational_diff_sum : forall x y z w,
  x +/ y +/ --/ (z +/ w) =/ x +/ --/ z +/ (y +/ --/ w).
Proof.
  intros. assert (H : forall x y z, x +/ y +/ z =/ x +/ (y +/ z)). {
    clear; intros. rsymm. apply rational_plus_assoc.
  } rational_rw H. rsymm. rational_rw H.
  rational_rw rational_plus_comm. rsymm. rational_rw rational_plus_comm.
  apply -> rational_plus_wd. rsymm. rational_rw rational_plus_assoc.
  assert (H0 := rational_plus_comm (--/ z) y).
  eapply (rational_plus_wd _ _ (--/ w)) in H0. rational_rw H0.
  clear H0. rational_rw H. rational_rw rational_plus_comm.
  rsymm. rational_rw rational_plus_comm. apply -> rational_plus_wd.
  rational_rw rational_plus_inv_mul. rational_rw rational_dist_front.
  clear H. assert (H := rational_plus_inv_mul z).
  eapply (rational_plus_wd _ _ (--/ w)) in H. rsymm. rational_rw H.
  rational_rw rational_plus_comm. rsymm. rational_rw rational_plus_comm.
  apply -> rational_plus_wd. rsymm. apply rational_plus_inv_mul.
Qed.

Lemma rational_pm_zero : forall x, x +/ --/ x =/ Rational Zero (P 0).
Proof.
  intros. destruct x as [[[a] | | [a]] [b]];
  unfold rational_plus; unfold rational_plus_inv; unfold rational_eq;
  simpl_int; try (simpl in *; trivial; int_contra); match goal with
  | [ |- context [ if ?x then _ else _ ] ] => destruct x eqn: ?
  end; reflection; try (simpl in *; trivial; int_contra);
  simpl_int; trivial; nia.
Qed.

Lemma rational_plus_zero : forall x, x +/ Rational Zero (P 0) =/ x.
Proof.
  intros. destruct x as [[[a] | | [a]] [b]];
  unfold rational_plus; unfold rational_plus_inv; unfold rational_eq;
  simpl_int; try (simpl in *; trivial; int_contra); simpl_eq; nia.
Qed.

Lemma rational_lt_plus_eq : forall x y z,
  x </ y -> x +/ z </ y +/ z.
Proof.
  intros; unfold rational_lt in *.
  assert (
    forall x y, x =/ y ->
    rational_positive x <-> rational_positive y
  ). {
    clear; intros; split; intros;
    destruct x as [[[a] | | [a]] b]; destruct y as [[[c] | | [c]] d];
    simpl in *; eauto; destruct_posz.
  } apply -> H0; try (rsymm; eapply rational_diff_sum).
  apply -> H0; try eassumption. rsymm; rational_rw rational_plus_zero.
  rational_rw rational_plus_comm; rsymm; rational_rw rational_plus_comm.
  apply -> rational_plus_wd; rsymm. apply rational_pm_zero.
Qed.

Lemma rational_lt_mul : forall x y z w,
  Rational Zero (P 0) </ x -> x </ y -> Rational Zero (P 0) </ z -> z </ w
  -> x */ z </ y */ w.
Proof.
  intros.
  assert (
    forall x, Rational Zero (P 0) </ x
    -> exists a b, x = Rational (PosZ a) b
  ). {
    clear; intros. destruct x as [[[a] | | [a]] [b]]; try (eexists; eauto).
    + inv H.
    + inv H.
  } destruct (H3 x H) as [[a] [[b] Heqx]];
  destruct (H3 z H1) as [[e] [[f] Heqz]].
  destruct (H3 y (rational_lt_trans _ _ _ H H0)) as [[c] [[d] Heqy]];
  destruct (H3 w (rational_lt_trans _ _ _ H1 H2)) as [[g] [[h] Heqw]].
  subst; revert H0 H2; clear; intros.
  unfold rational_mul; unfold rational_lt in *; unfold rational_plus in *;
  unfold rational_plus_inv in *; simpl_int;
  try (simpl in *; trivial; int_contra); repeat match goal with
  | [ H : context [ if ?x then _ else _ ] |- _ ] =>
    destruct x eqn: ?
  | [ |- context [if ?x then _ else _ ] ] => destruct x eqn: ?
  end; reflection; try (simpl in *; trivial; int_contra);
  remember (fun x y => x - y) as minus;
  repeat match goal with
  | H : minus ?x ?y = S _ |- _ =>
    eassert (x > y) by (revert H; subst minus; clear; intros; nia);
    replace (minus x y) with (S x - S y) in H by (subst; clear; eauto)
  end; repeat match goal with
  | [ H : context [ minus ?x ?y ] |- _ ] =>
    replace (minus x y) with (S x - S y) in H by (subst; clear; eauto)
  | [ H : context [ S (S (?x + ?y)) ] |- _ ] =>
    replace (S (S (x + y))) with (S x + S y) in H by (clear; nia)
  | [ H : context [ ?x <= ?y ] |- _ ] => eapply leb_refl in H;
    replace (Nat.leb x y) with (Nat.leb (S x) (S y)) in H by (clear; eauto)
  | [ H : context [ ?x > ?y ] |- _ ] => eapply leb_frefl in H;
    replace (Nat.leb x y) with (Nat.leb (S x) (S y)) in H by (clear; eauto)
  end; reflection; repeat match goal with
  | [ H : context [ S ?x ] |- _ ] => remember (S x); match goal with
    | H : _ = S x |- _ => clear H
    end
  end; subst; nia.
  (* why doesn't it work? *)
  Unshelve. all: exact (P 0).
Qed.

Lemma rational_lt_pos : forall x,
  Rational Zero (P 0) </ x <-> rational_positive x.
Proof.
  intros; split; intros.
  + destruct x as [[[a] | | [a]] [b]]; eauto.
  + destruct x as [[[a] | | [a]] [b]]; eauto.
Qed.

Lemma rational_lt_mul_nonneg : forall x y z w,
  Rational Zero (P 0) <=/ x -> x </ y -> Rational Zero (P 0) <=/ z -> z </ w
  -> x */ z </ y */ w.
Proof.
  intros. apply rational_le_lt in H; apply rational_le_lt in H1.
  destruct H; destruct H1; try (apply rational_lt_mul; assumption).
  + apply -> rational_lt_wd in H2; try (rsymm; eexact H1);
    try (eapply rational_eq_refl). assert (Hy := rational_lt_trans _ _ _ H H0).
    apply -> rational_lt_pos in H2; apply -> rational_lt_pos in Hy.
    assert (rational_positive (y */ w)). {
      destruct y as [[[a] | | [a]] [b]]; destruct w as [[[c] | | [c]] [d]];
      try (inv H2; inv Hy; fail). unfold rational_mul; simpl_int; eauto;
      simpl in *; int_contra.
    } apply rational_lt_pos in H3. eapply rational_lt_wd; try eexact H3;
    try eapply rational_eq_refl. eapply rational_mul_wd in H1.
    rational_rw rational_mul_comm; rsymm. rational_rw H1. clear.
    destruct x as [[[a] | | [a]] [b]]; unfold rational_mul;
    unfold rational_eq; simpl_int; trivial.
  + apply -> rational_lt_wd in H0; try (rsymm; eexact H);
    try (eapply rational_eq_refl).
    assert (Hw := rational_lt_trans _ _ _ H1 H2).
    apply -> rational_lt_pos in H0; apply -> rational_lt_pos in Hw.
    assert (rational_positive (y */ w)). {
      destruct y as [[[a] | | [a]] [b]]; destruct w as [[[c] | | [c]] [d]];
      try (inv H0; inv Hw; fail). unfold rational_mul; simpl_int; eauto;
      simpl in *; int_contra.
    } apply rational_lt_pos in H3. eapply rational_lt_wd; try eexact H3;
    try eapply rational_eq_refl. eapply rational_mul_wd in H; rsymm.
    rational_rw H. clear. destruct z as [[[a] | | [a]] [b]];
    unfold rational_mul; unfold rational_eq; simpl_int; trivial.
  + apply -> rational_lt_wd in H0; try (rsymm; eexact H);
    try (eapply rational_eq_refl). apply -> rational_lt_wd in H2;
    try (rsymm; eexact H1); try (eapply rational_eq_refl).
    apply -> rational_lt_pos in H0; apply -> rational_lt_pos in H2.
    assert (rational_positive (y */ w)). {
      destruct y as [[[a] | | [a]] [b]]; destruct w as [[[c] | | [c]] [d]];
      try (inv H0; inv H2; fail). unfold rational_mul; simpl_int; eauto;
      simpl in *; int_contra.
    } apply rational_lt_pos in H3. eapply rational_lt_wd; try eexact H3;
    try eapply rational_eq_refl. eapply rational_mul_wd in H; rsymm.
    rational_rw H. clear. destruct z as [[[a] | | [a]] [b]];
    unfold rational_mul; unfold rational_eq; simpl_int; trivial.
Qed.


Require Import Coq.Lists.List Coq.Arith.PeanoNat.
Require Import Crypto.Util.NatUtil.
Require Import Lia.
Require Import Circom.Util.
Require Import Circom.Default.
Require Import Circom.LibTactics.
Require Import Circom.Simplify.

Lemma nth_oblivious: forall {A: Type} l (i: nat) (d1 d2: A),
  i < length l ->
  List.nth i l d1 = List.nth i l d2.
Proof.
  induction l; intros; destruct i; cbn [nth length] in *; try lia; auto.
  simpl. erewrite IHl. reflexivity. lia.
Qed.

Lemma firstn_nth {A: Type}: forall l i j (d: A),
  (i < j)%nat ->
  nth i (firstn j l) d = nth i l d.
Proof.
  induction l; simpl; intros.
  - rewrite firstn_nil. destruct i; reflexivity.
  - destruct j. lia. destruct i.
    + rewrite firstn_cons. reflexivity.
    + simpl. rewrite IHl. auto. lia.
Qed.

Lemma fistn_prev {A: Type}: forall l i j (d: A),
  (i < j)%nat ->
  (j < length l)%nat ->
  nth i (firstn (S j) l) d = nth i (firstn j l) d.
Proof.
  induction l; intros.
  - simpl in *. lia.
  - simpl. destruct i. destruct j. lia. reflexivity.
    destruct j. lia.
    rewrite IHl. simpl. reflexivity.
    lia.
    simpl in H0. lia.
Qed.

Lemma firstn_1 {A: Type}: forall l (d: A),
  (length l > 0)%nat ->
  firstn 1 l = nth 0 l d :: nil.
Proof.
  destruct l; simpl; intros. lia. reflexivity.
Qed.

Lemma nth_skipn {A: Type}: forall l i j (d: A),
  (i+j < length l)%nat ->
  nth i (skipn j l) d = nth (i+j) l d.
Proof.
  induction l; simpl; intros.
  - destruct i; destruct j; lia.
  - destruct i; destruct j; simpl; repeat first [
        reflexivity
      | progress rewrite IHl by lia
      | progress rewrite Nat.add_0_r
      | progress rewrite Nat.add_succ_r
    ].
Qed.

Lemma firstn_S {A: Type}: forall i l (d: A),
  (i < length l)%nat ->
  firstn (S i) l = firstn i l ++ (nth i l d :: nil).
Proof.
  intros.
  replace (firstn (S i) l) with (firstn (S i) (firstn i l ++ skipn i l)).
  rewrite firstn_app. rewrite firstn_firstn.
  rewrite firstn_length_le by lia.
  replace (min (S i) i) with i by lia.
  replace (S i - i)%nat with 1%nat by lia.
  erewrite firstn_1.
  erewrite nth_skipn by lia.
  simpl. reflexivity.
  rewrite skipn_length. lia.
  rewrite firstn_skipn. reflexivity.
Qed.

Lemma skipn_nth_last: forall {A: Type} i xs (d: A),
  length xs = S i ->
  skipn i xs = nth i xs d :: nil.
Proof.
  intros.
  rewrite <- rev_involutive with (l:=xs).
  rewrite skipn_rev. rewrite rev_length. rewrite H. autorewrite with natsimplify.
  erewrite firstn_1.
  simpl.
  rewrite rev_involutive.
  rewrite rev_nth by lia.
  rewrite H. autorewrite  with natsimplify. reflexivity.
  rewrite rev_length. lia.
Qed.

Lemma firstn_split_last {A: Type}: forall (l: list A) n d,
  length l = S n ->
  firstn n l ++ nth n l d :: nil = l.
Proof.
  intros l m d Hlen.
  assert (l=l) by reflexivity.
  rewrite <- firstn_skipn with (n:=m) in H.
  erewrite skipn_nth_last in H by lia.
  rewrite <- H. reflexivity.
Qed.

Lemma skipn_skipn {A: Type}: forall (j i: nat) (l: list A),
  skipn i (skipn j l) = skipn (i+j)%nat l.
Proof.
  induction j; simpl; intros.
  autorewrite with natsimplify. reflexivity.
  destruct l. repeat rewrite skipn_nil. reflexivity.
  rewrite Nat.add_succ_r. simpl. rewrite IHj. reflexivity.
Qed.

Lemma Forall_firstn {A: Type}: forall (l: list A) i P,
  Forall P l -> Forall P (firstn i l).
Proof.
  induction l; intros.
  - rewrite firstn_nil. constructor.
  - invert H.
    destruct i. simpl. constructor.
    simpl. constructor; auto.
Qed.

Lemma Forall_firstn_S {A: Type}: forall (l: list A) i P d,
  S i = length l ->
  Forall P (firstn i l) ->
  P (nth i l d) ->
  Forall P l.
Proof.
  intros. erewrite <- firstn_split_last by eauto. apply Forall_app; eauto.
Qed.

Lemma Forall_skipn {A: Type}: forall (l: list A) i P,
  Forall P l -> Forall P (skipn i l).
Proof.
  induction l; intros.
  - rewrite skipn_nil. auto.
  - invert H.
    destruct i; simpl. auto.
    auto.
Qed.

Definition List_nth_Default {T} `{Default T} i xs := List.nth_default default xs i.

Global Notation "xs ! i " := (List_nth_Default i xs) (at level 20) : list_scope.
Global Notation "xs [: i ]" := (List.firstn i xs) (at level 20) : list_scope.
Global Notation "xs [ i :]" := (List.skipn i xs) (at level 20) : list_scope.

Lemma fold_nth {T} `{Default T}: forall (i:nat) d l,
  i < length l ->
  List.nth i l d = List_nth_Default i l.
Proof. intros. unfold List_nth_Default. rewrite nth_default_eq. erewrite nth_oblivious; eauto.  Qed.

Ltac unfold_default := unfold List_nth_Default; repeat rewrite nth_default_eq.
Ltac unfold_default' H := unfold List_nth_Default in H; repeat rewrite nth_default_eq in H.
Ltac fold_default := repeat (rewrite fold_nth; try lia).
Ltac fold_default' H := repeat (rewrite fold_nth in H; try lia).
Ltac simpl_default := unfold_default; simpl; fold_default; try lia.
Ltac default_apply L := unfold_default; L; fold_default; try lia.
Ltac default_apply' H L := unfold_default' H; L; fold_default' H; try lia.

Lemma Forall_rev_iff {A: Type}: forall P (l: list A),
  Forall P l <-> Forall P (rev l).
Proof.
  induction l;split;simpl;intros;auto;rewrite Forall_forall in *;intros.
  - apply H.
    apply in_app_or in H0. destruct H0.
    + right. apply in_rev;auto.
    + simpl in *. left. destruct H0; easy.
  - apply H. apply in_or_app. inversion H0;subst.
    + simpl;right;auto.
    + left. rewrite <- in_rev;auto.
Qed.

Lemma rev_nth' {A: Type}: forall i (l: list A) d,
  i < length l ->
  List.nth i l d = List.nth (length l - S i)%nat (rev l) d.
Proof.
  intros. remember (rev l) as l'.
  applys_eq rev_nth.
  f_equal. rewrite <- rev_involutive with (l:=l). rewrite <- Heql'. reflexivity.
  rewrite Heql'. rewrite rev_length. reflexivity.
  rewrite Heql'. rewrite rev_length. lia.
Qed.

Lemma app_congruence: forall {A: Type} (l1 l2 l1' l2': list A),
  l1 = l1' ->
  l2 = l2' ->
  l1 ++ l2 = l1' ++ l2'.
Proof.
  intros. rewrite H, H0. easy.
Qed.

Lemma app_congruence_iff_strong: forall {A: Set} (l1 l2 l1' l2': list A),
  length l1 = length l1' ->
  (l1 = l1' /\ l2 = l2') <->
  l1 ++ l2 = l1' ++ l2'.
Proof.
  split;intros.
  - apply app_congruence;easy.
  - pose proof (ListAux.map_length_decompose A A (fun x=>x) l1 l1' l2 l2' H).
    rewrite map_id in *. apply H1 in H0. destruct H0. rewrite map_id in *;auto.
Qed.

Lemma app_congruence_iff: forall {A: Set} (l1 l2 l1' l2': list A),
  length l1 = length l1' ->
  length l2 = length l2' ->
  (l1 = l1' /\ l2 = l2') <->
  l1 ++ l2 = l1' ++ l2'.
Proof.
  intros;apply app_congruence_iff_strong;auto.
Qed.

Lemma firstn_congruence {A}: forall i l l' (d: A),
  l[:i] = l'[:i] ->
  List.nth i l d = List.nth i l' d ->
  l[:S i] = l'[:S i].
Admitted.

Lemma list_tail_congruence {A}: forall i l l' (d: A),
  length l = S i ->
  length l' = S i ->
  l[:i] = l'[:i] ->
  List.nth i l d = List.nth i l' d ->
  l = l'.
Proof.
  intros.
  rewrite <- firstn_all with (l:=l).
  rewrite <- firstn_all with (l:=l').
  rewrite H, H0.
  eapply firstn_congruence; auto.
  rewrite H2. auto.
Qed.

Ltac firstn_all :=
  repeat match goal with
  | [ H: context[?l [:?k]],
      Hlen: length ?l = ?k |- _ ] =>
    rewrite firstn_all2 in H by lia
  | [ Hlen: length ?l = ?k |- context[?l [:?k]] ] =>
    rewrite firstn_all2  by lia
  end.

Lemma Forall_firstn_and_last {A}: forall l (d: A) (P: A -> Prop),
  length l > 0 ->
  Forall P (l[:length l-1]) ->
  P (List.nth (length l - 1)%nat l d) ->
  Forall P l.
Proof.
  intros.
  apply Forall_rev_iff.
  pose proof (rev_length l).
  erewrite <- firstn_split_last with (l:=l) (n:=(length l - 1)%nat).
  rewrite rev_unit.
  constructor. eauto.
  apply Forall_rev.
  auto.
  lia.
Qed.

Lemma forall_repeat {A}: forall (i:nat) P (x: A),
  i > 0 ->
  Forall P (List.repeat x i) <-> P x.
Proof.
  induction i; simpl; intros.
  lia.
  intuit.
  - inversion H0. auto.
  - constructor; auto. destruct i. simpl. auto.
    apply IHi. lia. auto.
Qed.

Lemma Forall_weaken: forall {A: Type} (P Q: A -> Prop) (l: list A),
  (forall x, P x -> Q x) -> Forall P l -> Forall Q l.
Proof.
  intros. apply Forall_forall. rewrite Forall_forall in H0.
  intros. auto.
Qed.

Ltac destruct_match :=
  match goal with
  | [ H: context[match ?x with _ => _ end] |- _ ] => destruct x
  | [ |- context[match ?x with _ => _ end] ] => destruct x
  end.

Lemma skipn_nth {A}: forall n (l: list A) i d,
  List.nth i (l[n:]) d = List.nth (n+i) l d.
Proof.
  induction n; intros; simpl; auto;
  repeat (destruct_match; simpl; auto).
Qed.

Ltac rewrite_length :=
  repeat match goal with
  | [ H: length ?xs = ?l |- context[length ?xs] ] =>
    rewrite H
  | [ H: length ?xs = ?l, H': context[length ?xs] |- _ ] =>
    rewrite H in H'
  | [ |- context[length (firstn _ _)]] => rewrite firstn_length_le; try lia
  | [ |- context[length (skipn _ _)]] => rewrite skipn_length; try lia
  | [ |- context[length (rev _)]] => rewrite rev_length
  end; simplify.

Require Import Circom.Tuple.

Local Open Scope tuple_scope.
Lemma nth_Default_List_tuple {T n} `{Default T} (xs: tuple T n) i:
  (to_list n xs) ! i = xs [i].
Proof.
  unfold List_nth_Default. unfold nth_Default, nth. rewrite nth_default_to_list. reflexivity.
Qed.

Ltac lift_to_list := repeat match goal with
| [H: context[nth_Default _ _] |- _] => rewrite <-nth_Default_List_tuple in H; try lia
| [ |- context[nth_Default _ _] ] => rewrite <-nth_Default_List_tuple; try lia
| [H: tforall _ _ |- _] => apply tforall_Forall in H
| [ |- tforall _ _] => apply tforall_Forall
end.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.ModalLogic.ProofTheory.ModalLogic.
Require Import Logic.ModalLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.

Section IntuitionisticDerivedRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {mL: ModalLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {KmAX: SystemK L Gamma}.

Lemma boxp_andp: forall x y, |-- boxp (x && y) <--> (boxp x && boxp y).
Proof.
  intros.
  apply solve_andp_intros.
  + rewrite <- (andp_elim1 x y) at 2.
    rewrite <- (andp_elim2 x y) at 3.
    rewrite andp_dup.
    apply provable_impp_refl.
  + rewrite <- impp_curry_uncurry.
    rewrite <- axiom_K.
    rewrite <- axiom_K.
    apply rule_N.
    apply andp_intros.
Qed.

Lemma orp_boxp: forall x y, |-- boxp x || boxp y --> boxp (x || y).
Proof.
  intros.
  apply solve_orp_impp.
  + rewrite <- axiom_K.
    apply rule_N.
    apply orp_intros1.
  + rewrite <- axiom_K.
    apply rule_N.
    apply orp_intros2.
Qed.

Lemma boxp_TT: |-- boxp TT.
Proof.
  apply rule_N.
  apply provable_impp_refl.
Qed.

Lemma not_diamondp_FF: |-- ~~ diamondp FF.
Proof.
  intros.
  unfold diamondp.
  rewrite <- double_negp_intros.
  apply rule_N.
  apply provable_impp_refl.
Qed.

Lemma impp_diamondp: forall x y, |-- boxp (x --> y) --> (diamondp x --> diamondp y).
Proof.
  intros.
  unfold diamondp.
  rewrite <- contrapositivePP.
  rewrite <- axiom_K.
  rewrite <- axiom_K.
  apply rule_N.
  apply contrapositivePP.
Qed.
(*
Lemma derivable_impp_diamondp: forall Phi x y, Phi |-- boxp (x --> y) --> (diamondp x --> diamondp y).
Proof.
  intros.
  apply deduction_weaken0.
  apply impp_diamondp.
Qed.

Lemma deduction_impp_diamondp: forall Phi x y,
  Phi |-- boxp (x --> y) ->
  Phi |-- (diamondp x --> diamondp y).
Proof.
  intros.
  eapply deduction_modus_ponens; eauto.
  apply derivable_impp_diamondp.
Qed.
*)
Lemma diamondp_andp: forall x y, |-- diamondp (x && y) --> (diamondp x && diamondp y).
Proof.
  intros.
  apply solve_impp_andp.
  + rewrite <- impp_diamondp.
    apply rule_N.
    apply andp_elim1.
  + rewrite <- impp_diamondp.
    apply rule_N.
    apply andp_elim2.
Qed.

Lemma orp_diamondp: forall x y, |-- diamondp x || diamondp y --> diamondp (x || y).
Proof.
  intros.
  apply solve_orp_impp.
  + rewrite <- impp_diamondp.
    apply rule_N.
    apply orp_intros1.
  + rewrite <- impp_diamondp.
    apply rule_N.
    apply orp_intros2.
Qed.

Lemma P_diamondp_P {TmGamma: SystemT L Gamma}: forall x, |-- x --> diamondp x.
Proof.
  intros.
  unfold diamondp.
  rewrite <- contrapositivePN.
  apply axiom_T.
Qed.

End IntuitionisticDerivedRules.


(** Author : Abhishek Anand ( http://www.cs.cornell.edu/~aa755/ )
*)

Require Export CoRN.ftc.FTC.

Definition Q2R  (q: Q) : IR := (inj_Q IR q).
Coercion  Q2R : Q >-> st_car.

Require Import Coq.setoid_ring.Ring.
Require Import CoRN.tactics.CornTac.
Require Import CoRN.algebra.CRing_as_Ring.

Add Ring IRisaRing: (CRing_Ring IR).

Require Export CoRN.ftc.Derivative.
Require Export CoRN.ftc.Integral.

Lemma ltAddRhs :
forall (a b : IR),
    [0][<]b -> a[<]a[+]b.
  intros ? ? Hlt.
  pose proof (leEq_reflexive _ a) as Hr.
  apply (plus_resp_less_leEq _ _ _ _ _ Hlt) in Hr.
  eapply less_wdl in Hr;[|apply cm_lft_unit_unfolded].
  eapply less_wdr;[| apply cag_commutes_unfolded].
  trivial.
Qed.

Lemma closeRationalR : forall (a b t d : IR) (Hab : a [<=] b),
  Compact Hab t
  -> t[<]b
  -> [0][<]d
  -> {q : Q | Compact Hab q /\
                      AbsIR (t[-]q)[<=]d}.
Proof.
  intros ? ? ? ? ? p Hcc Hdp.
  pose proof (less_Min _ _ _ (ltAddRhs t d Hdp) Hcc) as Hmlt.
  pose proof (Q_dense_in_CReals' _ _ _ Hmlt) as Hqr.
  destruct Hqr as [q Hqr Hql].
  exists q.
  simpl in p. unfold Q2R in p. destruct p as [pl pr].
  assert ( a[<=]inj_Q IR q) as Haq by (eauto using
        less_leEq, leEq_less_trans).
  assert (inj_Q IR q[<=] b) as Hqb by (eauto using
      less_leEq,
      less_leEq_trans,
      Min_leEq_rht).
  split;[exact (Haq,Hqb)|].
  rewrite AbsIR_minus. unfold Q2R.
  rewrite AbsIR_eq_x;[|eauto 4 using
        shift_zero_leEq_minus, less_leEq].
  apply shift_minus_leEq.
  rewrite cag_commutes_unfolded.
  eauto using
        less_leEq,leEq_less_trans,leEq_reflexive,
        less_leEq_trans,Min_leEq_lft.
Defined.

Lemma ltMinusRhs:
  forall (x y: IR),
    [0] [<]y -> x[-]y[<]x.
Proof.
  intros.
  apply shift_minus_less.
  apply ltAddRhs; auto.
Qed.

Lemma closeRationalL : forall (a b t d : IR) (Hab : a [<=] b),
  Compact Hab t
  -> a[<]t
  -> [0][<]d
  -> {q : Q | Compact Hab q /\
                      AbsIR (t[-]q)[<=]d}.
Proof.
  intros ? ? ? ? ? p Hcc Hdp.
  pose proof (Max_less _ _ _ (ltMinusRhs _ d Hdp) Hcc) as Hmlt.
  pose proof (Q_dense_in_CReals' _ _ _ Hmlt) as Hqr.
  destruct Hqr as [q Hqr Hql].
  exists q.
  simpl in p. unfold Q2R in p. destruct p as [pl pr].
  assert (inj_Q IR q[<=] b) as Hqb by (eauto using
        less_leEq, less_leEq_trans).
  assert (a[<=] inj_Q IR q) as Haq by (eauto using
      less_leEq,
      less_leEq_trans,
      leEq_less_trans,
      rht_leEq_Max).
  split;[exact (Haq,Hqb)|].
  rewrite AbsIR_eq_x;[|eauto 4 using
        shift_zero_leEq_minus, less_leEq].
  apply shift_minus_leEq.
  apply shift_leEq_plus'.
  unfold Q2R.
  pose proof (lft_leEq_Max (t[-]d) a).
  apply less_leEq.
  eapply leEq_less_trans; eauto.
Qed.

Require Export CoRN.ftc.StrongIVT.

Lemma closeRationalLR : forall (a b x d : IR) (Hab : a [<] b),
  (Compact (less_leEq _ _ _ Hab)) x
  -> [0][<]d
  -> {q : Q | (Compact (less_leEq _ _ _ Hab)) q /\
                      AbsIR (x[-]q)[<=]d}.
Proof.
  intros ? ? ? ? ? Hcc Hdp.
  pose proof Hab as Hap.
  apply less_cotransitive_unfolded with (z:=x)in Hap.
  destruct Hap as [Hlt | Hgt].
- apply closeRationalL; auto.
- apply closeRationalR; auto.
Qed.

(** this lemma is stronger than Weak_IVT. the only change
    is that the type of [x] (in the concluion)
    is Q, instead of IR *)
Lemma Weak_IVTQ
     : forall (I : interval) (F : PartFunct IR),
       Continuous I F ->
       forall (a b : IR) (Ha : Dom F a) (Hb : Dom F b)
         (HFab : F a Ha[<]F b Hb),
       I a ->
       I b ->
       forall e : IR,
       [0][<]e ->
       forall y : IR,
       Compact (less_leEq IR (F a Ha) (F b Hb) HFab) y ->
       {x : Q | Compact (Min_leEq_Max a b) x /\
       forall Hx : Dom F x, AbsIR (F x Hx[-]y)[<=]e}.
Proof.
  intros ? ? Hc ? ? ? ? ? Hia Hib ? He ? Hcp.
  apply pos_div_two in He.
  pose proof He as Hivt.
  eapply Weak_IVT with (y:=y) (F:=F) (HFab := HFab) in Hivt;
    eauto.
  unfold compact in He.
  unfold Continuous in Hc.
  destruct Hc as [Hcl Hcr].
  specialize (Hcr _ _  (Min_leEq_Max a b)).
  unfold Continuous_I in Hcr.
  match type of Hcr with
  ?A -> _ => assert A as H99 by (apply included_interval; auto);
            pose proof (included_trans _ _ _ _ H99 Hcl) as Hdom;
             specialize (Hcr H99); clear H99
  end.

  apply snd in Hcr.
  specialize (Hcr _ He).
  destruct Hcr as [d Hdp Hcc].
  destruct Hivt as [x Hmm Hfx].
  pose proof HFab as Hap.
  specialize (fun xp => Hcc x xp Hmm).
    (* y already names a point in the co-domain *)
  apply less_imp_ap in Hap.
  apply pfstrx in Hap.
  apply ap_imp_Min_less_Max in Hap.
  pose proof (closeRationalLR _ _ _ _ Hap Hmm Hdp) as Hqq.
  destruct Hqq as [q H99].
  exists q.
  destruct H99 as [Hcomp Hab].
  split;[exact Hcomp|].
  specialize (Hcc q Hcomp (Hdom _ Hmm) (Hdom _ Hcomp) Hab).
  specialize (Hfx (Hdom _ Hmm)).
  rewrite AbsIR_minus in Hcc.
  apply AbsIR_imp_AbsSmall in Hcc.
  apply AbsIR_imp_AbsSmall in Hfx.
  pose proof (AbsSmall_eps_div_two  _ _ _ _ Hcc Hfx) as Hsum.
  clear Hfx Hcc.
  unfold cg_minus in Hsum.
  ring_simplify in Hsum.
  intros Hx.
  apply AbsSmall_imp_AbsIR.
  rewrite pfwdef with (Hy := Hx) in Hsum; trivial.
  apply eq_reflexive.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import BinInt Ring_theory.
Local Open Scope Z_scope.

(** * Power functions over [Z] *)

(** Nota : this file is mostly deprecated. The definition of [Z.pow]
    and its usual properties are now provided by module [BinInt.Z]. *)

Notation Zpower_pos := Z.pow_pos (only parsing).
Notation Zpower := Z.pow (only parsing).
Notation Zpower_0_r := Z.pow_0_r (only parsing).
Notation Zpower_succ_r := Z.pow_succ_r (only parsing).
Notation Zpower_neg_r := Z.pow_neg_r (only parsing).
Notation Zpower_Ppow := Pos2Z.inj_pow (only parsing).

Lemma Zpower_theory : power_theory 1 Z.mul (@eq Z) Z.of_N Z.pow.
Proof.
 constructor. intros.
 destruct n;simpl;trivial.
 unfold Z.pow_pos.
 rewrite <- (Z.mul_1_r (pow_pos _ _ _)). generalize 1.
 induction p; simpl; intros; rewrite ?IHp, ?Z.mul_assoc; trivial.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.
Require Export depoolContract.Scenarios.Correctness.RoundCorrect.
Require Export depoolContract.Scenarios.Correctness.ParticipantCorrect.

Definition ledgerCorrectGlobally (l : Ledger) :=
    ledgerCorrectLocally l /\
    (forall r, roundIn l r -> roundCorrectGlobally l) /\
    (forall p, participantIn l p -> participantCorrectGlobally l).