(** 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.