(** * Structural Rules

This file proves some structural properties as exchange (for the
classical and linear context) as well as weakening and contraction in
the classical context. *)

Require Export LL.Misc.Utils.
Require Export LL.Misc.Permutations.
Require Export LL.SL.SELLF.PreTactics.
Require Import Coq.Program.Equality.

Export ListNotations.
Export LLNotations .
Set Implicit Arguments.

Section FLLBasicTheory.
  Context `{SI : SigSELL}.
  Context `{OLS: OLSig}.

  Section StructuralProperties.
    Variable theory : oo -> Prop. (* Theory Definition *)

    Notation " n '|-F-' B ';' L ';' X " := (seqN theory n B L X)  (at level 80).
    Hint Constructors seqN : core .
    Notation " '|-f-' B ';' L ';' X " := (seq theory B L X)  (at level 80).

    Hint Constructors seqN : core.
    Hint Constructors seq : core.

 Theorem WeakTheoryN : forall n CC LC X (th th':oo->Prop),
        (forall F, th F -> th' F) ->
        (seqN th n CC LC X -> seqN th' n CC LC X).
    Proof with sauto.
      induction n using lt_wf_ind.
     intros...
     inversion H1; subst.

     1-20: eauto using H.
     LLWith.
     1-2: eauto using H.
     LLTensor M N B C D .
     1-2: eauto using H.
     Qed.

  (**************** Exchange Rules ****************)

 Theorem exchangeLCN : forall n CC LC LC'  (X: Arrow),
        Permutation LC LC' ->
        (n |-F- CC ; LC ; X) -> n |-F- CC ; LC' ; X.
    Proof with sauto;solveLL.
      induction n using strongind;intros.
      + inversion H0 ...
      + inversion H1...
         1-12: eauto.
         LFocus F L'...
         1-3: eauto.
      Qed.

  Theorem exchangeLC LC : forall CC LC'  (X: Arrow),
        Permutation LC LC' ->
        ( |-f- CC ; LC ; X) -> |-f- CC ; LC' ; X.
    Proof with sauto;solveLL.
    intros.
    revert dependent LC'.
    induction H0;intros...
    * LLTensor M N B C D.
    * LLExists t.
    * LFocus F L'.
    * UFocus i F.
    * BFocus i F. sauto.
    * TFocus F.
  Qed.

 Lemma exchangeCCN : forall n CC CC' D (X:Arrow),
        Permutation CC CC' ->
        n |-F- CC ; D ; X ->
        n |-F- CC' ; D ; X.
  Proof with sauto.
  intro.
  induction n using strongind;intros.
  * inversion H0...
    - srewrite H in H1...
    - srewrite H in H2...
      solveLL.
    - srewrite H in H1...
  * inversion H1...
    2-14: eauto using Permutation_in.
    4-9: eauto using Permutation_in.
    srewrite H0 in H2...
    init2 i C.
    srewrite H0 in H2...
    solveLL.
    assert(Permutation (getLtX a CC) (getLtX a CC')).
    rewrite H0...
    rewrite <- H0...
    eapply H.
    3: exact H4.
    all:eauto.
    rewrite H0...
    BFocus i F B'...
   Qed.

 Lemma exchangeCC : forall CC CC' D (X:Arrow),
        Permutation CC CC' ->
        |-f- CC ; D ; X ->
        |-f- CC' ; D ; X.
  Proof with sauto.
  intros *.
  intros Hp Hseq.
  generalize dependent CC'.
  induction Hseq;intros...
  srewrite Hp in H...
  srewrite Hp in H0. solveLL.
  srewrite Hp in H...
  srewrite Hp in H...
  try rewrite Hp in *...
  LLTensor M N B C D.
  eauto using Permutation_in.
  eauto using Permutation_in.
  eapply tri_bang'...
  rewrite <- Hp...
  eapply IHHseq.
  rewrite Hp...
  eauto using Permutation_in.
  eauto using Permutation_in.
  eauto using Permutation_in.
  BFocus i F B'...
  eauto using Permutation_in.
 Qed.

  Global Instance seq_morphismN  n:
      Proper ((@Permutation TypedFormula) ==> (@Permutation oo) ==> eq ==> iff)
             (seqN theory n).
    Proof.
      unfold Proper; unfold respectful.
      intros.
      split; intro;subst.
      +  refine (exchangeCCN H _);auto.
         refine (exchangeLCN H0 _);auto.
      + apply Permutation_sym in H.
        apply Permutation_sym in H0.
        refine (exchangeCCN H _);auto.
        refine (exchangeLCN H0 _);auto.
    Qed.

   Global Instance seq_morphism  :
      Proper ((@Permutation TypedFormula) ==> (@Permutation oo) ==> eq ==> iff)
             (seq theory).
    Proof.
      unfold Proper; unfold respectful.
      intros.
      split; intro;subst.
      +  refine (exchangeCC H _);auto.
         refine (exchangeLC H0 _);auto.
      + apply Permutation_sym in H.
        apply Permutation_sym in H0.
        refine (exchangeCC H _);auto.
        refine (exchangeLC H0 _);auto.
    Qed.

  (**************** End Exchange Rules ****************)

  (** We can generalize the exponential phase in order to
     avoid mutual induction *)

  Ltac classic_or_linear sub :=
    destruct(uDec sub);simplSignature.

 Theorem BangUnb n i BD M P:
    u i = true -> n |-F- BD; M ; DW (Bang i P) -> SetU BD.
 Proof with sauto.
 intros.
 inversion H0...
 2: inversion H2.
 apply getUtoSetU'.
 symmetry.
 eapply bangUnb with (i:=i)... Qed.

 Theorem BangUnb' i BD M P:
    u i = true -> |-f- BD; M ; DW (Bang i P) -> SetU BD.
 Proof with sauto.
 intros.
 inversion H0... 2: inversion H2.
 apply getUtoSetU'.
 symmetry.
 eapply bangUnb with (i:=i)...
 Qed.

(* Soundness using inversion lemma of bang *)
Lemma seqNtoSeq : forall n B C X,
    seqN theory n B C X -> seq theory B C X.
     Proof with sauto.
      induction n using strongind;intros;eauto.
      + inversion H... eauto.
      + inversion H0...
        1- 17: eauto.
  Qed.

     Lemma HeightGeq : forall n B O (X:Arrow),
        seqN theory n B O X ->
        forall m, m>=n -> seqN theory m B O X.
    Proof with sauto;solveLL.
     intro.
      induction n;intros.
      + inversion H ...
      + inversion H;subst; try mgt0.
       1-4: eauto.
        1-5: intuition;eauto using Hp...
         (* LLTensor *)
         LLTensor M N B0 C D.
         eapply IHn;try lia ...
         eapply IHn;try lia ...
         1-2: intuition;eauto using Hp...
        LLExists t;eauto;eapply IHn;try lia...
       1-3:   intuition;eauto using Hp...
      (* dec *)
        LFocus F;eauto;eapply IHn;try lia...
        UFocus i F;eauto;eapply IHn;try lia...
        BFocus i F;eauto;eapply IHn;try lia...
        TFocus F;eauto;eapply IHn;try lia...
     Qed.

    (** HeightGeq with Exchange Classic Context *)
    Theorem HeightGeqCEx : forall n CC LC CC' X,
        Permutation CC' CC ->
        (seqN theory n  CC LC X) ->
        forall m, m>=n -> (seqN theory m  CC' LC X).
    Proof with eauto.
      intros.
      eapply HeightGeq with (n:=n);auto...
      symmetry in H.
      eapply exchangeCCN;eauto.
    Qed.

    (** HeightGeq with Exchange Linear Context *)
    Theorem HeightGeqLEx : forall n CC LC LC' X,
        Permutation LC LC' ->
        (seqN theory n  CC LC' X) ->
        forall m, m>=n -> (seqN theory m  CC LC X).
    Proof with eauto.
      intros.
      eapply HeightGeq with (n:=n);auto...
      symmetry in H.
      eapply exchangeLCN;eauto.
    Qed.

   Theorem HeightGeqEx : forall n CC CC' LC LC' X,
        Permutation CC CC' ->
        Permutation LC LC' ->
        (seqN theory n CC' LC' X) ->
        forall m, m>=n -> (seqN theory m CC LC X).
    Proof with eauto.
      intros.
      eapply HeightGeq with (n:=n);auto...
      symmetry in H.
      symmetry in H0.
      eapply exchangeLCN;eauto.
      eapply exchangeCCN;eauto.
    Qed.

  (**  Weakening using inversion lemma of bang *)
  Theorem weakeningN : forall n CC LC F X ,
      u (fst F) = true -> n |-F- CC ; LC ; X -> n |-F- F :: CC ; LC ; X.
   Proof with sauto;try solveLL.
    induction n using strongind;intros.
    * inversion H0...
       init2 i (F::C).
       rewrite <- H2...
    * inversion H1...
       init2 i (F::C).
       rewrite <- H3...
      LLTensor M N (F::B) C D...
      rewrite H4...
      rewrite <- app_comm_cons...
      rewrite <- app_comm_cons...
      eapply exchangeCCN with (CC:=F::(i,F0)::CC)...

      3-4: eauto using Permutation_in.
      4:{ BFocus i F0 (F::B')...
            rewrite <- H5... }
      destruct F.
      simpl in *...
      destruct F.
      simpl in *...
      destruct (lt_dec a s)...
     UFocus i F0.
      TFocus F0.
   Qed.

    Theorem weakeningGenN CC LC  CC' X n:
      n |-F- CC ; LC ; X -> SetU CC' -> n |-F- CC'++ CC ; LC ; X.
    Proof.
      intros.
      induction CC';simpl;intros;auto.
      destruct a.
      apply weakeningN ;sauto.
      solveSE.
      apply IHCC'. solveSE.
    Qed.

    Theorem weakeningGenN_rev CC LC CC' X n:
      n |-F- CC ; LC ; X -> SetU CC' -> n |-F- CC++ CC' ; LC ; X.
    Proof.
      intros.
      eapply exchangeCCN with (CC := CC' ++ CC);auto.
      apply Permutation_app_comm; auto.
      apply weakeningGenN;auto.
    Qed.

  Axiom seqtoSeqN : forall D O X,
        seq theory  D O X -> exists n, (seqN theory n D O X).

    (**  Weakening on the classical context *)
     Lemma weakening : forall CC LC F X ,
     u (fst F) = true -> |-f- CC ; LC ; X ->  |-f- F :: CC ; LC ; X.
    Proof with sauto;try solveLL.
    intros.
    revert dependent F.
    induction H0;intros...
    init2 i (F::C).
    rewrite <- H0...
    * LLTensor M N (F0::B) C D...
         rewrite H0...
     rewrite <- app_comm_cons...
     rewrite <- app_comm_cons...
    * rewrite perm_swap...
    * destruct F0.
       simpl in *...
    * destruct F0.
       simpl in *...
       destruct (lt_dec a s)...
    * LLExists t.
    * LFocus F...
    * UFocus i F.
    * BFocus i F (F0::B'). rewrite <- H1...
    * TFocus F.
   Qed.

    Theorem weakeningGen CC LC CC' X:
    SetU CC' -> |-f- CC ; LC ; X -> |-f- CC' ++ CC ; LC ; X.
    Proof with auto;try SLSolve.
      induction CC';simpl;intros;auto.
      apply weakening...
      solveSE.
      apply IHCC'...
      solveSE.
    Qed.

    Theorem weakeningAll CC LC X:
    SetU CC -> |-f- [] ; LC ; X -> |-f- CC ; LC ; X.
    Proof with auto.
      intros.
      rewrite <- (app_nil_r CC).
      apply weakeningGen...
    Qed.

    Theorem weakeningGen_rev CC LC CC' X :
      |-f- CC ; LC ; X -> SetU CC' -> |-f- CC++ CC' ; LC ; X.
    Proof.
      intros.
      eapply exchangeCC with (CC := CC' ++ CC);auto.
      apply Permutation_app_comm; auto.
      apply weakeningGen;auto.
    Qed.

    (**  Exchange Rule: Classical Context *)
    Theorem exchangeCC' CC CC' LC (X: Arrow):
      Permutation CC CC' ->
    |-f- CC ; LC ; X -> |-f- CC' ; LC ; X.
     Proof with sauto.
     intros.
     revert dependent CC'.
     induction H0;intros...
     * init1. rewrite <- H0...
     * init2 i C.
     * LLOne.
       rewrite <- H0...
     * LLTensor M N B C D.
     * LLBang. rewrite <- H1...
        eapply IHseq.
        rewrite H1...
     * LLExists t.
     * LFocus F...
     * UFocus i F.
       rewrite <- H3...
     * BFocus i F B'.
     * TFocus F.
    Qed.

     Theorem weakeningGenSubSet CC LC CC' X:
    (exists Y, (Permutation CC' (CC++Y)) /\ SetU Y) ->
    |-f- CC ; LC ; X -> |-f- CC' ; LC ; X.
    Proof.
      intros.
      do 2 destruct H.
      assert(Permutation (x ++ CC) CC').
      rewrite H. perm.
      eapply (exchangeCC H2).
      apply weakeningGen;auto.
    Qed.

        Theorem weakeningGenNSubSet n CC LC CC' X:
    (exists Y, (Permutation CC' (CC++Y)) /\ SetU Y) ->
   n  |-F- CC ; LC ; X -> n |-F- CC' ; LC ; X.
    Proof.
      intros.
      do 2 destruct H.
      assert(Permutation (x ++ CC) CC').
      rewrite H. perm.
      eapply (exchangeCCN H2).
      apply weakeningGenN;auto.
    Qed.

 Lemma lt_S n x :
  n >= S x -> n >= x.
 Proof.
    induction x;simpl;intros;
    [inversion H; lia | lia].
 Qed.
    (** Contraction on the classical context *)

  Lemma BangMax a n i B L P : lt a i ->
  n |-F- B ; L ; (DW (Bang i P)) ->
  n |-F- B ; L ; (DW (Bang a P)).
  Proof with CleanContext.
    intros.
    inversion H0...
    LLBang.
    pose proof (ltConv' _ _ _ H H6)...
    eapply weakeningGenNSubSet with (CC:=getLtX i B)...
    exists (getU x)...
  Qed.

     Lemma BangMax' a i B L P : lt a i ->
   |-f- B ; L ; (DW (Bang i P)) ->
   |-f- B ; L ; (DW (Bang a P)).
  Proof with CleanContext.
    intros.
    inversion H0...
    LLBang.
    pose proof (ltConv' _ _ _ H H5)...
    eapply weakeningGenSubSet with (CC:=getLtX i B)...
    exists (getU x)...
  Qed.

  End StructuralProperties.

  Definition EmptyTheory (F :oo) := False.
  Lemma EmptySubSetN : forall (theory : oo-> Prop) CC LC X n,
      seqN EmptyTheory n CC LC X -> seqN theory n CC LC X.
  Proof with sauto.
    intros.
    eapply @WeakTheoryN with (th:= EmptyTheory)...
    intros.
    inversion H0.
  Qed.

  (** Admissible rules including alternative definitions for the initial rule *)
  Section AdmissibleRules.
    Variable theory : oo -> Prop.

Lemma Init2In th i A L (USB: USigSELL): In (i, atom A) L -> seq th L [] (DW (perp A)).
Proof with sauto.
  intros.
  apply InPermutation in H...
  init2 i x.
Qed.

 Theorem InitPosNegN : forall Gamma A, SetU Gamma ->
        seqN theory 2 Gamma [atom A ; perp A ] (UP []).
      intros.
      solveLL.
    Qed.

    Theorem InitPosNegDwN : forall Gamma A, SetU Gamma ->
        seqN theory 4 Gamma [perp A ] (DW (atom A)).
      intros.
      solveLL.
    Qed.

    Theorem InitPosNeg : forall Gamma A,
    SetU Gamma -> seq theory Gamma [atom A ; perp A ] (UP []).
      intros.
      solveLL.
    Qed.

    Theorem InitPosNeg' : forall Gamma A,
     SetU Gamma -> seq theory Gamma [perp A ; atom A ] (UP []).
      intros.
      solveLL.
    Qed.

  End AdmissibleRules.

  (** Some simple invertibility lemmas *)
  Section Invertibility.
    Variable theory : oo -> Prop. (* Theory Definition *)

 Theorem FocusAtomN: forall n Gamma Delta A,
        (seqN theory n Gamma Delta (DW ((perp A ) ))) ->
     SetU Gamma /\ Delta = [ (atom A)] \/
     (exists i C, Delta = [] /\ SetU C /\ Permutation ((i,atom A )::C) Gamma).
    Proof with subst;auto.
      intros.
      inversion H ...
      2: inversion H1.
      right.
      exists i;exists C;firstorder.
    Qed.

  Theorem FocusAtom: forall Gamma Delta A,
        (seq theory Gamma Delta (DW ((perp A ) ))) ->
     SetU Gamma /\ Delta = [ (atom A)] \/
     (exists i C, Delta = [] /\ SetU C /\ Permutation ((i,atom A )::C) Gamma).
  Proof with subst;auto.
      intros.
       inversion H ...
      2: inversion H1.
      right.
      exists i;exists C;firstorder.
    Qed.

   Theorem InvUnb (SIU: USigSELL) C : SetL C -> C = [].
   Proof with sauto.
   intro H.
   apply Permutation_nil.
   rewrite (cxtDestruct C).
   assert(SetU C) by auto.
   rewrite (SetU_then_empty  _ H0).
   rewrite (SetL_then_empty _ H)...
  Qed.

   Theorem InvTensorNUnb (SIU: USigSELL) : forall n Gamma D F G,
   seqN theory n Gamma D (DW (MAnd F G)) ->
   exists M N, Permutation D (M++N) /\
   (seqN theory (n -1) Gamma M (DW F)) /\
   (seqN theory (n -1) Gamma N (DW G)).
  Proof with sauto.
  intros.
  inversion H...
  2: inversion H1.
  exists M.
  exists N.
  split;auto.
  apply InvUnb in H5, H6...
  1-2:rewrite H3...
  Qed.

    Theorem InvTensorNUnb' (SIU: USigSELL) : forall n Gamma D F G,
   seqN theory n Gamma D (DW (MAnd F  G)) ->
   exists M N m, Permutation D (M++N) /\ S m <= n /\
   (seqN theory m Gamma M (DW F)) /\
   (seqN theory m Gamma N (DW G)).
  Proof with sauto.
  intros.
  inversion H...
  2: inversion H1.
  exists M.
  exists N.
  exists n0.
  split;auto.
  split;auto.
  apply InvUnb in H5, H6...
  1-2:rewrite H3...

  Qed.

    Theorem FocusAtomTensorInvN: forall n  A F,
        (seqN theory n []  [atom A] (DW (MAnd (perp A) F))) ->
        (seqN theory (sub n  1 ) [] [] (DW (F))).
    Proof with sauto.
      intros.
      inversion H...
      * simpl in *.
        apply FocusAtomN in H10.
        destruct H10...
      * inversion H1.
    Qed.

    Theorem FocusAtomTensorTop: forall A B,
        (seq theory B [atom A] (DW (MAnd (perp A) Top))).
    Proof with sauto.
      intros.
      LLTensor [atom A] (@nil oo) (getU B) (getL B) (getL [])...
    Abort.

    Theorem FocusTopOplus1: forall F B D,
        seq theory B D (DW (AOr Top F)).
    Proof with sauto.
      intros.
      solveLL.
    Qed.

    Theorem FocusTopOplus2: forall F B D,
        seq theory B D (DW (AOr F Top )).
    Proof with sauto.
      intros.
      solveLL.
    Qed.

  End Invertibility.

  Section GeneralResults.
    Variable theory : oo -> Prop. (* Theory Definition *)
    Hint Constructors seqN : core .
    Hint Constructors seq : core .

  Lemma PProp_select B D CC F : Permutation (B++ getL D)
       (F :: CC) ->  u (fst F) = true ->
       (exists L1' : list (subexp * oo),
        Permutation B (F :: L1') /\
        Permutation (L1' ++ getL D) CC).
  Proof with sauto.
   intros.
   checkPermutationCases H.
   exists x.
   split;auto.
   apply getLPerm_SetL in H.
   assert(u (fst F) = false).
   inversion H...
   sauto.
   apply getLPerm_SetL in H.
   assert(u (fst F) = false).
   inversion H...
   sauto.
   Qed.

Lemma aux_c F BD B C D : SetU B -> SetL C -> SetL D -> u (fst F) = true -> Permutation (F :: BD) (B ++ C ++ D) -> In F B.
Proof with sauto.
  intros.
  checkPermutationCases H3.
  rewrite H3...
  checkPermutationCases H3.
  rewrite H3 in H0.
  inversion H0...
  rewrite H3 in H1.
  inversion H1...
 Qed.

  Theorem contractionN  : forall n CC LC F X,
       u (fst F) = true -> seqN theory n (F :: CC) LC X -> In F CC -> seqN theory n CC LC X.
  Proof with CleanContext;try solveLL.
  induction n using strongind;intros.
  * inversion H0...
     solveSE.
    checkPermutationCases H3.
    apply InPermutation in H1...
    rewrite H6 in H2.
    rewrite H1 in H2. solveSE.
    init2 i x. rewrite H5 in H2. solveSE. solveSE.
   * inversion H1;sauto;solveLL;solveSE.

    checkPermutationCases H4.
    apply InPermutation in H2.
    destruct H2.
    init2 i x. rewrite H7 in H3.
    rewrite H2 in H3.
    solveSE.
    solveLL. rewrite H6 in H3. solveSE.
    1-6: eauto.
    pose proof (aux_c H6 H7 H8 H0 H5).
 apply InPermutation in H3...
    assert(SetU x).
   rewrite H3 in H6.
   solveSE.
    apply InPermutation in H2...
    rewrite H3 in H5.
    rewrite H2 in H5.
    rewrite <- app_comm_cons in H5.
   apply Permutation_cons_inv in H5;auto.

    LLTensor M N x C D ...

    pose proof (aux_c H11 H7 H8 H0 H5).
   eapply H with (F:=F)...
    rewrite app_comm_cons.
    rewrite <- H3...

    pose proof (aux_c H11 H7 H8 H0 H5).
   eapply H with (F:=F)...
    rewrite app_comm_cons.
    rewrite <- H3...

    4-8:eauto.
    apply H with (F:=F)...
      eapply exchangeCCN with (CC:=(i,F0)::F::CC)...

apply InPermutation in H2.
    destruct H2.
    destruct F.
    simpl in H4.
    simpl in H0...
  destruct F.
    simpl in H0, H4, H5...
    destruct (lt_dec a s)...
    eapply H with (F:=(s, o))...
    apply InPermutation in H2...
    rewrite H2...
    simpl...
    destruct (lt_dec a s)...

inversion H6...
    UFocus i F0...
    eapply H with (F:=(i, F0))...
    UFocus i F0...
    eapply H with (F:=F)...
    checkPermutationCases H6.
    simpl in H0...
    rewrite H6 in  H2.
    inversion H2...
    BFocus i F0 x...
    eapply H with (F:=F)...
    rewrite <- H8...

    all:eauto.

   Qed.

 Theorem contraction  : forall CC LC F X,
     u (fst F) = true -> seq theory (F :: CC) LC X -> In F CC -> seq theory  CC LC X.
  Proof with subst;eauto.
  intros.
  apply seqtoSeqN in H0.
  destruct H0.
  apply contractionN in H0...
  apply seqNtoSeq in H0...
 Qed.

   Theorem contractionSet  : forall CC LC X L, (forall F, In F L -> In F CC) -> SetU L ->
        ( seq theory (L ++ CC) LC X) -> (seq theory CC LC  X).
   Proof.
      intros.
      induction L.
      simpl in H0;auto.
      apply IHL;intros.
      apply H. firstorder.
      solveSE.
      eapply exchangeCC with (CC':=a :: (L ++ CC)) in H1;[|auto].
      apply contraction in H1;auto.
      solveSE.
      apply in_or_app.
      firstorder.
  Qed.

     Theorem contractionSet'  : forall  C1 C2 CC LC X, Permutation CC (C1++C2) -> SetU C1 ->
        ( seq theory (C1 ++ CC) LC X) -> (seq theory CC LC  X).
   Proof with sauto.
      intro.
      induction C1;intros.
      simpl in H0;auto.
      inversion H0...
      rewrite <- app_comm_cons in H1.
      apply contraction in H1;auto.

      eapply IHC1 with (C2:=a::C2) in H1...
      rewrite H...
      apply in_or_app.
      right. rewrite H.
      apply in_or_app.
      left.
      firstorder.
  Qed.

    Theorem contractionGetU  : forall  C CC LC X,
        ( seq theory (getU C ++ getU C ++ CC) LC X) -> (seq theory (getU C ++ CC) LC  X).
   Proof with sauto.
      intros.
      eapply contractionSet'
      with (C1:=getU C) (C2:=CC)...
  Qed.

  Theorem contractionGetU_rev  : forall  C CC LC X,
        ( seq theory (CC ++ getU C ++ getU C) LC X) -> (seq theory (CC ++ getU C) LC  X).
   Proof with sauto.
      intros.
      eapply contractionSet'
      with (C1:=getU C) (C2:=CC)...
      eapply exchangeCC.
      2:{ exact H. }
      perm.
  Qed.

 Lemma Derivation1 D M F :
 seq theory D M (DW F) -> seq theory D M (UP [F]).
 Proof with sauto.
 intros.
 destruct(PositiveOrNegative F).
 LLStore...
 LFocus F.
 inversion H0;inversion H...
Qed.

  Lemma InvBangTN i j B P : u i = true ->
          seqN theory  j B [] (DW (Bang i P) ) -> seqN theory (j-1) B [] (UP [P]).
  Proof with sauto.
  intros Hu Hj.
  inversion Hj...
 2: inversion H0.
  apply bangUnb in H3...
  pose proof (cxtDestructLtX i B (getUtoSetU' _ (symmetry H3)))...
  rewrite H.
  eapply weakeningGenN_rev...
 Qed.

  Lemma InvBangT i j B P : u i = true ->
          seqN theory j B [] (DW (Bang i P)) -> seq theory B [] (UP [P]).
  Proof with sauto.
  intros Hu Hj.
  apply InvBangTN in Hj...
  apply seqNtoSeq in Hj...
 Qed.

End GeneralResults.

  (** Adequacy relating the system with and without inductive meassures *)

  (** Weakening in the linear context when the formula belongs to the theory *)
  Section MoreWeakening.
    Variable theory : oo -> Prop .

    Theorem WeakLinearTheoryN : forall n CC LC F X ,
        ~ IsPositiveAtom F ->
        (seqN theory n CC (F::LC) X) -> theory F ->
        seqN theory n CC LC X.
    Proof with sauto.
      induction n;intros;subst.
      + inversion H0...
        contradict H ...
      + inversion H0...
        - contradict H ...
        - LLPlusL.
          apply IHn with (F:=F)...
        - LLPlusR.
          apply IHn with (F:=F)...
        - LLWith.
          apply IHn with (F:=F)...
          apply IHn with (F:=F)...
        - LLBot.
          apply IHn with (F:=F)...
        - LLPar.
          apply IHn with (F:=F)...
        - checkPermutationCases H3.
          LLTensor x N B C D.
          apply IHn with (F:=F)...
          apply (exchangeLCN H3)...
          LLTensor M x B C D.
          apply IHn with (F:=F)...
          apply (exchangeLCN H3)...
        - LLStoreC.
          apply IHn with (F:=F)...
        - LLExists t.
          apply IHn with (F:=F)...
        - LLForall.
          apply IHn with (F:=F)...
        - LLRelease.
          apply IHn with (F:=F)...
        - LLStore.
          apply IHn with (F:=F)...
          eapply (exchangeLCN (perm_swap F F0 LC))...
        - checkPermutationCases H4.
          TFocus F.
          rewrite <- H7...
          LFocus F0 x.
          apply IHn with (F:=F)...
          rewrite <- H6...
        - UFocus i F0.
          apply IHn with (F:=F)...
        - BFocus i F0 B'.
          apply IHn with (F:=F)...
        - TFocus F0.
          apply IHn with (F:=F)...
 Qed.

  Theorem WeakLinearTheory : forall CC LC F X,
        ~ IsPositiveAtom F ->
        (seq theory CC (F::LC) X) -> theory F -> seq theory CC LC X.
      intros.
      apply seqtoSeqN in H0.
      destruct H0.
      apply WeakLinearTheoryN in H0;auto.
      apply seqNtoSeq in H0;auto.
  Qed.

 Lemma WeakTheory
     : forall (CC : list TypedFormula)
         (LC : list oo) (X : Arrow) (th th' : oo -> Prop),
       (forall F : oo, th F -> th' F) ->
       seq th CC LC X -> seq th' CC LC X.
  Proof with sauto.
  intros.
  apply seqtoSeqN in H0...
  eapply @WeakTheoryN with (th':=th') in H0...
  apply seqNtoSeq in H0...
 Qed.

  End MoreWeakening.
End FLLBasicTheory.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing [+] %\ensuremath+% #+# *)
(** printing {+} %\ensuremath+% #+# *)

Require Export CoRN.algebra.CSetoidInc.

(* Begin_SpecReals *)

(**
* Semigroups
** Definition of the notion of semigroup
*)

Definition is_CSemiGroup A (op : CSetoid_bin_op A) := associative op.

Record CSemiGroup : Type :=
  {csg_crr   :> CSetoid;
   csg_op    :  CSetoid_bin_op csg_crr;
   csg_proof :  is_CSemiGroup csg_crr csg_op}.

(**
%\begin{nameconvention}%
In the %{\em %names%}% of lemmas, we will denote [[+]] with [plus].
%\end{nameconvention}%
*)

Arguments csg_op {c}.
Infix "[+]" := csg_op (at level 50, left associativity).
(* End_SpecReals *)

(**
** Semigroup axioms
The axiomatic properties of a semi group.

%\begin{convention}% Let [G] be a semi-group.
%\end{convention}%
*)
Section CSemiGroup_axioms.
Variable G : CSemiGroup.

Lemma CSemiGroup_is_CSemiGroup : is_CSemiGroup G csg_op.
Proof.
 elim G; auto.
Qed.

Lemma plus_assoc : associative (csg_op (c:=G)).
Proof.
 exact CSemiGroup_is_CSemiGroup.
Qed.

End CSemiGroup_axioms.

(* Begin_SpecReals *)

(**
** Semigroup basics

%\begin{convention}%
Let [G] be a semi-group.
%\end{convention}%
*)
Section CSemiGroup_basics.
Variable G : CSemiGroup.

(* End_SpecReals *)

Lemma plus_assoc_unfolded : forall (G : CSemiGroup) (x y z : G), x[+] (y[+]z) [=] x[+]y[+]z.
Proof.
 exact plus_assoc.
Qed.

End CSemiGroup_basics.

Section p71R1.

(**
** Morphism
%\begin{convention}%
Let [S1 S2:CSemiGroup].
%\end{convention}%
*)

Variable S1:CSemiGroup.
Variable S2:CSemiGroup.

Definition morphism_of_CSemiGroups (f:(CSetoid_fun S1 S2)):CProp:=
forall (a b:S1), (f (a[+]b))[=] (f a)[+](f b).

End p71R1.

(**
** About the unit
*)

Definition is_rht_unit S (op : CSetoid_bin_op S) Zero : Prop := forall x, op x Zero [=] x.

(* End_SpecReals *)

Definition is_lft_unit S (op : CSetoid_bin_op S) Zero : Prop := forall x, op Zero x [=] x.

Arguments is_lft_unit [S].

(* Begin_SpecReals *)

Arguments is_rht_unit [S].

(** An alternative definition:
*)

Definition is_unit (S:CSemiGroup): S -> Prop :=
fun e => forall (a:S), e[+]a [=] a /\ a[+]e [=]a.

Lemma cs_unique_unit : forall (S:CSemiGroup) (e f:S),
(is_unit S e) /\ (is_unit S f) -> e[=]f.
Proof.
 intros S e f.
 unfold is_unit.
 intros H.
 elim H.
 clear H.
 intros H0 H1.
 elim (H0 f).
 clear H0.
 intros H2 H3.
 elim (H1 e).
 clear H1.
 intros H4 H5.
 astepr (e[+]f).
 astepl (e[+]f).
 apply eq_reflexive.
Qed.

(* End_SpecReals *)

#[global]
Hint Resolve plus_assoc_unfolded: algebra.

(**
** Functional operations
We can also define a similar addition operator, which will be denoted by [{+}], on partial functions.

%\begin{convention}% Whenever possible, we will denote the functional construction corresponding to an algebraic operation by the same symbol enclosed in curly braces.
%\end{convention}%

At this stage, we will always consider automorphisms; we %{\em %could%}% treat this in a more general setting, but we feel that it wouldn't really be a useful effort.

%\begin{convention}% Let [G:CSemiGroup] and [F,F':(PartFunct G)] and denote by [P] and [Q], respectively, the predicates characterizing their domains.
%\end{convention}%
*)

Section Part_Function_Plus.

Variable G : CSemiGroup.
Variables F F' : PartFunct G.

(* begin hide *)
Let P := Dom F.
Let Q := Dom F'.
(* end hide *)

Lemma part_function_plus_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y),
 F x (Prj1 Hx) [+]F' x (Prj2 Hx) [#] F y (Prj1 Hy) [+]F' y (Prj2 Hy) -> x [#] y.
Proof.
 intros x y Hx Hy H.
 case (cs_bin_op_strext  _ _ _ _ _ _  H); intros H1; exact (pfstrx _ _ _ _ _ _ H1).
Qed.

Definition Fplus := Build_PartFunct G _ (conj_wd (dom_wd _ F) (dom_wd _ F'))
  (fun x Hx => F x (Prj1 Hx) [+]F' x (Prj2 Hx)) part_function_plus_strext.

(**
%\begin{convention}% Let [R:G->CProp].
%\end{convention}%
*)

Variable R : G -> CProp.

Lemma included_FPlus : included R P -> included R Q -> included R (Dom Fplus).
Proof.
 intros; simpl in |- *; apply included_conj; assumption.
Qed.

Lemma included_FPlus' : included R (Dom Fplus) -> included R P.
Proof.
 intro H; simpl in H; eapply included_conj_lft; apply H.
Qed.

Lemma included_FPlus'' : included R (Dom Fplus) -> included R Q.
Proof.
 intro H; simpl in H; eapply included_conj_rht; apply H.
Qed.

End Part_Function_Plus.

Arguments Fplus [G].
Infix "{+}" := Fplus (at level 50, left associativity).

#[global]
Hint Resolve included_FPlus : included.

#[global]
Hint Immediate included_FPlus' included_FPlus'' : included.

(**
** Subsemigroups
%\begin{convention}%
Let [csg] a semi-group and [P] a non-empty
predicate on the semi-group which is preserved by [[+]].
%\end{convention}%
*)
Section SubCSemiGroups.
Variable csg : CSemiGroup.
Variable P : csg -> CProp.
Variable op_pres_P : bin_op_pres_pred _ P csg_op.

Let subcrr : CSetoid := Build_SubCSetoid _ P.

Definition Build_SubCSemiGroup : CSemiGroup := Build_CSemiGroup
  subcrr (Build_SubCSetoid_bin_op _ _ _ op_pres_P)
  (restr_f_assoc _ _ _ op_pres_P (plus_assoc csg)).
End SubCSemiGroups.

Section D9S.

(**
** Direct Product
%\begin{convention}%
Let [M1 M2:CSemiGroup]
%\end{convention}%
*)

Variable M1 M2: CSemiGroup.
Definition dprod (x:ProdCSetoid M1 M2)(y:ProdCSetoid M1 M2):
  (ProdCSetoid M1 M2):=
let (x1, x2):= x in
let (y1, y2):= y in
(pairT (x1[+]y1) (x2 [+] y2)).

Lemma dprod_strext:(bin_fun_strext (ProdCSetoid M1 M2)(ProdCSetoid M1 M2)
  (ProdCSetoid M1 M2)dprod).
Proof.
 unfold bin_fun_strext.
 intros x1 x2 y1 y2.
 unfold dprod.
 case x1.
 intros a1 a2.
 case x2.
 intros b1 b2.
 case y1.
 intros c1 c2.
 case y2.
 intros d1 d2.
 simpl.
 intro H.
 elim H.
  clear H.
  intro H.
  cut (a1[#]b1 or c1[#]d1).
   intuition.
  set (H0:= (@csg_op M1)).
  unfold CSetoid_bin_op in H0.
  set (H1:= (@csbf_strext M1 M1 M1 H0)).
  unfold bin_fun_strext in H1.
  apply H1.
  exact H.
 clear H.
 intro H.
 cut (a2[#]b2 or c2[#]d2).
  intuition.
 set (H0:= (@csg_op M2)).
 unfold CSetoid_bin_op in H0.
 set (H1:= (@csbf_strext M2 M2 M2 H0)).
 unfold bin_fun_strext in H1.
 apply H1.
 exact H.
Qed.

Definition dprod_as_csb_fun:
  CSetoid_bin_fun (ProdCSetoid M1 M2) (ProdCSetoid M1 M2)(ProdCSetoid M1 M2):=
  (Build_CSetoid_bin_fun (ProdCSetoid M1 M2)(ProdCSetoid M1 M2)
  (ProdCSetoid M1 M2) dprod dprod_strext).

Lemma direct_product_is_CSemiGroup:
  (is_CSemiGroup (ProdCSetoid M1 M2) dprod_as_csb_fun).
Proof.
 unfold is_CSemiGroup.
 unfold associative.
 intros x y z.
 case x.
 intros x1 x2.
 case y.
 intros y1 y2.
 case z.
 intros z1 z2.
 simpl.
 split.
  apply CSemiGroup_is_CSemiGroup.
 apply CSemiGroup_is_CSemiGroup.
Qed.

Definition direct_product_as_CSemiGroup:=
  (Build_CSemiGroup (ProdCSetoid M1 M2) dprod_as_csb_fun
  direct_product_is_CSemiGroup).

End D9S.

(**
** The SemiGroup of Setoid functions
*)

Lemma FS_is_CSemiGroup:
forall (X:CSetoid),(is_CSemiGroup (FS_as_CSetoid X X) (comp_as_bin_op  X )).
Proof.
 unfold is_CSemiGroup.
 exact assoc_comp.
Qed.

Definition FS_as_CSemiGroup (A : CSetoid) :=
  Build_CSemiGroup (FS_as_CSetoid A A) (comp_as_bin_op A) (assoc_comp A).

Section p66E2b4.

(**
** The Free SemiGroup
%\begin{convention}% Let [A:CSetoid].
%\end{convention}%
*)

Variable A:CSetoid.

Lemma Astar_is_CSemiGroup:
  (is_CSemiGroup (free_csetoid_as_csetoid A) (app_as_csb_fun A)).
Proof.
 unfold is_CSemiGroup.
 unfold associative.
 intros x.
 unfold app_as_csb_fun.
 simpl.
 induction x.
  simpl.
  intros x y.
  apply eq_fm_reflexive.
 simpl.
 intuition.
Qed.

Definition Astar_as_CSemiGroup:=
  (Build_CSemiGroup (free_csetoid_as_csetoid A) (app_as_csb_fun A)
   Astar_is_CSemiGroup).

End p66E2b4.


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files implements a type [natmap A] of finite maps whose keys range
over Coq's data type of unary natural numbers [nat]. The implementation equips
a list with a proof of canonicity. *)
From stdpp Require Import fin_maps mapset.
Set Default Proof Using "Type".

Notation natmap_raw A := (list (option A)).
Definition natmap_wf {A} (l : natmap_raw A) :=
  match last l with None => True | Some x => is_Some x end.
Instance natmap_wf_pi {A} (l : natmap_raw A) : ProofIrrel (natmap_wf l).
Proof. unfold natmap_wf. case_match; apply _. Qed.

Lemma natmap_wf_inv {A} (o : option A) (l : natmap_raw A) :
  natmap_wf (o :: l) → natmap_wf l.
Proof. by destruct l. Qed.
Lemma natmap_wf_lookup {A} (l : natmap_raw A) :
  natmap_wf l → l ≠ [] → ∃ i x, mjoin (l !! i) = Some x.
Proof.
  intros Hwf Hl. induction l as [|[x|] l IH]; simpl; [done| |].
  { exists 0. simpl. eauto. }
  destruct IH as (i&x&?); eauto using natmap_wf_inv; [|by exists (S i), x].
  intros ->. by destruct Hwf.
Qed.

Record natmap (A : Type) : Type := NatMap {
  natmap_car : natmap_raw A;
  natmap_prf : natmap_wf natmap_car
}.
Arguments NatMap {_} _ _ : assert.
Arguments natmap_car {_} _ : assert.
Arguments natmap_prf {_} _ : assert.
Lemma natmap_eq {A} (m1 m2 : natmap A) :
  m1 = m2 ↔ natmap_car m1 = natmap_car m2.
Proof.
  split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?].
  simplify_eq/=; f_equal; apply proof_irrel.
Qed.
Global Instance natmap_eq_dec `{EqDecision A} : EqDecision (natmap A) := λ m1 m2,
  match decide (natmap_car m1 = natmap_car m2) with
  | left H => left (proj2 (natmap_eq m1 m2) H)
  | right H => right (H ∘ proj1 (natmap_eq m1 m2))
  end.

Instance natmap_empty {A} : Empty (natmap A) := NatMap [] I.
Instance natmap_lookup {A} : Lookup nat A (natmap A) := λ i m,
  let (l,_) := m in mjoin (l !! i).

Fixpoint natmap_singleton_raw {A} (i : nat) (x : A) : natmap_raw A :=
  match i with 0 => [Some x]| S i => None :: natmap_singleton_raw i x end.
Lemma natmap_singleton_wf {A} (i : nat) (x : A) :
  natmap_wf (natmap_singleton_raw i x).
Proof. unfold natmap_wf. induction i as [|[]]; simplify_eq/=; eauto. Qed.
Lemma natmap_lookup_singleton_raw {A} (i : nat) (x : A) :
  mjoin (natmap_singleton_raw i x !! i) = Some x.
Proof. induction i; simpl; auto. Qed.
Lemma natmap_lookup_singleton_raw_ne {A} (i j : nat) (x : A) :
  i ≠ j → mjoin (natmap_singleton_raw i x !! j) = None.
Proof. revert j; induction i; intros [|?]; simpl; auto with congruence. Qed.
Hint Rewrite @natmap_lookup_singleton_raw : natmap.

Definition natmap_cons_canon {A} (o : option A) (l : natmap_raw A) :=
  match o, l with None, [] => [] | _, _ => o :: l end.
Lemma natmap_cons_canon_wf {A} (o : option A) (l : natmap_raw A) :
  natmap_wf l → natmap_wf (natmap_cons_canon o l).
Proof. unfold natmap_wf, last. destruct o, l; simpl; eauto. Qed.
Lemma natmap_cons_canon_O {A} (o : option A) (l : natmap_raw A) :
  mjoin (natmap_cons_canon o l !! 0) = o.
Proof. by destruct o, l. Qed.
Lemma natmap_cons_canon_S {A} (o : option A) (l : natmap_raw A) i :
  natmap_cons_canon o l !! S i = l !! i.
Proof. by destruct o, l. Qed.
Hint Rewrite @natmap_cons_canon_O @natmap_cons_canon_S : natmap.

Definition natmap_alter_raw {A} (f : option A → option A) :
    nat → natmap_raw A → natmap_raw A :=
  fix go i l {struct l} :=
  match l with
  | [] =>
     match f None with
     | Some x => natmap_singleton_raw i x | None => []
     end
  | o :: l =>
     match i with
     | 0 => natmap_cons_canon (f o) l | S i => natmap_cons_canon o (go i l)
     end
  end.
Lemma natmap_alter_wf {A} (f : option A → option A) i l :
  natmap_wf l → natmap_wf (natmap_alter_raw f i l).
Proof.
  revert i. induction l; [intro | intros [|?]]; simpl; repeat case_match;
    eauto using natmap_singleton_wf, natmap_cons_canon_wf, natmap_wf_inv.
Qed.
Instance natmap_alter {A} : PartialAlter nat A (natmap A) := λ f i m,
  let (l,Hl) := m in NatMap _ (natmap_alter_wf f i l Hl).
Lemma natmap_lookup_alter_raw {A} (f : option A → option A) i l :
  mjoin (natmap_alter_raw f i l !! i) = f (mjoin (l !! i)).
Proof.
  revert i. induction l; intros [|?]; simpl; repeat case_match; simpl;
    autorewrite with natmap; auto.
Qed.
Lemma natmap_lookup_alter_raw_ne {A} (f : option A → option A) i j l :
  i ≠ j → mjoin (natmap_alter_raw f i l !! j) = mjoin (l !! j).
Proof.
  revert i j. induction l; intros [|?] [|?] ?; simpl;
    repeat case_match; simpl; autorewrite with natmap; auto with congruence.
  rewrite natmap_lookup_singleton_raw_ne; congruence.
Qed.

Definition natmap_omap_raw {A B} (f : A → option B) :
    natmap_raw A → natmap_raw B :=
  fix go l :=
  match l with [] => [] | o :: l => natmap_cons_canon (o ≫= f) (go l) end.
Lemma natmap_omap_raw_wf {A B} (f : A → option B) l :
  natmap_wf l → natmap_wf (natmap_omap_raw f l).
Proof. induction l; simpl; eauto using natmap_cons_canon_wf, natmap_wf_inv. Qed.
Lemma natmap_lookup_omap_raw {A B} (f : A → option B) l i :
  mjoin (natmap_omap_raw f l !! i) = mjoin (l !! i) ≫= f.
Proof.
  revert i. induction l; intros [|?]; simpl; autorewrite with natmap; auto.
Qed.
Hint Rewrite @natmap_lookup_omap_raw : natmap.
Global Instance natmap_omap: OMap natmap := λ A B f m,
  let (l,Hl) := m in NatMap _ (natmap_omap_raw_wf f _ Hl).

Definition natmap_merge_raw {A B C} (f : option A → option B → option C) :
    natmap_raw A → natmap_raw B → natmap_raw C :=
  fix go l1 l2 :=
  match l1, l2 with
  | [], l2 => natmap_omap_raw (f None ∘ Some) l2
  | l1, [] => natmap_omap_raw (flip f None ∘ Some) l1
  | o1 :: l1, o2 :: l2 => natmap_cons_canon (f o1 o2) (go l1 l2)
  end.
Lemma natmap_merge_wf {A B C} (f : option A → option B → option C) l1 l2 :
  natmap_wf l1 → natmap_wf l2 → natmap_wf (natmap_merge_raw f l1 l2).
Proof.
  revert l2. induction l1; intros [|??]; simpl;
    eauto using natmap_omap_raw_wf, natmap_cons_canon_wf, natmap_wf_inv.
Qed.
Lemma natmap_lookup_merge_raw {A B C} (f : option A → option B → option C)
    l1 l2 i : f None None = None →
  mjoin (natmap_merge_raw f l1 l2 !! i) = f (mjoin (l1 !! i)) (mjoin (l2 !! i)).
Proof.
  intros. revert i l2. induction l1; intros [|?] [|??]; simpl;
    autorewrite with natmap; auto;
    match goal with |- context [?o ≫= _] => by destruct o end.
Qed.
Instance natmap_merge: Merge natmap := λ A B C f m1 m2,
  let (l1, Hl1) := m1 in let (l2, Hl2) := m2 in
  NatMap (natmap_merge_raw f l1 l2) (natmap_merge_wf _ _ _ Hl1 Hl2).

Fixpoint natmap_to_list_raw {A} (i : nat) (l : natmap_raw A) : list (nat * A) :=
  match l with
  | [] => []
  | None :: l => natmap_to_list_raw (S i) l
  | Some x :: l => (i,x) :: natmap_to_list_raw (S i) l
  end.
Lemma natmap_elem_of_to_list_raw_aux {A} j (l : natmap_raw A) i x :
  (i,x) ∈ natmap_to_list_raw j l ↔ ∃ i', i = i' + j ∧ mjoin (l !! i') = Some x.
Proof.
  split.
  - revert j. induction l as [|[y|] l IH]; intros j; simpl.
    + by rewrite elem_of_nil.
    + rewrite elem_of_cons. intros [?|?]; simplify_eq.
      * by exists 0.
      * destruct (IH (S j)) as (i'&?&?); auto.
        exists (S i'); simpl; auto with lia.
    + intros. destruct (IH (S j)) as (i'&?&?); auto.
      exists (S i'); simpl; auto with lia.
  - intros (i'&?&Hi'). subst. revert i' j Hi'.
    induction l as [|[y|] l IH]; intros i j ?; simpl.
    + done.
    + destruct i as [|i]; simplify_eq/=; [left|].
      right. rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
    + destruct i as [|i]; simplify_eq/=.
      rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
Qed.
Lemma natmap_elem_of_to_list_raw {A} (l : natmap_raw A) i x :
  (i,x) ∈ natmap_to_list_raw 0 l ↔ mjoin (l !! i) = Some x.
Proof.
  rewrite natmap_elem_of_to_list_raw_aux. setoid_rewrite Nat.add_0_r.
  naive_solver.
Qed.
Lemma natmap_to_list_raw_nodup {A} i (l : natmap_raw A) :
  NoDup (natmap_to_list_raw i l).
Proof.
  revert i. induction l as [|[?|] ? IH]; simpl; try constructor; auto.
  rewrite natmap_elem_of_to_list_raw_aux. intros (?&?&?). lia.
Qed.
Instance natmap_to_list {A} : FinMapToList nat A (natmap A) := λ m,
  let (l,_) := m in natmap_to_list_raw 0 l.

Definition natmap_map_raw {A B} (f : A → B) : natmap_raw A → natmap_raw B :=
  fmap (fmap f).
Lemma natmap_map_wf {A B} (f : A → B) l :
  natmap_wf l → natmap_wf (natmap_map_raw f l).
Proof.
  unfold natmap_map_raw, natmap_wf. rewrite fmap_last.
  destruct (last l). by apply fmap_is_Some. done.
Qed.
Lemma natmap_lookup_map_raw {A B} (f : A → B) i l :
  mjoin (natmap_map_raw f l !! i) = f <$> mjoin (l !! i).
Proof.
  unfold natmap_map_raw. rewrite list_lookup_fmap. by destruct (l !! i).
Qed.
Instance natmap_map: FMap natmap := λ A B f m,
  let (l,Hl) := m in NatMap (natmap_map_raw f l) (natmap_map_wf _ _ Hl).

Instance: FinMap nat natmap.
Proof.
  split.
  - unfold lookup, natmap_lookup. intros A [l1 Hl1] [l2 Hl2] E.
    apply natmap_eq. revert l2 Hl1 Hl2 E. simpl.
    induction l1 as [|[x|] l1 IH]; intros [|[y|] l2] Hl1 Hl2 E; simpl in *.
    + done.
    + by specialize (E 0).
    + destruct (natmap_wf_lookup (None :: l2)) as (i&?&?); auto with congruence.
    + by specialize (E 0).
    + f_equal. apply (E 0). apply IH; eauto using natmap_wf_inv.
      intros i. apply (E (S i)).
    + by specialize (E 0).
    + destruct (natmap_wf_lookup (None :: l1)) as (i&?&?); auto with congruence.
    + by specialize (E 0).
    + f_equal. apply IH; eauto using natmap_wf_inv. intros i. apply (E (S i)).
  - done.
  - intros ?? [??] ?. apply natmap_lookup_alter_raw.
  - intros ?? [??] ??. apply natmap_lookup_alter_raw_ne.
  - intros ??? [??] ?. apply natmap_lookup_map_raw.
  - intros ? [??]. by apply natmap_to_list_raw_nodup.
  - intros ? [??] ??. by apply natmap_elem_of_to_list_raw.
  - intros ??? [??] ?. by apply natmap_lookup_omap_raw.
  - intros ????? [??] [??] ?. by apply natmap_lookup_merge_raw.
Qed.

Fixpoint strip_Nones {A} (l : list (option A)) : list (option A) :=
  match l with None :: l => strip_Nones l | _ => l end.

Lemma list_to_natmap_wf {A} (l : list (option A)) :
  natmap_wf (reverse (strip_Nones (reverse l))).
Proof.
  unfold natmap_wf. rewrite last_reverse.
  induction (reverse l) as [|[]]; simpl; eauto.
Qed.
Definition list_to_natmap {A} (l : list (option A)) : natmap A :=
  NatMap (reverse (strip_Nones (reverse l))) (list_to_natmap_wf l).
Lemma list_to_natmap_spec {A} (l : list (option A)) i :
  list_to_natmap l !! i = mjoin (l !! i).
Proof.
  unfold lookup at 1, natmap_lookup, list_to_natmap; simpl.
  rewrite <-(reverse_involutive l) at 2. revert i.
  induction (reverse l) as [|[x|] l' IH]; intros i; simpl; auto.
  rewrite reverse_cons, IH. clear IH. revert i.
  induction (reverse l'); intros [|?]; simpl; auto.
Qed.

(** Finally, we can construct sets of [nat]s satisfying extensional equality. *)
Notation natset := (mapset natmap).
Instance natmap_dom {A} : Dom (natmap A) natset := mapset_dom.
Instance: FinMapDom nat natmap natset := mapset_dom_spec.

(* Fixpoint avoids this definition from being unfolded *)
Fixpoint of_bools (βs : list bool) : natset :=
  let f (β : bool) := if β then Some () else None in
  Mapset $ list_to_natmap $ f <$> βs.
Definition to_bools (sz : nat) (X : natset) : list bool :=
  let f (mu : option ()) := match mu with Some _ => true | None => false end in
  resize sz false $ f <$> natmap_car (mapset_car X).

Lemma of_bools_unfold βs :
  let f (β : bool) := if β then Some () else None in
  of_bools βs = Mapset $ list_to_natmap $ f <$> βs.
Proof. by destruct βs. Qed.
Lemma elem_of_of_bools βs i : i ∈ of_bools βs ↔ βs !! i = Some true.
Proof.
  rewrite of_bools_unfold; unfold elem_of, mapset_elem_of; simpl.
  rewrite list_to_natmap_spec, list_lookup_fmap.
  destruct (βs !! i) as [[]|]; compute; intuition congruence.
Qed.
Lemma of_bools_union βs1 βs2 :
  length βs1 = length βs2 →
  of_bools (βs1 ||* βs2) = of_bools βs1 ∪ of_bools βs2.
Proof.
  rewrite <-Forall2_same_length; intros Hβs.
  apply elem_of_equiv_L. intros i. rewrite elem_of_union, !elem_of_of_bools.
  revert i. induction Hβs as [|[] []]; intros [|?]; naive_solver.
Qed.
Lemma to_bools_length (X : natset) sz : length (to_bools sz X) = sz.
Proof. apply resize_length. Qed.
Lemma lookup_to_bools_ge sz X i : sz ≤ i → to_bools sz X !! i = None.
Proof. by apply lookup_resize_old. Qed.
Lemma lookup_to_bools sz X i β :
  i < sz → to_bools sz X !! i = Some β ↔ (i ∈ X ↔ β = true).
Proof.
  unfold to_bools, elem_of, mapset_elem_of, lookup at 2, natmap_lookup; simpl.
  intros. destruct (mapset_car X) as [l ?]; simpl.
  destruct (l !! i) as [mu|] eqn:Hmu; simpl.
  { rewrite lookup_resize, list_lookup_fmap, Hmu
      by (rewrite ?fmap_length; eauto using lookup_lt_Some).
    destruct mu as [[]|], β; simpl; intuition congruence. }
  rewrite lookup_resize_new by (rewrite ?fmap_length;
    eauto using lookup_ge_None_1); destruct β; intuition congruence.
Qed.
Lemma lookup_to_bools_true sz X i :
  i < sz → to_bools sz X !! i = Some true ↔ i ∈ X.
Proof. intros. rewrite lookup_to_bools by done. intuition. Qed.
Lemma lookup_to_bools_false sz X i :
  i < sz → to_bools sz X !! i = Some false ↔ i ∉ X.
Proof. intros. rewrite lookup_to_bools by done. naive_solver. Qed.
Lemma to_bools_union sz X1 X2 :
  to_bools sz (X1 ∪ X2) = to_bools sz X1 ||* to_bools sz X2.
Proof.
  apply list_eq; intros i; rewrite lookup_zip_with.
  destruct (decide (i < sz)); [|by rewrite !lookup_to_bools_ge by lia].
  apply option_eq; intros β.
  rewrite lookup_to_bools, elem_of_union by done; intros.
  destruct (decide (i ∈ X1)), (decide (i ∈ X2)); repeat first
    [ rewrite (λ X H, proj2 (lookup_to_bools_true sz X i H)) by done
    | rewrite (λ X H, proj2 (lookup_to_bools_false sz X i H)) by done];
    destruct β; naive_solver.
Qed.
Lemma to_of_bools βs sz : to_bools sz (of_bools βs) = resize sz false βs.
Proof.
  apply list_eq; intros i. destruct (decide (i < sz));
    [|by rewrite lookup_to_bools_ge, lookup_resize_old by lia].
  apply option_eq; intros β.
  rewrite lookup_to_bools, elem_of_of_bools by done.
  destruct (decide (i < length βs)).
  { rewrite lookup_resize by done.
    destruct (lookup_lt_is_Some_2 βs i) as [[]]; destruct β; naive_solver. }
  rewrite lookup_resize_new, lookup_ge_None_2 by lia. destruct β; naive_solver.
Qed.

(** A [natmap A] forms a stack with elements of type [A] and possible holes *)
Definition natmap_push {A} (o : option A) (m : natmap A) : natmap A :=
  let (l,Hl) := m in NatMap _ (natmap_cons_canon_wf o l Hl).

Definition natmap_pop_raw {A} (l : natmap_raw A) : natmap_raw A := tail l.
Lemma natmap_pop_wf {A} (l : natmap_raw A) :
  natmap_wf l → natmap_wf (natmap_pop_raw l).
Proof. destruct l; simpl; eauto using natmap_wf_inv. Qed.
Definition natmap_pop {A} (m : natmap A) : natmap A :=
  let (l,Hl) := m in NatMap _ (natmap_pop_wf _ Hl).

Lemma lookup_natmap_push_O {A} o (m : natmap A) : natmap_push o m !! 0 = o.
Proof. by destruct o, m as [[|??]]. Qed.
Lemma lookup_natmap_push_S {A} o (m : natmap A) i :
  natmap_push o m !! S i = m !! i.
Proof. by destruct o, m as [[|??]]. Qed.
Lemma lookup_natmap_pop {A} (m : natmap A) i : natmap_pop m !! i = m !! S i.
Proof. by destruct m as [[|??]]. Qed.
Lemma natmap_push_pop {A} (m : natmap A) :
  natmap_push (m !! 0) (natmap_pop m) = m.
Proof.
  apply map_eq. intros i. destruct i.
  - by rewrite lookup_natmap_push_O.
  - by rewrite lookup_natmap_push_S, lookup_natmap_pop.
Qed.
Lemma natmap_pop_push {A} o (m : natmap A) : natmap_pop (natmap_push o m) = m.
Proof. apply natmap_eq. by destruct o, m as [[|??]]. Qed.


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Arith.Arith.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz. (* for lia *)
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import tactics.

(* Theory of envs as lists of deBruijn levels *)

(* update entry *)
Fixpoint update {A} (σ : list A) (l : nat) (v : A) : list A :=
  match σ with
  | [] => σ
  | a :: σ' =>
      if (Nat.eqb l (length σ')) then (v :: σ') else (a :: (update σ' l v ))
  end.

Fixpoint insert {A} (σ : list A) (l : nat) (v : A) : list A :=
  match σ with
  | [] => σ
  | a :: σ' =>
      if (Nat.eqb l (length σ')) then (a :: v :: σ') else (a :: (insert σ' l v ))
  end.

(* Look up a free variable (deBruijn level) in env   *)
Fixpoint indexr {X : Type} (n : nat) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l' =>
      if (Nat.eqb n (length l')) then Some a else indexr n l'
  end.

Lemma indexr_head : forall {A} {x : A} {xs}, indexr (length xs) (x :: xs) = Some x.
  intros. simpl. destruct (Nat.eqb (length xs) (length xs)) eqn:Heq. auto.
  apply Nat.eqb_neq in Heq. contradiction.
Qed.

Lemma indexr_length : forall {A B} {xs : list A} {ys : list B}, length xs = length ys -> forall {x}, indexr x xs = None <-> indexr x ys = None.
Proof.
  intros A B xs.
  induction xs; intros; destruct ys; split; simpl in *; intros; eauto; try lia.
  - inversion H. destruct (PeanoNat.Nat.eqb x (length xs)). discriminate.
    specialize (IHxs _ H2 x). destruct IHxs. auto.
  - inversion H. rewrite <- H2 in H0. destruct (PeanoNat.Nat.eqb x (length xs)). discriminate.
    specialize (IHxs _ H2 x). destruct IHxs. auto.
Qed.

Lemma indexr_skip : forall {A} {x : A} {xs : list A} {i}, i <> length xs -> indexr i (x :: xs) = indexr i xs.
Proof.
  intros.
  rewrite <- PeanoNat.Nat.eqb_neq in H. auto.
  simpl. rewrite H. reflexivity.
Qed.

Lemma indexr_skips : forall {A} {xs' xs : list A} {i}, i < length xs -> indexr i (xs' ++ xs) = indexr i xs.
  induction xs'; intros; intuition.
  replace ((a :: xs') ++ xs) with (a :: (xs' ++ xs)).
  rewrite indexr_skip. eauto. rewrite app_length. lia. auto.
Qed.

Lemma indexr_var_some :  forall {A} {xs : list A} {i}, (exists x, indexr i xs = Some x) <-> i < length xs.
Proof.
  induction xs; intros; split; intros. inversion H. inversion H0.
  inversion H. inversion H. simpl in H0. destruct (PeanoNat.Nat.eqb i (length xs)) eqn:Heq.
  apply Nat.eqb_eq in Heq. rewrite Heq. auto. inversion H.
  simpl in H. rewrite Heq in H. apply IHxs in H. simpl. lia.
  simpl. destruct (PeanoNat.Nat.eqb i (length xs)) eqn:Heq.
  exists a. reflexivity. apply Nat.eqb_neq in Heq. simpl in H.
  apply IHxs. lia.
Qed.

(* easier to use for assumptions without existential quantifier *)
Lemma indexr_var_some' :  forall {A} {xs : list A} {i x}, indexr i xs = Some x -> i < length xs.
Proof.
  intros. apply indexr_var_some. exists x. auto.
Qed.

Lemma indexr_var_none :  forall {A} {xs : list A} {i}, indexr i xs = None <-> i >= length xs.
Proof.
  induction xs; intros; split; intros.
  simpl in *. lia. auto.
  simpl in H.
  destruct (PeanoNat.Nat.eqb i (length xs)) eqn:Heq.
  discriminate. apply IHxs in H. apply Nat.eqb_neq in Heq. simpl. lia.
  assert (Hleq: i >= length xs). {
    simpl in H. lia.
  }
  apply IHxs in Hleq. rewrite <- Hleq.
  apply indexr_skip. simpl in H. lia.
Qed.

Lemma indexr_insert_ge : forall {A} {xs xs' : list A} {x} {y}, x >= (length xs') -> indexr x (xs ++ xs') = indexr (S x) (xs ++ y :: xs').
  induction xs; intros.
  - repeat rewrite app_nil_l. pose (H' := H).
    rewrite <- indexr_var_none in H'.
    rewrite H'. symmetry. apply indexr_var_none. simpl. lia.
  - replace ((a :: xs) ++ xs') with (a :: (xs ++ xs')); auto.
    replace ((a :: xs) ++ y :: xs') with (a :: (xs ++ y :: xs')); auto.
    simpl. replace (length (xs ++ y :: xs')) with (S (length (xs ++ xs'))).
    destruct (Nat.eqb x (length (xs ++ xs'))) eqn:Heq; auto.
    repeat rewrite app_length. simpl. lia.
Qed.

Lemma indexr_insert_lt : forall {A} {xs xs' : list A} {x} {y}, x < (length xs') -> indexr x (xs ++ xs') = indexr x (xs ++ y :: xs').
  intros.
  rewrite indexr_skips; auto.
  erewrite indexr_skips.
  erewrite indexr_skip. auto.
  lia. simpl. lia.
Qed.

Lemma indexr_insert:  forall {A} {xs xs' : list A} {y}, indexr (length xs') (xs ++ y :: xs') = Some y.
  intros. induction xs.
  - replace ([] ++ y :: xs') with (y :: xs'); auto. apply indexr_head.
  - simpl. rewrite IHxs. rewrite app_length. simpl.
    destruct (PeanoNat.Nat.eqb (length xs') (length xs + S (length xs'))) eqn:Heq; auto.
    apply Nat.eqb_eq in Heq. lia.
Qed.

Lemma update_length : forall {A} {σ : list A} {l v}, length σ = length (update σ l v).
  induction σ; simpl; intuition.
  destruct (Nat.eqb l (length σ)) eqn:Heq; intuition.
  simpl. congruence.
Qed.

Lemma update_indexr_miss : forall {A} {σ : list A} {l v l'}, l <> l' ->  indexr l' (update σ l v) = indexr l' σ.
  induction σ; simpl; intuition.
  destruct (Nat.eqb l (length σ)) eqn:Hls; destruct (Nat.eqb l' (length σ)) eqn:Hl's.
  apply Nat.eqb_eq in Hls. apply Nat.eqb_eq in Hl's. rewrite <- Hl's in Hls. contradiction.
  simpl. rewrite Hl's. auto.
  simpl. rewrite <- update_length. rewrite Hl's. auto.
  simpl. rewrite <- update_length. rewrite Hl's. apply IHσ. auto.
Qed.

Lemma update_indexr_hit : forall {A} {σ : list A} {l v}, l < length σ -> indexr l (update σ l v) = Some v.
  induction σ; simpl; intuition.
  destruct (Nat.eqb l (length σ)) eqn:Hls.
  apply Nat.eqb_eq in Hls. rewrite Hls. apply indexr_head.
  simpl. rewrite <- update_length. rewrite Hls. apply Nat.eqb_neq in Hls.
  apply IHσ. lia.
Qed.

Lemma update_commute : forall {A} {σ : list A} {i j vi vj}, i <> j -> (update (update σ i vi) j vj) = (update (update σ j vj) i vi).
  induction σ; simpl; intuition.
  destruct (Nat.eqb i (length σ)) eqn:Heq.
  - assert (Heq' : Nat.eqb j (length σ) = false).
    apply Nat.eqb_eq in Heq. rewrite Nat.eqb_neq. lia.
    rewrite Heq'. simpl. rewrite Heq'. rewrite <- update_length.
    rewrite Heq. auto.
  - destruct (Nat.eqb j (length σ)) eqn:Heq'; simpl.
    all: repeat rewrite <- update_length.
    all: rewrite Heq. all: rewrite Heq'. auto.
    rewrite IHσ; auto.
Qed.

Lemma update_inv : forall {A} {l : list A} {i v}, i > length l -> update l i v = l.
Proof.
  induction l; intros; simpl; auto.
  bdestruct (i =? length l). simpl in H. lia.
  bdestruct (i <? length l). simpl in H. lia.
  assert (length l < i) by lia. f_equal. apply IHl. auto.
Qed.

Lemma indexr_skips' : forall {A} {xs xs' : list A} {i}, i >= length xs -> indexr i (xs' ++ xs) = indexr (i - length xs) xs'.
  induction xs; intros; intuition.
  - rewrite app_nil_r. simpl. rewrite Nat.sub_0_r. auto.
  - simpl in *. destruct i; try lia.
    rewrite <- indexr_insert_ge; try lia.
    rewrite IHxs. simpl. auto. lia.
Qed.

Fixpoint delete_nth (n : nat) {A} (l : list A) : list A :=
  match l with
  | nil       => nil
  | cons x xs => if (Nat.eqb n (length xs)) then xs else x :: (delete_nth n xs)
  end.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i 	     $Id: Ndist.v 14641 2011-11-06 11:59:10Z herbelin $	      i*)

Require Import Arith.
Require Import Min.
Require Import BinPos.
Require Import BinNat.
Require Import Ndigits.

(** An ultrametric distance over [N] numbers *)

Inductive natinf : Set :=
  | infty : natinf
  | ni : nat -> natinf.

Fixpoint Pplength (p:positive) : nat :=
  match p with
  | xH => 0
  | xI _ => 0
  | xO p' => S (Pplength p')
  end.

Definition Nplength (a:N) :=
  match a with
  | N0 => infty
  | Npos p => ni (Pplength p)
  end.

Lemma Nplength_infty : forall a:N, Nplength a = infty -> a = N0.
Proof.
  simple induction a; trivial.
  unfold Nplength in |- *; intros; discriminate H.
Qed.

Lemma Nplength_zeros :
 forall (a:N) (n:nat),
   Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false.
Proof.
  simple induction a; trivial.
  simple induction p. simple induction n. intros. inversion H1.
  simple induction k. simpl in H1. discriminate H1.
  intros. simpl in H1. discriminate H1.
  simple induction k. trivial.
  generalize H0. case n. intros. inversion H3.
  intros. simpl in |- *. unfold Nbit in H. apply (H n0). simpl in H1. inversion H1. reflexivity.
  exact (lt_S_n n1 n0 H3).
  simpl in |- *. intros n H. inversion H. intros. inversion H0.
Qed.

Lemma Nplength_one :
 forall (a:N) (n:nat), Nplength a = ni n -> Nbit a n = true.
Proof.
  simple induction a. intros. inversion H.
  simple induction p. intros. simpl in H0. inversion H0. reflexivity.
  intros. simpl in H0. inversion H0. simpl in |- *. unfold Nbit in H. apply H. reflexivity.
  intros. simpl in H. inversion H. reflexivity.
Qed.

Lemma Nplength_first_one :
 forall (a:N) (n:nat),
   (forall k:nat, k < n -> Nbit a k = false) ->
   Nbit a n = true -> Nplength a = ni n.
Proof.
  simple induction a. intros. simpl in H0. discriminate H0.
  simple induction p. intros. generalize H0. case n. intros. reflexivity.
  intros. absurd (Nbit (Npos (xI p0)) 0 = false). trivial with bool.
  auto with bool arith.
  intros. generalize H0 H1. case n. intros. simpl in H3. discriminate H3.
  intros. simpl in |- *. unfold Nplength in H.
  cut (ni (Pplength p0) = ni n0). intro. inversion H4. reflexivity.
  apply H. intros. change (Nbit (Npos (xO p0)) (S k) = false) in |- *. apply H2. apply lt_n_S. exact H4.
  exact H3.
  intro. case n. trivial.
  intros. simpl in H0. discriminate H0.
Qed.

Definition ni_min (d d':natinf) :=
  match d with
  | infty => d'
  | ni n => match d' with
            | infty => d
            | ni n' => ni (min n n')
            end
  end.

Lemma ni_min_idemp : forall d:natinf, ni_min d d = d.
Proof.
  simple induction d; trivial.
  unfold ni_min in |- *.
  simple induction n; trivial.
  intros.
  simpl in |- *.
  inversion H.
  rewrite H1.
  rewrite H1.
  reflexivity.
Qed.

Lemma ni_min_comm : forall d d':natinf, ni_min d d' = ni_min d' d.
Proof.
  simple induction d. simple induction d'; trivial.
  simple induction d'; trivial. elim n. simple induction n0; trivial.
  intros. elim n1; trivial. intros. unfold ni_min in H. cut (min n0 n2 = min n2 n0).
  intro. unfold ni_min in |- *. simpl in |- *. rewrite H1. reflexivity.
  cut (ni (min n0 n2) = ni (min n2 n0)). intros.
  inversion H1; trivial.
  exact (H n2).
Qed.

Lemma ni_min_assoc :
 forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d'').
Proof.
  simple induction d; trivial. simple induction d'; trivial.
  simple induction d''; trivial.
  unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
  intro. rewrite H. reflexivity.
  generalize n0 n1. elim n; trivial.
  simple induction n3; trivial. simple induction n5; trivial.
  intros. simpl in |- *. auto.
Qed.

Lemma ni_min_O_l : forall d:natinf, ni_min (ni 0) d = ni 0.
Proof.
  simple induction d; trivial.
Qed.

Lemma ni_min_O_r : forall d:natinf, ni_min d (ni 0) = ni 0.
Proof.
  intros. rewrite ni_min_comm. apply ni_min_O_l.
Qed.

Lemma ni_min_inf_l : forall d:natinf, ni_min infty d = d.
Proof.
  trivial.
Qed.

Lemma ni_min_inf_r : forall d:natinf, ni_min d infty = d.
Proof.
  simple induction d; trivial.
Qed.

Definition ni_le (d d':natinf) := ni_min d d' = d.

Lemma ni_le_refl : forall d:natinf, ni_le d d.
Proof.
  exact ni_min_idemp.
Qed.

Lemma ni_le_antisym : forall d d':natinf, ni_le d d' -> ni_le d' d -> d = d'.
Proof.
  unfold ni_le in |- *. intros d d'. rewrite ni_min_comm. intro H. rewrite H. trivial.
Qed.

Lemma ni_le_trans :
 forall d d' d'':natinf, ni_le d d' -> ni_le d' d'' -> ni_le d d''.
Proof.
  unfold ni_le in |- *. intros. rewrite <- H. rewrite ni_min_assoc. rewrite H0. reflexivity.
Qed.

Lemma ni_le_min_1 : forall d d':natinf, ni_le (ni_min d d') d.
Proof.
  unfold ni_le in |- *. intros. rewrite (ni_min_comm d d'). rewrite ni_min_assoc.
  rewrite ni_min_idemp. reflexivity.
Qed.

Lemma ni_le_min_2 : forall d d':natinf, ni_le (ni_min d d') d'.
Proof.
  unfold ni_le in |- *. intros. rewrite ni_min_assoc. rewrite ni_min_idemp. reflexivity.
Qed.

Lemma ni_min_case : forall d d':natinf, ni_min d d' = d \/ ni_min d d' = d'.
Proof.
  simple induction d. intro. right. exact (ni_min_inf_l d').
  simple induction d'. left. exact (ni_min_inf_r (ni n)).
  unfold ni_min in |- *. cut (forall n0:nat, min n n0 = n \/ min n n0 = n0).
  intros. case (H n0). intro. left. rewrite H0. reflexivity.
  intro. right. rewrite H0. reflexivity.
  elim n. intro. left. reflexivity.
  simple induction n1. right. reflexivity.
  intros. case (H n2). intro. left. simpl in |- *. rewrite H1. reflexivity.
  intro. right. simpl in |- *. rewrite H1. reflexivity.
Qed.

Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d.
Proof.
  unfold ni_le in |- *. intros. rewrite (ni_min_comm d' d). apply ni_min_case.
Qed.

Lemma ni_le_min_induc :
 forall d d' dm:natinf,
   ni_le dm d ->
   ni_le dm d' ->
   (forall d'':natinf, ni_le d'' d -> ni_le d'' d' -> ni_le d'' dm) ->
   ni_min d d' = dm.
Proof.
  intros. case (ni_min_case d d'). intro. rewrite H2.
  apply ni_le_antisym. apply H1. apply ni_le_refl.
  exact H2.
  exact H.
  intro. rewrite H2. apply ni_le_antisym. apply H1. unfold ni_le in |- *. rewrite ni_min_comm. exact H2.
  apply ni_le_refl.
  exact H0.
Qed.

Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n).
Proof.
  cut (forall m n:nat, m <= n -> min m n = m).
  intros. unfold ni_le, ni_min in |- *. rewrite (H m n H0). reflexivity.
  simple induction m. trivial.
  simple induction n0. intro. inversion H0.
  intros. simpl in |- *. rewrite (H n1 (le_S_n n n1 H1)). reflexivity.
Qed.

Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n.
Proof.
  unfold ni_le in |- *. unfold ni_min in |- *. intros. inversion H. apply le_min_r.
Qed.

Lemma Nplength_lb :
 forall (a:N) (n:nat),
   (forall k:nat, k < n -> Nbit a k = false) -> ni_le (ni n) (Nplength a).
Proof.
  simple induction a. intros. exact (ni_min_inf_r (ni n)).
  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt n (Pplength p)). trivial.
  intro. absurd (Nbit (Npos p) (Pplength p) = false).
  rewrite
   (Nplength_one (Npos p) (Pplength p)
      (refl_equal (Nplength (Npos p)))).
  discriminate.
  apply H. exact H0.
Qed.

Lemma Nplength_ub :
 forall (a:N) (n:nat), Nbit a n = true -> ni_le (Nplength a) (ni n).
Proof.
  simple induction a. intros. discriminate H.
  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt (Pplength p) n). trivial.
  intro. absurd (Nbit (Npos p) n = true).
  rewrite
   (Nplength_zeros (Npos p) (Pplength p)
      (refl_equal (Nplength (Npos p))) n H0).
  discriminate.
  exact H.
Qed.

(** We define an ultrametric distance between [N] numbers:
    $d(a,a')=1/2^pd(a,a')$,
    where $pd(a,a')$ is the number of identical bits at the beginning
    of $a$ and $a'$ (infinity if $a=a'$).
    Instead of working with $d$, we work with $pd$, namely
    [Npdist]: *)

Definition Npdist (a a':N) := Nplength (Nxor a a').

(** d is a distance, so $d(a,a')=0$ iff $a=a'$; this means that
    $pd(a,a')=infty$ iff $a=a'$: *)

Lemma Npdist_eq_1 : forall a:N, Npdist a a = infty.
Proof.
  intros. unfold Npdist in |- *. rewrite Nxor_nilpotent. reflexivity.
Qed.

Lemma Npdist_eq_2 : forall a a':N, Npdist a a' = infty -> a = a'.
Proof.
  intros. apply Nxor_eq. apply Nplength_infty. exact H.
Qed.

(** $d$ is a distance, so $d(a,a')=d(a',a)$: *)

Lemma Npdist_comm : forall a a':N, Npdist a a' = Npdist a' a.
Proof.
  unfold Npdist in |- *. intros. rewrite Nxor_comm. reflexivity.
Qed.

(** $d$ is an ultrametric distance, that is, not only $d(a,a')\leq
    d(a,a'')+d(a'',a')$,
  but in fact $d(a,a')\leq max(d(a,a''),d(a'',a'))$.
  This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [Npdist_ultra] below).
  This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{Nplength}}(a))$
  is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$,
  or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that
  min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq
  \texttt{Nplength} (a~\texttt{xor}~ b)$
  (lemma [Nplength_ultra]).
*)

Lemma Nplength_ultra_1 :
 forall a a':N,
   ni_le (Nplength a) (Nplength a') ->
   ni_le (Nplength a) (Nplength (Nxor a a')).
Proof.
  simple induction a. intros. unfold ni_le in H. unfold Nplength at 1 3 in H.
  rewrite (ni_min_inf_l (Nplength a')) in H.
  rewrite (Nplength_infty a' H). simpl in |- *. apply ni_le_refl.
  intros. unfold Nplength at 1 in |- *. apply Nplength_lb. intros.
  cut (forall a'':N, Nxor (Npos p) a' = a'' -> Nbit a'' k = false).
  intros. apply H1. reflexivity.
  intro a''. case a''. intro. reflexivity.
  intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). unfold xorf in |- *.
  rewrite
   (Nplength_zeros (Npos p) (Pplength p)
      (refl_equal (Nplength (Npos p))) k H0).
  generalize H. case a'. trivial.
  intros. cut (Nbit (Npos p1) k = false). intros. rewrite H3. reflexivity.
  apply Nplength_zeros with (n := Pplength p1). reflexivity.
  apply (lt_le_trans k (Pplength p) (Pplength p1)). exact H0.
  apply ni_le_le. exact H2.
Qed.

Lemma Nplength_ultra :
 forall a a':N,
   ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (Nxor a a')).
Proof.
  intros. case (ni_le_total (Nplength a) (Nplength a')). intro.
  cut (ni_min (Nplength a) (Nplength a') = Nplength a).
  intro. rewrite H0. apply Nplength_ultra_1. exact H.
  exact H.
  intro. cut (ni_min (Nplength a) (Nplength a') = Nplength a').
  intro. rewrite H0. rewrite Nxor_comm. apply Nplength_ultra_1. exact H.
  rewrite ni_min_comm. exact H.
Qed.

Lemma Npdist_ultra :
 forall a a' a'':N,
   ni_le (ni_min (Npdist a a'') (Npdist a'' a')) (Npdist a a').
Proof.
  intros. unfold Npdist in |- *. cut (Nxor (Nxor a a'') (Nxor a'' a') = Nxor a a').
  intro. rewrite <- H. apply Nplength_ultra.
  rewrite Nxor_assoc. rewrite <- (Nxor_assoc a'' a'' a'). rewrite Nxor_nilpotent.
  rewrite Nxor_neutral_left. reflexivity.
Qed.


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

  purpose   : auxiliary library for bool.
  author    : ZhengPu Shi
  date      : 2022.04
*)

Require Export Bool.
Require Export Setoid.    (* andb_true_iff need it. *)

(* ######################################################################### *)
(** * More properties for bool *)

(** andb split *)

Ltac tac_andb_true_iff :=
  intros; split; intro H;[
  repeat rewrite andb_true_iff in *;
  repeat match goal with | H : _ /\ _ |- _ => destruct H; auto 10 end|
  repeat rewrite andb_true_iff;
  repeat match goal with | H : _ /\ _ |- _ => destruct H; auto 10 end].

Lemma andb_true_iff3 : forall b1 b2 b3 : bool,
  b1 && b2 && b3 = true <->
  b1 = true /\ b2 = true /\ b3 = true.
Proof.
  tac_andb_true_iff.
Qed.

Lemma andb_true_iff4 : forall b1 b2 b3 b4 : bool,
  b1 && b2 && b3 && b4 = true <->
  b1 = true /\ b2 = true /\ b3 = true /\ b4 = true.
Proof.
  tac_andb_true_iff.
Qed.

Lemma andb_true_iff5 : forall b1 b2 b3 b4 b5 : bool,
  b1 && b2 && b3 && b4 && b5 = true <->
  b1 = true /\ b2 = true /\ b3 = true /\ b4 = true /\ b5 = true.
Proof.
  tac_andb_true_iff.
Qed.

Lemma andb_true_iff6 : forall b1 b2 b3 b4 b5 b6 : bool,
  b1 && b2 && b3 && b4 && b5 && b6 = true <->
  b1 = true /\ b2 = true /\ b3 = true /\ b4 = true /\ b5 = true /\
  b6 = true.
Proof.
  tac_andb_true_iff.
Qed.

Lemma andb_true_iff7 : forall b1 b2 b3 b4 b5 b6 b7 : bool,
  b1 && b2 && b3 && b4 && b5 && b6 && b7 = true <->
  b1 = true /\ b2 = true /\ b3 = true /\ b4 = true /\ b5 = true /\
  b6 = true /\ b7 = true.
Proof.
  tac_andb_true_iff.
Qed.

(** andb equal inversion *)

Lemma andb_eq_inv : forall a1 a2 b1 b2 : bool,
  a1 = b1 -> a2 = b2 -> a1 && a2 = b1 && b2.
Proof.
  destruct a1,a2,b1,b2; intros; auto.
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Arith.PeanoNat. Import Nat.
Import ListNotations.
From NS Require Import FrameworkAS.

(*-------------------------------Hoare_Logic---------------------------------*)
(* Example from the book *)
Theorem Example6_8a :
  {{ B[[BTrue]] }} WHILE BTrue DO SKIP {{ B[[BTrue]] }}.
Proof.
  intros P Q.
  apply consp with
    (P':= B[[BTrue]]) (Q' := ~B[[BTrue]] /\p B[[BTrue]]).
  apply whilep.
  - apply hoare_post_true.
    intros st.
    unfold bassn.
    simpl.
    reflexivity.
  - (* Precondition implies invariant *)
    intros st H.
    constructor.
  - (* Loop invariant and negated guard imply postcondition *)
    simpl.
    unfold assert_implies.
    unfold and_sub.
    intros st [H0 H1].
    apply H1.
Qed.

Theorem Example6_8b :
  {{ B[[BTrue]] }} WHILE BTrue DO SKIP {{ ~B[[BTrue]] }}.
Proof.
  intros P Q.
  apply consp with
    (P':= B[[BTrue]]) (Q' := ~B[[BTrue]] /\p B[[BTrue]]).
  apply whilep.
  - apply hoare_post_true.
    intros st.
    unfold bassn.
    simpl.
    reflexivity.
  - (* Precondition implies invariant *)
    intros st H.
    constructor.
  - (* Loop invariant and negated guard imply postcondition *)
    simpl.
    unfold assert_implies.
    unfold and_sub.
    intros st [H0 H1].
    apply H0.
Qed.

(* Definition of factorial *)
Fixpoint real_fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => n * (real_fact n')
  end.

(* Proof of the factorial program *)
Theorem Example6_9:
  forall (m:nat),
  {{ fun st => st x = m }}
  y ::= 1; WHILE ~(x = 1)
  DO (y ::= y * x; x ::= x - 1)
  {{ fun st => st y = (real_fact m) /\ m > 0}}.
Proof.
  intros m.
  apply consp_pre with (fun (st : State) => (st x > 0 ->
        real_fact (st x) = real_fact m /\ m >= st x)).
  apply compp with (fun (st : State) => (st x > 0 ->
        st y * real_fact (st x) = real_fact m /\ m >= st x)).
  eapply consp_post.
  apply whilep.
  apply consp_pre with (fun (st : State) => st x - 1 > 0 ->
        st y * st x * real_fact (st x - 1) =
        real_fact m /\ m >= (st x - 1)).
  apply compp with (fun (st : State) => st x - 1 > 0 ->
        st y * real_fact (st x - 1) =
        real_fact m /\ m >= (st x - 1)).
  eapply consp_pre.
  apply assp.
  - intros st P Q.
    unfold bassn, assn_sub, assert_implies, t_update. simpl.
    unfold bassn, assn_sub, assert_implies, t_update in Q.
    simpl in Q.
    apply P in Q.
    apply Q.
  - eapply consp_pre.
    apply assp.
    intros st P Q.
    unfold bassn, assn_sub, assert_implies, t_update. simpl.
    unfold bassn, assn_sub, assert_implies, t_update in Q.
    simpl in Q.
    apply P in Q.
    apply Q.
  - unfold and_sub.
    intros st P Q.
    destruct P.
    unfold bassn in H.
    simpl in H.
    apply negb_true_iff in H.
    apply beq_nat_false in H.
    assert (forall n, n <> 0 -> n * real_fact (n - 1) =
        real_fact n).
    + intros. destruct n.
      * destruct H1. reflexivity.
      * simpl. rewrite <- minus_n_O. reflexivity.
    + rewrite <- mult_assoc. rewrite H1. omega. omega.
  - unfold and_sub.
    intros st P. destruct P.
    unfold bassn2 in H.
    apply not_true_iff_false in H.
    simpl in H.
    apply negb_false_iff in H.
    apply beq_nat_true in H.
    assert (st x > 0).
      { omega. }
    apply H0 in H1.
    assert (real_fact (st x) = 1).
      { rewrite H. reflexivity. }
    rewrite H2 in H1. omega.
  - eapply consp_pre.
    apply assp.
    intros st P Q.
    unfold bassn, assn_sub, assert_implies, t_update. simpl.
    unfold bassn, assn_sub, assert_implies, t_update in Q.
    simpl in Q.
    apply P in Q.
    rewrite <- plus_n_O.
    apply Q.
  - intros st P H.
    rewrite P.
    omega.
Qed.

(*----------------------------Annotated_Programs-----------------------------*)
(* We can also prove the examples above in their annotated program form *)
Import Annotated.
Example annotatedprogram : Annotated := (
  {{ B[[BTrue]] }}
  WHILE BTrue
  DO
    {{B[[BTrue]] /\p B[[BTrue]]}} =>>
    {{B[[BTrue]]}}
    SKIP
    {{ B[[BTrue]] }}
  {{ ~B[[BTrue]] /\p B[[BTrue]]}} =>>
  {{ B[[BFalse]] }}
)
.

Theorem annotatedprogram_correct :
  ann_correct (annotatedprogram).
Proof.
  verify.
  unfold and_sub in H.
  destruct H.
  unfold not in H.
  destruct H.
  reflexivity.
Qed.

Example my_fact (m:nat) : Annotated := (
    {{ fun st => st x = m }} =>>
    {{ fun st => st x > 0 -> real_fact (st x) =
        real_fact m /\ m >= st x }}
  y ::= ANum 1
    {{ fun st => st x > 0 -> st y * real_fact (st x) =
        real_fact m /\ m >= st x }};
  WHILE BNot (BEq (AId x) (ANum 1))
  DO   {{ fun st => (st x > 0 ->
        st y * real_fact (st x) = real_fact m /\ m >= st x)
        /\ st x <> 1 }} =>>
       {{ fun st => st x - 1 > 0 ->
        st y * st x * real_fact (st x - 1) =
        real_fact m /\ m >= (st x - 1) }}
     y ::= AMult (AId y) (AId x)
       {{ fun st => st x - 1 > 0 ->
        st y * real_fact (st x - 1) =
        real_fact m /\ m >= (st x - 1) }};
     x ::= AMinus (AId x) (ANum 1)
       {{ fun st => st x > 0 -> st y * real_fact (st x)
        = real_fact m /\ m >= st x }}
    {{ fun st => (st x > 0 -> st y * real_fact (st x) =
        real_fact m /\ m >= st x) /\ st x = 1 }} =>>
    {{ fun st => st y = real_fact m /\ m > 0}}
).

Theorem my_factcorrect : forall m,
  ann_correct (my_fact m).
Proof.
  intros.
  verify.
  - rewrite <- plus_n_O.
    assert ((y !-> 1, st) x > 0 ->
        real_fact (st x) = real_fact m /\ m >= st x).
    { apply H. }
    apply H1 in H0.
    apply H0.
  - assert (forall n, n <> 0 -> n * real_fact (n - 1)
        = real_fact n).
    + intros.
      destruct n.
      * destruct H1.
        reflexivity.
      * simpl.
        rewrite <- minus_n_O.
        reflexivity.
    + unfold not.
      intros.
      rewrite H2 in H.
      discriminate H.
  - apply beq_nat_true in H.
    apply H.
  - assert (forall n, n <> 0 -> n * real_fact (n - 1) =
        real_fact n).
    + intros.
      destruct n.
      * destruct H2.
        reflexivity.
      * simpl.
        rewrite <- minus_n_O.
        reflexivity.
    + rewrite <- mult_assoc.
      rewrite H2.
      omega.
      omega.
  - assert ((y !-> st y * st x, st) x - 1 > 0 ->
        st y * st x * real_fact (st x - 1)
        = real_fact m /\ m >= st x - 1).
    { apply H. }
    apply H1 in H0.
    apply H0.
  - assert ((x !-> st x - 1, st) x > 0 ->
        st y * real_fact (st x - 1)
        = real_fact m /\ m >= st x - 1).
    { apply H. }
    apply H1 in H0.
    apply H0.
  - assert (1 > 0).
    { omega. }
    apply H in H0.
    assert (real_fact 1 = 1).
    { reflexivity. }
    rewrite H1 in H0.
    assert (st y * 1 = st y).
    { omega. }
    rewrite H2 in H0.
    apply H0.
Qed.

(*-------------------------Soundness_and_Completeness------------------------*)
(* There are no other examples we can prove for these subjects *)


Require Export P06.

Theorem subst_equiv: forall i1 i2 a1 a2,
  var_not_used_in_aexp i1 (subst_aexp i1 a1 a2) ->
  cequiv <{i1 := a1; i2 := a2}>
         <{i1 := a1; i2 := subst_aexp i1 a1 a2}>.
Proof.
  exact FILL_IN_HERE.
Qed.


From CoqAlgs Require Export Sorting.InsertionSort.
From CoqAlgs Require Export Sorting.SortSpec.

From CoqAlgs Require Export CMon.

Set Implicit Arguments.

Inductive type (X : CMon) : Type :=
    | elem : type X
    | prop : type X.

Arguments elem {X}.
Arguments prop {X}.

Inductive exp {X : CMon} : type X -> Type :=
    | Id : exp elem
    | Var : nat -> exp elem
    | Op : exp elem -> exp elem -> exp elem
    | fFalse : exp prop
    | fTrue : exp prop
    | fEquiv : exp elem -> exp elem -> exp prop
    | fAnd : exp prop -> exp prop -> exp prop
    | fOr : exp prop -> exp prop -> exp prop
    | fImpl : exp prop -> exp prop -> exp prop.

Arguments Id     {X}.
Arguments Var    {X} _.
Arguments Op     {X} _ _.
Arguments fEquiv {X} _ _.
Arguments fAnd   {X} _ _.
Arguments fOr    {X} _ _.
Arguments fImpl  {X} _ _.

Definition typeDenote {X : CMon} (t : type X) : Type :=
match t with
    | elem => X
    | prop => Prop
end.

Fixpoint denote {X : CMon} {t : type X} (env : Env X)
  (f : exp t) : typeDenote t :=
match f with
    | Id => neutr
    | Var n => nth n env neutr
    | Op e1 e2 => op (denote env e1) (denote env e2)
    | fFalse => False
    | fTrue => True
    | fEquiv e1 e2 => denote env e1 = denote env e2
    | fAnd f1 f2 => denote env f1 /\ denote env f2
    | fOr f1 f2 => denote env f1 \/ denote env f2
    | fImpl f1 f2 => denote env f1 -> denote env f2
end.

Fixpoint flatten {X : CMon} (e : exp elem) : list nat :=
match e with
    | Id => []
    | Var v => [v]
    | Op e1 e2 => flatten e1 ++ flatten e2
end.

Theorem flatten_correct :
  forall (X : CMon) (env : Env X) (e : exp elem),
    expDenoteL env (flatten e) = denote env e.
Proof.
  dependent induction e; cbn.
    reflexivity.
    rewrite neutr_r. reflexivity.
    rewrite expDenoteL_app. rewrite IHe1, IHe2; reflexivity.
Qed.

Theorem sort_correct :
  forall (X : CMon) (env : Env X) (l : list nat) (s : Sort trich_le),
    expDenoteL env (s l) = expDenoteL env l.
Proof.
  intros. apply expDenoteL_Permutation. rewrite Permutation_sort.
  reflexivity.
Qed.

Function list_to_exp {X : CMon} (l : list nat) : exp elem :=
match l with
    | [] => Id
    | [x] => Var x
    | h :: t => Op (Var h) (list_to_exp t)
end.

Theorem list_to_exp_correct :
  forall (X : CMon) (env : Env X) (l : list nat),
    denote env (list_to_exp l) = expDenoteL env l.
Proof.
  intros. functional induction list_to_exp l; cbn.
    trivial.
    rewrite neutr_r. trivial.
    rewrite IHe. trivial.
Qed.

Definition simplify {X : CMon} (e : exp elem) : exp elem :=
  list_to_exp (insertionSort natlt (flatten e)).

Theorem simplify_correct :
  forall (X : CMon) (env : Env X) (e : exp elem),
    denote env (simplify e) = denote env e.
Proof.
  unfold simplify. intros.
  rewrite !list_to_exp_correct.
  pose (sort_correct _ env (flatten e) (Sort_insertionSort natlt)).
  cbn in e0. rewrite e0.
  erewrite !flatten_correct.
  reflexivity.
Qed.

Theorem reflectEq :
  forall (X : CMon) (env : Env X) (e1 e2 : exp elem),
    denote env (simplify e1) = denote env (simplify e2) ->
      denote env e1 = denote env e2.
Proof.
  intros. rewrite !simplify_correct in H. assumption.
Qed.

Fixpoint solve
  {X : CMon} (env : Env X) (f : exp prop)
  : option (denote env f).
Proof.
  dependent destruction f; cbn.
    apply None.
    apply Some. trivial.
    apply None.
    destruct (solve X env f1), (solve X env f2).
      apply Some. split; assumption.
      1-3: apply None.
    destruct (solve X env f1).
      apply Some. left. assumption.
      destruct (solve X env f2).
        apply Some. right. assumption.
        apply None.
    destruct (solve X env f2).
      apply Some. intro. assumption.
      apply None.
Defined.

Theorem solve_spec :
  forall (X : CMon) (env : Env X) (f : exp prop),
    (exists p : denote env f, solve env f = Some p) ->
      denote env f.
Proof.
  intros. destruct H. assumption.
Qed.

Definition simplifyFormula {X : CMon} {t : type X} : exp t -> exp t :=
match t with
    | elem => fun e => simplify e
    | prop => fun e =>
        match e with
            | fEquiv e1 e2 => fEquiv (simplify e1) (simplify e2)
            | _ => e
        end
end.

Theorem simplifyFormula_correct :
  forall (X : CMon) (t : type X) (env : Env X) (e : exp t),
    denote env (simplifyFormula e) = denote env e.
Proof.
  destruct t; cbn; intros.
    rewrite simplify_correct. trivial.
    dependent destruction e; trivial.
      cbn. rewrite !simplify_correct. trivial.
Qed.

Theorem reflectFormula :
  forall (X : CMon) (env : Env X) (e : exp prop),
    denote env (simplifyFormula e) -> denote env e.
Proof.
  dependent induction e; cbn; trivial.
    rewrite !simplify_correct. trivial.
Qed.

Ltac allVars X xs e :=
match e with
    | op ?e1 ?e2 =>
        let xs' := allVars X xs e2 in allVars X xs' e1
    | ?a = ?b =>
        let xs' := allVars X xs b in allVars X xs' a
    | ~?P => allVars xs P
    | ?P1 /\ ?P2 =>
        let xs' := allVars X xs P2 in allVars X xs' P1
    | ?P1 \/ ?P2 =>
        let xs' := allVars X xs P2 in allVars X xs' P1
    | ?P1 -> ?P2 =>
        let xs' := allVars X xs P2 in allVars X xs' P1
    | ?P1 <-> ?P2 =>
        let xs' := allVars X xs P2 in allVars X xs' P1
    | _ =>
        match type of e with
            | X => addToList e xs
        end
end.

Ltac reify env e :=
match e with
    | neutr => constr:(Id)
    | op ?a ?b =>
        let e1 := reify env a in
        let e2 := reify env b in constr:(Op e1 e2)
    | False => constr:(fFalse)
    | True => constr:(fTrue)
    | ?a = ?b =>
        let e1 := reify env a in
        let e2 := reify env b in constr:(fEquiv e1 e2)
    | ~?P =>
        let e' := reify env P in constr:(fImpl e' fFalse)
    | ?P1 /\ ?P2 =>
        let e1 := reify env P1 in
        let e2 := reify env P2 in constr:(fAnd e1 e2)
    | ?P1 \/ ?P2 =>
        let e1 := reify env P1 in
        let e2 := reify env P2 in constr:(fOr e1 e2)
    | ?P1 -> ?P2 =>
        let e1 := reify env P1 in
        let e2 := reify env P2 in constr:(fImpl e1 e2)
    | ?P1 <-> ?P2 =>
        let e1 := reify env P1 in
        let e2 := reify env P2 in constr:(fAnd (fImpl e1 e2) (fImpl e2 e1))
    | _ =>
        let n := lookup e env in constr:(Var n)
end.

Ltac reflectGoal :=
match goal with
    | X : CMon |- ?P =>
        let env := allVars (@carrier X) constr:(@nil X) P in
        let e := reify env P in
          change (denote env e);
          apply reflectFormula; cbn
end.

Ltac cmon_simpl := cbn; intros; subst;
match goal with
    | X : CMon |- ?a = ?b => reflectGoal
end.

Ltac cmon := cmon_simpl; reflexivity.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                       Derived_composition_rules.v                        *)
(****************************************************************************)

Require Export Basic_composition_rules.
Require Import Fixed_dLists.

Set Implicit Arguments.
Unset Strict Implicit.

(** Particular case of the PC rule : parallel composition of the same **)
(** Mealy automaton **)

Section Particular_Parallel_Composition.

  Variable
    Input_type_1 Input_type Output_type_1 Output_type State_type_1 : Set.

 (** Description of the automata to duplicate **)

  Variable Trans1 : Input_type_1 -> State_type_1 -> State_type_1.
  Variable Out1 : Input_type_1 -> State_type_1 -> Output_type_1.

  Let S1 := Mealy Trans1 Out1.
  Let S1' := Mealy Trans1 Out1.

  (** f will be used to dispath the input vector **)
  Variable f : Input_type -> Input_type_1 * Input_type_1.

  (** output will be used to construct the output of the parallel composition **)
  Variable output_part : d_list Output_type_1 2 -> Output_type.

 (** Explicit construction of the parallel composition *)

  Notation S1S1 :=
    (fun (i : Stream Input_type) (s1 s1' : State_type_1) =>
     S_map output_part
       (dlist_to_Stream
          (List2 (S1 (S_map fstS (S_map f i)) s1)
             (S1 (S_map sndS (S_map f i)) s1'))))
    (only parsing).

 (** Description of the parallel composition PC of two Mealy automata S1 **)

  Definition Trans_PC_part (i : Input_type) (s : State_type_1 * State_type_1)
    : State_type_1 * State_type_1 := Trans_PC Trans1 Trans1 f i s.

  Definition Out_PC_part (i : Input_type) (s : State_type_1 * State_type_1) :
    Output_type :=
    let (s1, s1') := s in
    output_part (List2 (Out1 (fst (f i)) s1) (Out1 (snd (f i)) s1')).

  Definition PC_part :
    Stream Input_type -> State_type_1 * State_type_1 -> Stream Output_type :=
    Mealy Trans_PC_part Out_PC_part.

  Definition States_PC_part :
    Stream Input_type ->
    State_type_1 * State_type_1 -> Stream (State_type_1 * State_type_1) :=
    States_Mealy Trans_PC_part.

  (** Equivalence between S1S1 and PC_part **)

  Lemma Equiv_S1S1_PC_part :
   forall (i : Stream Input_type) (s1 s1' : State_type_1),
   EqS
     ((fun (i : Stream Input_type) (s1 s1' : State_type_1) =>
       S_map output_part
         (dlist_to_Stream
            (List2 (S1 (S_map fstS (S_map f i)) s1)
               (S1 (S_map sndS (S_map f i)) s1')))) i s1 s1')
     (PC_part i (s1, s1')).
  Proof.
  cofix Equiv_S1S1_PC_part.
  intros i s1 s1'.
  apply eqS.
  simpl in |- *; auto.
  rewrite S_tail_S_map; rewrite S_tail_dlist_to_Stream; rewrite tls_simpl.
  unfold S1 in |- *; unfold S1 in Equiv_S1S1_PC_part.
  rewrite S_tail_Mealy; rewrite S_tail_S_map; rewrite S_tail_S_map;
   rewrite S_tail_Mealy; rewrite S_tail_S_map; rewrite S_tail_S_map.
  unfold PC_part in |- *; unfold PC_part in Equiv_S1S1_PC_part.
  rewrite S_tail_Mealy.
  unfold Trans_PC_part in |- *; unfold Trans_PC_part in Equiv_S1S1_PC_part;
   unfold Trans_PC in |- *; auto.
  Qed.

End Particular_Parallel_Composition.


Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics list.
From discprob.basic Require Import seq_ext.
From discprob.measure Require Export borel integral isomorphism.
Require Import ClassicalEpsilon.

Section pushforward.
  Context {A1 A2: Type}.
  Context {F1 : measurable_space A1}.
  Context {F2 : measurable_space A2}.
  Context (μ: measure A1).
  Context (f: A1 → A2).
  Context (Hmeas: measurable f).

  Definition pushforward : measure A2.
  Proof.
    refine {| measure_fun := λ U, μ (fun_inv f U) |}.
    - abstract (by intros ?? ->).
    - intros; apply measure_nonneg.
    - abstract (rewrite fun_inv_empty measure_empty //).
    - abstract (intros Us Hin Hdisj;
                rewrite fun_inv_unionF;
                apply measure_additivity;
                  by [ intros; eapply Hmeas | apply fun_inv_disjointF; auto]).
  Defined.

  Lemma wpt_hom_aux (wpt: weighted_partition F2):
    ∀ (r : R) (U : A1 → Prop),
      In (r, U) (map (λ rU : R * (A2 → Prop), (rU.1, fun_inv f rU.2)) wpt) → F1 U.
  Proof.
    intros r U Hin. apply in_map_iff in Hin as ((r'&U')&Heq&Hin).
    inversion Heq; subst. eapply Hmeas.
    by apply In_wpt_snd_measurable in Hin.
  Qed.

  Lemma wpt_hom_spec:
    ∀ wpt2 : weighted_partition F2, ∃ wpt1 : weighted_partition F1,
      ∀ x, wpt_fun wpt2 (f x) = wpt_fun wpt1 x.
  Proof.
    apply wpt_induction.
    - intros wpt1 wpt2 Heq.
      intros (wpt&?). exists wpt => ?. by rewrite -Heq.
    - intros U HmeasU.
      exists (wpt_indicator (fun_inv f U) (Hmeas _ HmeasU)).
      intros. rewrite ?wpt_indicator_spec.
      destruct excluded_middle_informative; eauto.
    - intros wpt1 wpt2 (wpt1'&Heq1') (wpt2'&Heq2').
      exists (wpt_plus wpt1' wpt2'). intros x.
      rewrite ?wpt_plus_spec. rewrite Heq1' Heq2'. done.
    - intros k wpt (wpt'&Heq').
      exists (wpt_scal k wpt'). intros x. rewrite ?wpt_scal_spec Heq'. auto.
  Qed.

  Lemma wpt_hom_fun (wpt: weighted_partition F2): weighted_partition F1.
  Proof.
    specialize (wpt_hom_spec wpt) => Hspec.
    apply constructive_indefinite_description in Hspec as (wpt'&?).
    exact wpt'.
  Defined.

  Lemma wpt_hom_fun_spec wpt: ∀ x, wpt_fun wpt (f x) = wpt_fun (wpt_hom_fun wpt) x.
  Proof.
    intros x.
    rewrite /wpt_hom_fun; destruct constructive_indefinite_description; eauto.
  Qed.

  Lemma wpt_change_of_variables (wpt1: weighted_partition F1) (wpt2: weighted_partition F2):
    (∀ x, wpt_fun wpt2 (f x) = wpt_fun wpt1 x) →
    wpt_integral μ wpt1 = wpt_integral pushforward wpt2.
  Proof.
    revert wpt2 wpt1.
    eapply (@wpt_induction _ F2 (λ wpt2, ∀ wpt1, (∀ x, wpt_fun wpt2 (f x) = wpt_fun wpt1 x) →
                                wpt_integral μ wpt1 = wpt_integral pushforward wpt2)).
    - intros wpt1 wpt1' Heq Hres1 wpt2 Heq2.
      rewrite Hres1.
      * apply wpt_integral_proper; by symmetry.
      * congruence.
    - intros U HmeasU wpt1 Heq.
      rewrite ?wpt_integral_indicator.
      transitivity (wpt_integral μ (wpt_indicator (fun_inv f U) (Hmeas _ HmeasU))).
      {
        apply wpt_integral_proper.
        intros z. rewrite -Heq ?wpt_indicator_spec //=.
      }
      rewrite wpt_integral_indicator //=.
    - intros wpt1 wpt2 Hspec1 Hspec2 wpt Heq.
      rewrite wpt_integral_plus.
      destruct (wpt_hom_spec wpt1) as (wpt1'&?).
      destruct (wpt_hom_spec wpt2) as (wpt2'&?).
      transitivity (wpt_integral μ (wpt_plus wpt1' wpt2')).
      {
        apply wpt_integral_proper => z. rewrite -Heq. rewrite ?wpt_plus_spec; congruence.
      }
      rewrite wpt_integral_plus; f_equal; eauto.
    - intros k wpt Hspec kwpt Heq.
      destruct (wpt_hom_spec wpt) as (wpt'&?).
      transitivity (wpt_integral μ (wpt_scal k wpt')).
      {
        apply wpt_integral_proper => z. rewrite -Heq. rewrite ?wpt_scal_spec; congruence.
      }
      rewrite ?wpt_integral_scal; f_equal; eauto.
  Qed.

  Lemma is_pos_integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g) v:
    (∀ x, 0 <= g x) →
    is_pos_integral μ (λ x, g (f x)) v ↔ is_pos_integral pushforward g v.
  Proof.
    intros Hpos.
    edestruct (wpt_approx_measurable g Hpos Hmeasg) as (wpt&Hincr&Hlim'&Hbound); eauto.
    split.
    - intros His_pos.
      eapply is_pos_integral_mct_wpt; eauto.
      eapply (is_lim_seq_ext (λ n, wpt_integral μ (wpt_hom_fun (wpt n)))).
      { intros n. apply wpt_change_of_variables. intros x.
        rewrite /wpt_hom_fun. destruct constructive_indefinite_description; eauto.
      }
      eapply (is_pos_integral_mct_wpt' μ (λ n, wpt_hom_fun (wpt n)));
        try eapply His_pos; eauto.
      * intros x. eapply is_lim_seq_ext; last eapply Hlim'.
        intros n => //=. apply wpt_hom_fun_spec.
      * intros x n. rewrite -?wpt_hom_fun_spec; eauto.
    - intros His_pos.
      eapply (is_pos_integral_mct_wpt _ (λ n, wpt_hom_fun (wpt n))); eauto.
      * eapply measurable_comp; eauto.
      * intros x. eapply is_lim_seq_ext; last eapply Hlim'.
        intros n => //=. apply wpt_hom_fun_spec.
      * intros x n. rewrite -?wpt_hom_fun_spec; eauto.
      *
      eapply (is_lim_seq_ext (λ n, wpt_integral pushforward (wpt n))).
      { intros n. symmetry. apply wpt_change_of_variables. intros x.
        rewrite /wpt_hom_fun. destruct constructive_indefinite_description; eauto.
      }
      eapply is_pos_integral_mct_wpt'; eauto.
  Qed.

  Lemma is_integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g) v:
    is_integral μ (λ x, g (f x)) v ↔ is_integral pushforward g v.
  Proof.
    split.
    - rewrite /is_integral. intros (Hmeas'&(v1&v2&Hpos1&Hpos2&Heq)).
      split; eauto. exists v1, v2.
      split_and!; auto.
      * eapply is_pos_integral_change_of_variables; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
      * eapply is_pos_integral_change_of_variables; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
    - rewrite /is_integral. intros (Hmeas'&(v1&v2&Hpos1&Hpos2&Heq)).
      split; eauto.
      { eapply measurable_comp; eauto. }
      exists v1, v2.
      split_and!; auto.
      * eapply is_pos_integral_change_of_variables in Hpos1; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
      * eapply is_pos_integral_change_of_variables in Hpos2; eauto; first measurable.
        intros; apply Rmax_case_strong; nra.
  Qed.

  Lemma Pos_integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g):
    (∀ x, 0 <= g x) →
    Pos_integral μ (λ x, g (f x)) = Pos_integral pushforward g.
  Proof.
    intros Hpos.
    destruct (Classical_Prop.classic (∃ v, is_pos_integral pushforward g v)) as [(v&Hex)|Hnex].
    { rewrite (is_pos_integral_unique _ _ _ Hex).
      apply is_pos_integral_unique.
      apply is_pos_integral_change_of_variables; eauto.
    }
    transitivity 0.
    * apply measurable_non_ex_pos_integral_0.
      ** eapply measurable_comp; eauto.
      ** intros (v&Hex).  eapply Hnex. exists v. apply is_pos_integral_change_of_variables; eauto.
    * symmetry; apply measurable_non_ex_pos_integral_0; eauto.
  Qed.

  Lemma Integral_change_of_variables (g: A2 → R) (Hmeasg: measurable g):
    Integral μ (λ x, g (f x)) = Integral pushforward g.
  Proof.
    rewrite /Integral; f_equal.
    * eapply (Pos_integral_change_of_variables (λ x, Rmax (g x) 0)); eauto; first measurable.
      intros; apply Rmax_case_strong; nra.
    * eapply (Pos_integral_change_of_variables (λ x, Rmax (- g x) 0)); eauto; first measurable.
      intros; apply Rmax_case_strong; nra.
  Qed.

End pushforward.

(*
Definition measure_restrict {A: Type} (F F': sigma_algebra A) (μ: measure A) (Hle: le_sigma F F'):
  measure A.
Proof.
  apply (pushforward μ id); abstract auto.
Defined.
*)