(** Cut Elimination for Focused Linear Logic

This file proves cut-elimination for the triadic system of linear
logic. The proof uses 5 cut-rules dealing with the negative and
positive phase of proofs (see [CutElimBase]).

It is assumed that the theory only produces well formed LL formulas
(see [TheoryIsFormula]).
 *)

Require Export FLL.Misc.Hybrid.
Require Export FLL.SL.FLLTactics.
Require Import Lia.
Require Import FLL.Misc.Permutations.
Require Import FunInd.
Require Import Coq.Program.Equality.
Require Export FLL.SL.InvPositivePhase.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Section CutElimination.
  Context `{OLS: OLSig}.
  Hint Constructors isFormula  Remove seqN IsPositiveAtom : core .

  Variable theory : oo -> Prop .
  Notation " n '|---' B ';' L ';' X " := (seqN theory n B L X) (at level 80).
  Notation " '|--' B ';' L ';' X " := (seq theory B L X) (at level 80).

  Theorem CutElimBase C dualC D dualD B L M N P:
    dualC = dual C ->
    (0 |--- B; M++[C] ; DW P ->
                        0  |--- B; N ; DW dualC ->
                                       |-- B; M++N ; DW P)
    /\
    (0 |--- B; M++[C] ; UP L ->
                        0 |--- B; N ; DW dualC ->
                                      |-- B; M++N ; UP L)
    /\
    (0 |--- B; M ; UP (C::L) ->
                   0 |--- B; N ; DW dualC ->
                                 |-- B; M++N ; UP L)
    /\
    (dualD = dual D -> dualC = (! dualD) ->
     0 |--- B++[D]; M ; UP L ->
                        0 |--- B; [] ; DW (! dualD) ->
                                       |-- B; M ; UP L)
    /\
    (dualD = dual D  -> dualC = (! dualD) ->
     ~ IsPositiveAtom D ->
     0 |--- B++[D]; M ; DW P ->
                        0 |--- B; [] ; DW (! dualD) ->
                                       |-- B; M ; DW P).
  Proof with subst;auto.
    intros CDual.
    split;[intros
          |split;[intros
                 |split;[intros
                        |split;intros]]].
    * (** Dw Linear Cut *)
      inversion H...
      **
        symmetry in H4.
        apply app_eq_unit in H4.
        destruct H4.
    + inversion H1...
      inversion H3...
      clear H1 H3.
      apply seqNtoSeq in H0.
      exact H0.
    + inversion H1...
      inversion H3.
      **
        symmetry in H1.
        apply app_eq_nil in H1.
        destruct H1.
        inversion H2.
      **
        symmetry in H4.
        apply app_eq_nil in H4.
        destruct H4.
        inversion H2.
      * (** Up Linear Cut *)
        inversion H...
        eapply tri_top'.
      * (** Up Cut *)
        inversion H...
        inversion H0.
      * (** Up Classic Cut *)
        inversion H2.
      *
        inversion H3.
  Qed.

  Lemma AtomPerm0 j B F L P:
    IsPositiveAtom P -> j |--- B; []; (>> ! P ^) -> 0 |--- B ++ [P]; L; (>> F) -> |-- B; L; (> [F]).
  Proof with subst;auto;solveF.
    intros isPAP Hj H0.
    inversion isPAP...
    clear isPAP.
    inversion H0...
    +
      eapply tri_store'...
      eapply tri_dec1' with (F:=perp A0) (L':=[atom A0])...
      eapply tri_init1'.
    +
      apply in_app_or in H4.
      inversion H4...
      eapply tri_store'...
      eapply tri_dec1' with (F:=perp A0) (L':=[])...
      eapply tri_init2'...
      inversion Hj...

      apply seqNtoSeq in H5...
    +
      eapply tri_store'...
      eapply tri_dec1' with (F:=one) (L':=[])...
      eapply tri_one'.
  Qed.

  Definition CutH (w h: nat) :=
    forall m i j C dualC D dualD P M N L B,
      m <= h ->
      m = i + j ->
      dualC = C ^ ->
      isFormula C -> isFormula dualC ->
      complexity C = S w ->
      isFormula P ->
      isNotAsyncL N ->
      isFormulaL N ->
      isNotAsyncL M ->
      isFormulaL M ->
      isFormulaL L ->
      isFormulaL B ->
      (i |--- B; M ++ [C]; (>> P) -> j |--- B; N; (>> dualC) -> |-- B; M ++ N; (>> P)) /\
      (i |--- B; M ++ [C]; (> L) -> j |--- B; N; (>> dualC) -> |-- B; M ++ N; (> L)) /\
      (i |--- B; M; (> C :: L) -> j |--- B; N; (>> dualC) -> |-- B; M ++ N; (> L)) /\
      (dualD = D ^ ->
       dualC = ! dualD ->
       i |--- B ++ [D]; M; (> L) -> j |--- B; []; (>> ! dualD) -> |-- B; M; (> L)) /\
      (dualD = D ^ ->
       dualC = ! dualD ->
       ~ IsPositiveAtom D ->
       i |--- B ++ [D]; M; (>> P) -> j |--- B; []; (>> ! dualD) -> |-- B; M; (>> P)).

  Hypothesis TheoryIsFormula: forall P, theory P -> isFormula P.

  Theorem AtomPerm j n w h P F L B:
    CutH w h -> S h = S n + j -> complexity P = w ->
    isFormulaL B -> isFormulaL L -> isNotAsyncL L -> isFormula P -> isFormula F ->
    IsPositiveAtom P -> j |--- B; []; (>> ! P ^) -> n |--- B ++ [P]; L; (>> F) -> |-- B; L; (> [F]).
  Proof with subst;auto;solveF.
    intros HC Hh Hc isFB isFL isNL isFP isFF isPAP Hj Hn.
    inversion isPAP...
    clear isFP isPAP.
    revert dependent B.
    revert dependent L.
    revert dependent F.
    revert dependent j.

    induction n; intros.
    * eapply AtomPerm0 with (P:=atom A) (j:=j)...
    *
      inversion Hn... (* 9 Cases *)
      ** (* Case 1 *)
        eapply tri_store'...
        eapply tri_dec1' with (F:=perp A0) (L':=[atom A0])...
        eapply tri_init1'.
      ** (* Case 2 *)
        apply in_app_or in H3.
        inversion H3...
        eapply tri_store'...
        eapply tri_dec1' with (F:=perp A0) (L':=[])...
        eapply tri_init2'...
        inversion Hj...
        apply seqNtoSeq in H4...
      ** (* Case 3 *)
        eapply tri_store'...
        eapply tri_dec1' with (F:=one) (L':=[])...
        eapply tri_one'.
      ** (* Case 4 *)
        assert(|-- B; M; (> [F0])).
        eapply IHn with (j:=S j) ...
        lia.
        inversion isFF...
        rewrite H1 in isFL.
        eapply ForallAppInv1.
        exact isFL.
        rewrite H1 in isFL.
        rewrite H1 in isNL.
        apply ForallAppInv1 in isNL...
        eapply HeightGeq. exact Hj. lia.

        assert(|-- B; N; (> [G])).
        eapply IHn with (j:=S j)...
        lia.
        inversion isFF...
        rewrite H1 in isFL.
        eapply ForallAppInv2 in isFL...
        rewrite H1 in isFL.
        rewrite H1 in isNL.
        apply ForallAppInv2 in isNL...
        eapply HeightGeq. exact Hj. lia.

        assert(|-- B; M++N++[F0 ** G]; UP ([]++[])).
        apply InvTensor...

        rewrite H1 in isNL.
        apply ForallAppInv1 in isNL...

        rewrite H1 in isNL.
        apply ForallAppInv2 in isNL...

        rewrite H1 in isFL.
        eapply ForallAppInv1 in isFL...
        rewrite H1 in isFL.
        eapply ForallAppInv2 in isFL...
        eapply tri_store'...
        refine (exchangeLC _ H3 ).
        rewrite H1. perm.
      ** (* Case 5 *)
        assert(|-- B; L; (> [F0])).
        eapply IHn with (j:=S j)...
        lia.
        inversion isFF...
        eapply HeightGeq. exact Hj. lia.

        assert(|-- B; L++[F0 op G]; UP ([]++[])).
        apply InvPlus...
        inversion isFF...
        simpl in H0.
        eapply tri_store'...
      ** (* Case 6 *)
        assert(|-- B; L; (> [G])).
        eapply IHn with (j:=S j)...
        lia.
        inversion isFF...
        eapply HeightGeq. exact Hj. lia.

        assert(|-- B; L++[F0 op G]; UP ([]++[])).
        apply InvPlusComm...
        inversion isFF...
        simpl in H0.
        eapply tri_store'...
      ** (* Case 7 *)
        assert(
            S n |--- B ++ [atom A]; []; (> [F0]) ->
                                        j |--- B; []; (>> ! perp A) -> |-- B; []; (> [F0])).
        eapply HC  with (C:=? atom A) (dualC:=! perp A) (N:=[])...
        inversion isFF...
        eapply tri_store'...
        eapply tri_dec1' with (F:=! F0) (L':=[])...
        apply tri_bang'...
        apply H...
        eapply HeightGeq. exact H3. lia.
      ** (* Case 8 *)
        assert(
            S n |--- B ++ [atom A]; L; (> [F]) ->
                                       j |--- B; []; (>> ! perp A) -> |-- B; L; (> [F])).
        eapply HC with (C:=? atom A) (dualC:=! perp A) (N:=L)...

        apply H...
        eapply HeightGeq. exact H4. lia.
      ** (* Case 9 *)
        assert(|-- B; L; (> [FX t])).
        eapply IHn with (j:=S j)...
        lia.
        inversion isFF...
        eapply HeightGeq. exact Hj. lia.

        assert(|-- B; L++[E{ FX}]; UP ([]++[])).
        eapply InvEx with (t0:=t)...
        inversion isFF...

        simpl in H0.
        eapply tri_store'...
  Qed.

  (*
      Ltac solveAsyncL :=
        repeat
          match goal with
          | [ H1: isNotAsyncL ?M1, H2: isNotAsyncL ?M2 |- isNotAsyncL (?M1 ++ ?M2)] =>
            apply LPosApp;auto
          | [ H1: isNotAsyncL ?M1, H2: isNotAsyncL ?M2 |- isNotAsyncL (?M2 ++ ?M1)] =>
            apply LPosApp;auto

          | [ H1: Permutation (?X ++ ?N) ?M, H2: isNotAsyncL ?M |- isNotAsyncL ?X] =>
            symmetry in H1; eapply LPos2;eauto
          | [ H1: Permutation ?M (?X ++ ?N), H2: isNotAsyncL ?M |- isNotAsyncL ?X] =>
            eapply LPos2;eauto
          | [ H1: Permutation (?N ++ ?X) ?M, H2: isNotAsyncL ?M |- isNotAsyncL ?X] =>
            symmetry in H1; eapply LPos3;eauto
          | [ H1: Permutation ?M (?N ++ ?X), H2: isNotAsyncL ?M |- isNotAsyncL ?X] =>
            eapply LPos2;eauto
          | [ H1: ~ asynchronous ?F, H2: isNotAsyncL ?M |- isNotAsyncL (?M ++ [?F]) ] =>
            eapply LPos3 with (M1:=[]) (L:=F::M)
          | [ H1: ~ asynchronous ?F, H2: isNotAsyncL ?M |- isNotAsyncL (?F :: ?M) ] =>
            split;auto
          | [  |- Permutation ?M1 ?M2 ] =>
            perm
          end.
   *)

  Ltac solveIsFormL :=
    repeat
      match goal with
      | [ H1: isFormulaL (?F :: ?M'), H2: isFormulaL ?M |- isFormulaL (?M ++ [?F]) ] =>
        assert(Hp: Permutation (M ++ [F]) (F :: M) ) by perm;
        rewrite Hp;inversion H1;subst;apply ForallCons;auto
      | [ H1: isFormulaL (?F :: ?M') |- isFormula ?F ] =>
        inversion H1;subst;auto
      | [ H1: isFormulaL (?F :: ?M) |- isFormulaL (?F'::?M) ] =>
        inversion H1;subst;apply ForallCons;auto
      | [ H1: isFormula ?F, H2: isFormulaL ?M |- isFormulaL (?F::?M) ] =>
        apply ForallCons;auto
      | [ H1: isFormulaL (?F :: ?M) |- isFormulaL ?M ] =>
        inversion H1;subst;auto
      | [ H1: isFormulaL ?M, H2: Permutation ?M ?M' |- _ ] =>
        rewrite H2 in H1;clear H2
      | [ H1: isFormulaL ?M, H2: Permutation ?M' ?M |- _ ] =>
        rewrite <- H2 in H1;clear H2
      | [ H1: isFormulaL (?M++?N) |- isFormulaL ?M ] =>
        eapply ForallAppInv1;eauto
      | [ H1: isFormulaL (?M++?N) |- isFormulaL ?N ] =>
        eapply ForallAppInv2;eauto
      | [ H1: In ?F ?B |- isFormula ?F ] =>
        apply isFormulaIn in H1;auto
      end.

  Ltac solveFormLL :=
    try constructor;
    match goal with
    | [ H1: isFormula (AAnd ?A1 ?A2) |- isFormula ?A1 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (AAnd ?A1 ?A2) |- isFormula ?A2 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (MAnd ?A1 ?A2) |- isFormula ?A1 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (MAnd ?A1 ?A2) |- isFormula ?A2 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (AOr ?A1 ?A2) |- isFormula ?A1 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (AOr ?A1 ?A2) |- isFormula ?A2 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (MOr ?A1 ?A2) |- isFormula ?A1 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (MOr ?A1 ?A2) |- isFormula ?A2 ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (Bang ?A) |- isFormula ?A ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (Quest ?A) |- isFormula ?A ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (F{ ?FX}) |- isFormula (?FX ?x) ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (All ?A) |- isFormula (?A ?x) ] =>
      inversion H1;subst;auto
    | [ H1: isFormula (Some ?A) |- isFormula (?A ?x) ] =>
      inversion H1;subst;auto
    end.

  Theorem CutElimination i j C dualC D dualD B L M N P:
    dualC = dual C -> isFormula C -> isFormula dualC ->
    isNotAsyncL M -> isNotAsyncL N ->
    isFormulaL B -> isFormulaL M -> isFormulaL N -> isFormulaL L ->
    isFormula P ->

    (
      i |--- B; M++[C] ; DW P ->
                         j |--- B; N ; DW dualC ->
                                       |-- B; M++N ; DW P)
    /\
    (
      i |--- B; M++[C] ; UP L ->
                         j |--- B; N ; DW dualC ->
                                       |-- B; M++N ; UP L)
    /\
    (
      i |--- B; M ; UP (C::L) ->
                    j |--- B; N ; DW dualC ->
                                  |-- B; M++N ; UP L)
    /\
    (dualD = dual D -> dualC = (! dualD) ->
     i |--- B++[D]; M ; UP L ->
                        j |--- B; [] ; DW (! dualD) ->
                                       |-- B; M ; UP L)
    /\
    (dualD = dual D -> dualC = (! dualD) ->
     ~ IsPositiveAtom D ->
     i |--- B++[D]; M ; DW P ->
                        j |--- B; [] ; DW (! dualD) ->
                                       |-- B; M ; DW P).

  Proof with subst;auto;solveF.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H as [w H].
    revert H.
    revert i j C dualC D dualD P B L M N.

    induction w using strongind;intros.
    - assert(complexity C > 0) by apply Complexity0.
      rewrite H in H10. inversion H10.
    - remember (plus i j) as h.
      revert dependent B.
      revert dependent L.
      revert dependent M.
      revert dependent N.
      revert dependent P.
      revert dependent dualD.

      revert D.
      revert dependent C.
      revert dependent dualC.

      revert dependent i.
      revert j.
      dependent induction h using strongind; intros.
      +
        symmetry in Heqh.
        apply plus_is_O in Heqh.
        destruct Heqh;subst.
        apply CutElimBase...

      +

        rename H into CutW.
        rename H0 into CutH.
        rename H1 into compC.
        rename H3 into isFDC.
        rename H4 into isFC.
        rename H5 into isNAN.
        rename H6 into isNAM.
        rename H7 into isFM.
        rename H8 into isFN.
        rename H9 into isFL.
        rename H10 into isFP.
        rename H11 into isFB.
        move B at top.
        move M at top.
        move N at top.
        move L at top.
        move C at top.
        move D at top.
        move dualC at top.
        move dualD at top.
        move P at top.

        subst.

        split;[intros
              |split;[intros
                     |split;[intros
                            |split;intros]]].
        * (** Dw Linear Cut *)
          clear CutW.
          inversion H... (* 9 cases *)
          ** (* DLCUT CASE 1 *)
            symmetry in H4.
            apply app_eq_unit in H4.
            destruct H4.
            ***
              inversion H1...
              apply seqNtoSeq in H0;auto.
            ***
              inversion H1...
          ** (* DLCUT CASE 2 *)
            symmetry in H1.
            apply app_eq_nil in H1.
            destruct H1...
          ** (* DLCUT CASE 3 *)
            symmetry in H4.
            apply app_eq_nil in H4.
            destruct H4...
          ** (* DLCUT CASE 4 *)
            apply PProp_perm_sel in H2.
            destruct H2.
            ***
              do 2 destruct H1.
              assert(
                  n |--- B; x ++ [C]; (>> F) ->
                                      j  |--- B; N; (>> dual C) ->
                                                    |-- B; x ++ N; (>> F)) as DLCut.

              eapply CutH;eauto.
              solveFormLL.
              rewrite <- H2 in isNAM.
              eapply ForallAppInv1 in isNAM...
              solveIsFormL.
              eapply DLCut in H0;auto.
              eapply tri_tensor'.
              3:{
                apply seqNtoSeq in H7.
                exact H7. }
              2:{ exact H0. }
              rewrite <- H2; perm.
              eapply exchangeLCN;eauto.
            ***
              do 2 destruct H1.
              assert( n |--- B; x ++ [C]; (>> G) ->
                                          j |--- B; N; (>> dual C) ->
                                                       |-- B; x ++ N; (>> G)) as DLCut.

              eapply CutH;eauto.
              solveFormLL.
              rewrite <- H2 in isNAM.
              eapply ForallAppInv2 in isNAM...

              solveIsFormL.

              eapply DLCut in H0;auto.
              eapply tri_tensor'.
              3:{ exact H0. }
              2:{
                apply seqNtoSeq in H3.
                exact H3. }
              rewrite <- H2; perm.
              eapply exchangeLCN;eauto.
          ** (* DLCUT CASE 5 *)
            assert(
                n   |--- B; M ++ [C]; (>> F) ->
                                      j  |--- B; N; (>> dual C) ->
                                                    |-- B; M ++ N; (>> F)) as DLCut.

            eapply CutH;eauto.
            solveFormLL.
            eapply tri_plus1'...
          ** (* DLCUT CASE 6 *)
            assert(
                n   |--- B; M ++ [C]; (>> G) ->
                                      j  |--- B; N; (>> dual C) ->
                                                    |-- B; M ++ N; (>> G)) as DLCut.

            eapply CutH;eauto.
            solveFormLL.

            eapply tri_plus2'...
          ** (* DLCUT CASE 7 *)
            symmetry in H1.
            apply app_eq_nil in H1.
            destruct H1...
          ** (* DLCUT CASE 8 *)
            assert(
                n   |--- B; M ++ [C]; (> [P]) ->
                                      j  |--- B; N; (>> dual C) ->
                                                    |-- B; M ++ N; (> [P])) as ULCut.

            eapply CutH;eauto.
            apply ULCut in H0;auto.
            eapply tri_rel';auto.
          ** (* DLCUT CASE 9 *)
            assert(
                n   |--- B; M ++ [C]; (>> FX t) ->
                                      j  |--- B; N; (>> dual C) ->
                                                    |-- B; M ++ N; (>> FX t)) as DLCut.

            eapply CutH;eauto.
            solveFormLL.
            eapply tri_ex'...
        * (** Up Linear Cut *)
          clear CutW.
          inversion H... (* 10 cases *)
          ** (* ULCUT CASE 1 *)
            eapply tri_top'.
          ** (* ULCUT CASE 2 *)
            assert(
                n |--- B; M ++ [C]; (> M0) ->
                                    j |--- B; N; (>> dual C) ->
                                                 |-- B; M ++ N; > M0) as ULCut.
            eapply CutH;eauto.
            inversion isFL...
            eapply tri_bot'...
          ** (* ULCUT CASE 3 *)
            assert(
                n |--- B; M ++ [C]; (> F :: G :: M0) ->
                                    j |--- B; N; (>> dual C) ->
                                                 |-- B; M ++ N; > F :: G :: M0) as ULCut.
            eapply CutH;eauto.

            change (F :: G :: M0) with ([F ; G] ++ M0).
            apply ForallApp;inversion isFL...
            inversion H3...

            eapply tri_par'...
          ** (* ULCUT CASE 4 *)
            assert(
                n |--- B; M ++ [C]; (> F :: M0) ->
                                    j |--- B; N; (>> dual C) ->
                                                 |-- B; M ++ N; > F :: M0) as ULCutF.
            eapply CutH;eauto.
            solveIsFormL.
            solveFormLL.

            assert(
                n |--- B; M ++ [C]; (> G :: M0) ->
                                    j |--- B; N; (>> dual C) ->
                                                 |-- B; M ++ N; > G :: M0) as ULCutG.
            eapply CutH;eauto.
            solveIsFormL.
            solveFormLL.

            eapply tri_with'...
          ** (* ULCUT CASE 5 *)
            assert(
                n |--- B++[F]; M ++ [C]; (> M0) ->
                                         j |--- B++[F]; N; (>> dual C) ->
                                                           |-- B++[F]; M ++ N; > M0) as ULCut.
            eapply CutH;eauto.
            solveIsFormL.
            assert(Permutation (B ++ [F]) (F :: B) ) by perm.
            rewrite H1.
            inversion isFL...

            change (F :: B) with ([F] ++ B).
            apply ForallApp;inversion H4...

            apply ULCut in H5;auto.

            eapply tri_quest';auto.
            eapply weakeningGenN_rev;auto.
          ** (* ULCUT CASE 6 *)
            assert(
                n |--- B; (M ++ [F]) ++ [C]; (> M0) ->
                                             j |--- B; N; (>> dual C) ->
                                                          |-- B ; (M ++ [F]) ++ N; > M0) as ULCut.
            eapply CutH;eauto.
            apply LexpPosConc...

            solveIsFormL.
            solveIsFormL.

            apply ULCut in H0;auto.
            eapply tri_store';auto.

            refine (exchangeLC _ H0);perm.
            refine (exchangeLCN _ H6);perm.
          ** (* ULCUT CASE 7 *)
            assert(Permutation (M ++ [C]) (C::M)) by
                apply perm_takeit_3.

            (* just double hyp *)
            assert(Remove F (M ++ [C]) L') by auto.
            eapply Remove_Permutation_Ex in H4;eauto.
            destruct H4.
            apply Remove_inv_cons in H4.
            destruct H4.
            ***
              inversion H4...
              clear H1 H4.
              assert(positiveFormula C \/ release C) as PosOrRel.
              apply PositiveOrRelease;auto.

              destruct PosOrRel as [HCPos | HCRel].
              ****
                eapply PositiveDualRelease in HCPos;eauto.
                inversion H0;subst;try solve

                                       [match goal with
                                        | [ H: _ = (C ^), H': release (C ^) |- _ ] =>
                                          rewrite <- H in H'; inversion H'
                                        end].

                assert(
                    n0 |--- B; N ; (> [dual C]) ->
                                   S  n  |--- B; x; (>> C) ->
                                                    |-- B; N ++ x; (> [])) as UCut.

                eapply CutH;eauto;try lia.

                rewrite DualComplexity .
                rewrite <- ng_involutive;auto.
                apply ng_involutive.

                apply UCut in H10;auto.
                refine (exchangeLC _ H10);perm.

                apply Remove_Permute in H3;auto.
                rewrite perm_takeit_3 in H3.
                simpl in H3.
                apply Permutation_cons_inv in H3.
                refine (HeightGeqEx _ H7 _);auto.
              ****
                inversion H7;subst;try solve [inversion HCRel].

                assert(
                    S n0 |--- B; x ; (> [C]) ->
                                     j  |--- B; N; (>> dual C) ->
                                                   |-- B; x ++ N; (> [])) as UCut.

                eapply CutH;eauto.
                apply UCut in H0;auto.
                refine (HeightGeqEx _ H10 _); auto.

                apply Remove_Permute in H3;auto.
                rewrite perm_takeit_3 in H3.
                simpl in H3.
                apply Permutation_cons_inv in H3;auto.
            ***
              destruct H4.
              inversion H4...
              clear H1 H4.

              assert(
                  n |--- B; x0++[C] ; (>> F) ->
                                      j |--- B; N; (>> dual C) ->
                                                   |-- B; x0 ++ N; >> F) as DLCut.
              eapply CutH;eauto.

              apply Remove_Permute in H5;auto.

              solveIsFormL.
              apply Remove_Permute in H5;auto.

              change (F :: x0) with ([F] ++ x0) in H5.
              rewrite H5 in isNAM.
              apply ForallAppInv2 in isNAM...
              apply Remove_Permute in H5;auto.

              solveIsFormL.

              apply DLCut in H0;auto.
              eapply tri_dec1' with (F0:=F);auto.
              2:{ exact H0. }
              apply Remove_app_tail;auto.

              apply Remove_Permute in H3;auto.
              apply Remove_Permute in H6;auto.

              eapply exchangeLCN;[ |exact H7].
              rewrite H6 in H3.
              replace (F :: x0) with ([F] ++ x0) in H3;auto.
              rewrite  app_normalize_1 in H3.
              apply Permutation_cons_inv in H3.
              exact (symmetry H3).
          ** (* ULCUT CASE 8 *)
            assert(
                n |--- B; M ++ [C];  (>> F) ->
                                     j |--- B; N; (>> dual C) ->
                                                  |-- B; M ++ N; (>> F)) as DLCut.
            eapply CutH;eauto.

            solveIsFormL.

            apply DLCut in H0;auto.
            eapply tri_dec2' with (F0:=F);auto.
          ** (* ULCUT CASE 9 *)
            assert(
                n |--- B; M ++ [C];  (>> F) ->
                                     j |--- B; N; (>> dual C) ->
                                                  |-- B; M ++ N; (>> F)) as DLCut.
            eapply CutH;eauto.

            apply DLCut in H0;auto.
            eapply tri_dec3' with (F0:=F);auto.
          ** (* ULCUT CASE 10 *)
            apply tri_fx';auto;intros.
            assert(
                n |--- B; M ++ [C];  (> FX x :: M0) ->
                                     j |--- B; N; (>> dual C) ->
                                                  |-- B; M ++ N; (> FX x :: M0)) as DLCut.
            eapply CutH;eauto.

            solveIsFormL.
            solveFormLL.

            apply DLCut in H0;auto.

        * (** Up Cut *)
          inversion H... (* 7 cases *)
          ** (* UCUT CASE 1 *)
            inversion H0...
          ** (* UCUT CASE 2 *)
            inversion H0...
            ***
              rewrite app_nil_r.
              apply seqNtoSeq  in H5;auto.
            ***
              inversion H2.
          ** (* UCUT CASE 3 *)

            inversion H0...
            ***
              inversion compC.
              remember(complexity F).
              assert(
                  n  |--- B; M; (> F :: G :: L) ->
                                n0 |--- B; M0; (>> F ^) ->
                                               |-- B; M ++ M0; (> G :: L)) as HcutF.

              eapply CutW with (m:=n1);eauto; try lia.

              solveFormLL.
              inversion isFDC...
              rewrite H3 in isNAN.
              apply ForallAppInv1 in isNAN...

              solveIsFormL.
              inversion isFC...

              apply HcutF in H5;auto.
              apply seqtoSeqN in H5.
              destruct H5.

              remember(complexity G).
              assert(
                  x |--- B; M ++ M0; (> G :: L) ->
                                     n0 |--- B; N0; (>> G ^) ->
                                                    |-- B; (M ++ M0) ++ N0; > L) as HcutG.

              eapply CutW with (m:=n2);auto;try lia.
              solveFormLL.
              inversion isFDC...
              rewrite H3 in isNAN.
              apply ForallAppInv1 in isNAN...
              apply ForallApp...
              rewrite H3 in isNAN.
              apply ForallAppInv2 in isNAN...

              rewrite H3 in isFN.
              apply ForallApp...
              eapply ForallAppInv1. exact isFN.
              rewrite H3 in isFN.
              eapply ForallAppInv2. exact isFN.

              apply HcutG in H1;auto.
              eapply exchangeLC;[ |exact H1].
              rewrite H3; perm.

          ** (* UCUT CASE 4 *)
            inversion H0...
            ***
              inversion compC.
              remember(complexity F).
              assert(
                  n  |--- B; M; (> F :: L) ->
                                n0 |--- B; N; (>> F ^) ->
                                              |-- B; M ++ N; (> L)) as HcutF.

              eapply CutW with (m:=n1);auto; try lia.
              solveFormLL.
              inversion isFDC...
              apply HcutF in H6;auto.
            ***
              inversion compC.
              remember(complexity G).
              assert(
                  n  |--- B; M; (> G :: L) ->
                                n0 |--- B; N; (>> G ^) ->
                                              |-- B; M ++ N; (> L)) as HcutG.

              eapply CutW with (m:=n1);auto; try lia.
              solveFormLL.
              inversion isFDC...
              apply HcutG in H7;auto.
          ** (* UCUT CASE 5 *)

            inversion H0...
            assert(
                n  |--- B++ [F]; M ; (> L) ->
                                     S n0 |--- B; []; (>> ! F ^) ->
                                                      |-- B; M ; (> L)) as UCCut.

            eapply CutH with (m:=h) (C:=? F) (dualC:=! F^);eauto.

            apply UCCut in H5;auto.
            rewrite app_nil_r...
          **
            assert(
                n  |--- B; M ++ [C]; (> L) ->
                                     j |--- B; N; (>> dual C) ->
                                                  |-- B; M ++ N; (> L)) as ULCut.

            eapply CutH...

            apply ULCut in H7;auto.
          **

            inversion H0...
            inversion isFC .
            inversion isFDC .
            inversion compC.
            assert(
                n  |--- B; M; (> (FX t :: L)) ->
                              n0 |--- B; N; (>> (FX t) ^) ->
                                            |-- B; M++N; (> L)) as HCut.

            eapply CutW with (m:=w);eauto.
            remember (VAR con 0).
            assert(proper e).
            rewrite Heqe. auto with Ext_Eq.
            constructor.
            rewrite <- H13.
            eapply ComplexityUniformEq...

            apply HCut;auto.
        * (** Up Classic Cut *)
          inversion H1... (* 10 Cases *)
          ** (* UCCUT CASE 1 *)
            eapply tri_top'.
          ** (* UCCUT CASE 2 *)
            assert(
                n |--- B ++ [D]; M ; (> M0) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; M ; > M0) as UCCut.
            eapply CutH with (C:=C) (dualC:=dual C) ;eauto.
            solveIsFormL.
            eapply tri_bot'...
          ** (* UCCUT CASE 3 *)
            assert(
                n |--- B ++ [D]; M ; (> F :: G :: M0) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; M ; > F :: G :: M0) as UCCut.
            eapply CutH with (C:=C) (dualC:=dual C);eauto.
            inversion isFL...
            inversion H4...
            eapply tri_par'...
          ** (* UCCUT CASE 4 *)
            assert(
                n |--- B ++ [D]; M ; (> F :: M0) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; M ; > F :: M0) as UCCutF.
            eapply CutH with (C:=C) (dualC:=dual C);eauto.
            inversion isFL...
            inversion H5...
            assert(
                n |--- B ++ [D]; M ; (> G :: M0) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; M ; > G :: M0) as UCCutG.
            eapply CutH with (C:=C) (dualC:=dual C);eauto.
            inversion isFL...
            inversion H5...
            eapply tri_with'...
          ** (* UCCUT CASE 5 *)
            assert(
                n |--- (B ++ [F]) ++ [D]; M ; (> M0) ->
                                              j |--- B ++ [F]; []; (>> ! dual D) ->
                                                                   |-- B ++ [F]; M ; > M0) as UCCut.
            eapply CutH with (C:=C) (dualC:=dual C);eauto.
            solveIsFormL.
            inversion isFL...
            inversion H4...
            apply ForallApp...
            assert(n |--- (B ++ [F]) ++ [D]; M; (> M0)).
            refine (exchangeCCN _ H7);perm.

            apply UCCut in H;auto.
            eapply tri_quest';auto.
            eapply weakeningGenN_rev;auto.
          ** (* UCCUT CASE 6 *)
            assert(
                n |--- B ++ [D]; M ++ [F] ; (> M0) ->
                                            j |--- B ; []; (>> ! dual D) ->
                                                           |-- B ; M ++ [F] ; > M0) as UCCut.
            eapply CutH with (C:=C) (dualC:=dual C);eauto.
            apply LexpPosConc...
            inversion isFL...

            apply ForallApp...
            inversion isFL...
            eapply tri_store'...
          ** (* UCCUT CASE 7 *)
            destruct(PositiveAtomDec D).
            inversion H...
            assert(isFormulaL(F :: L')).

            apply Remove_Permute in H5;auto.
            rewrite <- H5;auto.
            inversion H3...
            assert(isNotAsyncL L').
            apply Remove_Permute in H5;auto.
            rewrite H5 in isNAM.
            inversion isNAM...

            (** Atomic Permutation *)
            assert(|-- B; L'; (> [F])).

            eapply AtomPerm with (P:=atom A) (j:=j) (n:=n) (h:=h) (w:=1)...
            unfold CutElimination.CutH; intros.
            eapply CutH with (m:=m);try assumption.

            rewrite DualComplexity  in compC.
            rewrite H0 in compC.
            inversion compC...

            destruct(PositiveOrRelease F).
            inversion H7;subst;try solve [inversion H11].
            apply Remove_Permute in H5...
            eapply exchangeLC.
            2:{ exact H17. }
            rewrite H5. perm.

            assert
              (
                n |--- B ++ [atom A]; L'; (> [F]) ->
                                          j |--- B; []; (>> ! perp A) -> |-- B; L'; (> [F])).
            eapply CutH with (C:=C) (dualC:=dual C) (N:=L')...
            solveIsFormL.

            eapply tri_dec1' with (F0:=F).
            exact H4. exact H5.
            eapply tri_rel'...

            assert
              (
                n |--- B ++ [D]; L'; (>> F) ->
                                     j |--- B; []; (>> ! dual D) -> |-- B; L'; (>> F)).
            eapply CutH with (C:=C) (dualC:=dual C);eauto...
            apply Remove_Permute in H5;auto.
            solveIsFormL.
            apply Remove_Permute in H5;auto.
            rewrite H5 in isNAM.
            inversion isNAM...
            apply Remove_Permute in H5;auto.
            solveIsFormL.
            eapply tri_dec1' with (F0:=F)...

          ** apply in_app_or in H5.
             inversion H5...

             destruct(PositiveAtomDec D).
             inversion H3...

             clear H3 H5.
             (** Atomic Permutation *)
             assert(|-- B; M; (> [F])).
             eapply AtomPerm with (P:=atom A) (j:=j) (n:=n) (h:=h) (w:=1)...
             unfold CutElimination.CutH; intros.
             eapply CutH with (m:=m);try assumption.

             rewrite DualComplexity  in compC.
             rewrite H0 in compC.
             inversion compC...
             solveIsFormL.
             eapply @AbsorptionClassic with (F:=F)...
             apply isFormulaIn in H;auto.
             ---
               assert
                 (
                   n |--- B ++ [D]; M; (>> F) ->
                                       j |--- B; []; (>> ! dual D) -> |-- B; M; (>> F)).
               eapply CutH with (C:=C) (dualC:=dual C);eauto...
               apply isFormulaIn in H;auto.
               solveIsFormL.
               eapply tri_dec2' with (F0:=F)...
             ---
               subst.
               inversion H2...
               assert(
                   n |--- B ++ [F]; M ; (>> F) ->
                                        S n0 |--- B ; []; (>> ! dual F) ->
                                                          |-- B ; M ; >> F) as DCCut.
               eapply CutH with (C:=C) (dualC:=dual C);eauto.

               rewrite H0 in isFDC.
               inversion isFDC...
               assert((? F) ^ = ! F ^).
               simpl. reflexivity.
               assert(C = ? F).
               rewrite ng_involutive.

               rewrite H.
               rewrite <- H0.
               rewrite <- ng_involutive;auto.

               rewrite H6 in isFC.
               inversion isFC...

               assert (|-- B; M; (>> F)).
               apply DCCut...
               apply seqtoSeqN in H.
               destruct H.
               assert(
                   n0 |--- B; [] ; (> [dual F]) ->
                                   x |--- B ; M; (>> F) ->
                                                 |-- B ; M ; > []) as UCut.
               eapply CutW;eauto...

               assert((? F) ^ = ! F ^).
               simpl. reflexivity.
               assert(C = ? F).
               rewrite ng_involutive.

               rewrite H3.
               rewrite <- H0.
               rewrite <- ng_involutive;auto.

               rewrite H6 in compC.
               inversion compC...
               symmetry.
               apply DualComplexity.

               apply ng_involutive.

               rewrite H0 in isFDC.
               inversion isFDC...
               assert((? F) ^ = ! F ^).
               simpl. reflexivity.
               assert(C = ? F).
               rewrite ng_involutive.

               rewrite H3.
               rewrite <- H0.
               rewrite <- ng_involutive;auto.

               rewrite H6 in isFC.
               inversion isFC...
               apply Forall_forall;intros y Hy; inversion Hy.
               apply UCut...

          **
            destruct(PositiveAtomDec D).
            inversion H...

            clear H.
            (** Atomic Permutation *)
            assert(|-- B; M; (> [F])).
            eapply AtomPerm with (P:=atom A) (j:=j) (n:=n) (h:=h) (w:=1)...
            unfold CutElimination.CutH; intros.
            eapply CutH with (m:=m);try assumption.

            rewrite DualComplexity  in compC.
            rewrite H0 in compC.
            inversion compC...

            ***
              destruct(NegativeAtomDec F).
              2:{ eapply AbsorptionTheory;eauto.
              }

              inversion H3...
              inversion H9...
              eapply tri_dec3'.
              exact H4. exact H5.
              eapply tri_init1'.
              apply in_app_or in H11.

              inversion H11...
              eapply tri_dec3'.
              exact H4. exact H5.
              eapply tri_init2'...
              inversion H...

              apply seqtoSeqN in H14.
              destruct H14.
              apply AbsorptionAtom in H6...
              apply seqNtoSeq in H6...
            ***
              assert
                (
                  n |--- B ++ [D]; M; (>> F) ->
                                      j |--- B; []; (>> ! dual D) -> |-- B; M; (>> F)).
              eapply CutH with (C:=C) (dualC:=dual C);eauto...
              eapply tri_dec3' with (F0:=F)...
          **
            eapply tri_fx';auto;intros.
            assert(
                n |--- B ++ [D]; M ; (> FX x :: M0) ->
                                     j |--- B ; []; (>> ! dual D) ->
                                                    |-- B; M; (> FX x :: M0)) as DCCut.
            eapply CutH with (C:=C) (dualC:=dual C);eauto...
            inversion isFL...
            inversion H6...
            solveIsFormL.
            apply DCCut...
        * (** Dw Classic Cut *)
          inversion H2... (* 9 Cases *)
          **
            apply tri_init1'.
          **
            apply in_app_or in H8.
            inversion H8...
            apply tri_init2'...
            subst.
            assert(IsPositiveAtom (atom A)) by constructor.
            contradiction.
          **
            eapply tri_one'.
          **
            clear CutW.
            assert(
                n |--- B ++ [D]; M0; (>> F) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; M0 ; >> F) as DCCutF.
            eapply CutH with (C:=C) (dualC:=dual C) ;eauto...
            solveFormLL.
            rewrite H5 in isNAM.
            apply ForallAppInv1 in isNAM...
            solveIsFormL.

            assert(
                n |--- B ++ [D]; N0; (>> G) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; N0 ; >> G) as DCCutG.
            eapply CutH with (C:=C) (dualC:=dual C) ;eauto...
            solveFormLL.
            rewrite H5 in isNAM.
            apply ForallAppInv2 in isNAM...

            solveIsFormL.
            apply DCCutF in H6;auto.
            apply DCCutG in H10;auto.

            refine(tri_tensor' H5 H6 H10).

          **
            assert(
                n |--- B ++ [D]; M; (>> F) ->
                                    j |--- B; []; (>> ! dual D) ->
                                                  |-- B; M ; >> F) as DCCut.
            eapply CutH with (C:=C) (dualC:=dual C) ;eauto.
            solveFormLL.
            eapply tri_plus1'...
          **
            assert(
                n |--- B ++ [D]; M; (>> G) ->
                                    j |--- B; []; (>> ! dual D) ->
                                                  |-- B; M ; >> G) as DCCut.
            eapply CutH with (C:=C) (dualC:=dual C) ;eauto.
            solveFormLL.
            eapply tri_plus2'...
          **
            assert(
                n |--- B ++ [D]; []; (> [F]) ->
                                     j |--- B; []; (>> ! dual D) ->
                                                   |-- B; [] ; > [F]) as UCCut.

            eapply CutH with (C:=C) (dualC:=dual C) ;eauto.
            inversion isFP...
            solveIsFormL.

            eapply tri_bang'...
          **
            assert(
                n |--- B ++ [D]; M; (> [P]) ->
                                    j |--- B; []; (>> ! dual D) ->
                                                  |-- B; M ; > [P]) as UCCut.

            eapply CutH with (C:=C) (dualC:=dual C) ;eauto.
            eapply tri_rel'...
          **

            assert(
                n |--- B ++ [D]; M ; (>> FX t) ->
                                     j |--- B ; []; (>> ! dual D) ->
                                                    |-- B ; M ; (>> FX t)) as DCCut.
            eapply CutH with (C:=C) (dualC:=dual C);eauto.
            inversion isFP...

            eapply tri_ex'...

  Qed.

  Theorem GeneralCut i j C dualC B L M N:
    dualC = dual C -> isFormula C -> isFormula (dualC) ->
    isNotAsyncL M -> isNotAsyncL N ->
    isFormulaL B -> isFormulaL M -> isFormulaL N -> isFormulaL L ->
    (i |--- B; M ; UP (C::L) ->
                   j |--- B; N ; DW dualC ->
                                 |-- B; M++N ; UP L).
  Proof with subst;auto.
    intros.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H10 as [w H10].
    specialize CutElimination;intros.
    assert((i |--- B; M ; UP (C::L) ->
                          j |--- B; N ; DW dualC ->
                                        |-- B; M++N ; UP L)) as CUT.
    eapply H11;eauto.
    apply CUT;auto.
  Qed.

  Theorem GeneralCut' :
    forall (C dualC : oo) (B L M N : list oo),
      dualC = C ^ ->
      isFormula C ->
      isFormula dualC ->
      isNotAsyncL M ->
      isNotAsyncL N ->
      isFormulaL B ->
      isFormulaL M ->
      isFormulaL N -> isFormulaL L ->
      (|-- B ; M ; (> C :: L)) ->
      (|-- B ; N ;  (>> dualC)) ->
      |-- B ;  (M ++ N) ; (> L).
    intros.
    apply seqtoSeqN in H8.
    apply seqtoSeqN in H9.
    CleanContext.
    eapply GeneralCut with (C:= C) (dualC := C ^);eauto.
  Qed.

  Theorem CutAndreoli i j C dualC B M N:
    dualC = dual C -> isFormula C -> isFormula (dualC) ->
    isNotAsyncL M -> isNotAsyncL N ->
    isFormulaL B -> isFormulaL M -> isFormulaL N ->
    (i |--- B; M ; DW C ->
                   j |--- B; N ; DW dualC ->
                                 |-- B; M++N ; UP []).
  Proof with subst;auto.
    intros.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H9 as [w H9].

    destruct(PositiveOrRelease C).
    -
      eapply PositiveDualRelease in H10;eauto.
      rewrite H in H8.
      inversion H8;subst;
        try solve[
              match goal with
              | [H : _ = C ^ |- _] => rewrite <- H in H10;inversion H10
              end].
      eapply exchangeLC with (LC:=N++M). perm.
      eapply GeneralCut; try assumption.
      2:{ exact H1. }
      2:{ exact H0. }
      apply ng_involutive.

      apply Forall_forall;intros x Hx.
      inversion Hx...
      exact H16.
      exact H7.
    -
      inversion H7;subst; try solve [inversion H10].
      eapply GeneralCut; try assumption.
      2:{ exact H0. }
      2:{ exact H1. }
      reflexivity.
      apply Forall_forall;intros x Hx.
      inversion Hx...
      exact H16.
      exact H8.
  Qed.
End CutElimination.


(*|
##############################
Teach Coq to check termination
##############################

:Link: https://stackoverflow.com/q/48173854
|*)

(*|
Question
********

Coq, unlike many others, accepts an optional explicit parameter, which
can be used to indicate the decreasing structure of a fixpoint
definition.

From Gallina specification, 1.3.4,

.. code-block:: coq

    Fixpoint ident params {struct ident0} : type0 := term0

defines the syntax. but from it, we've known that it must be an
identifier, instead of a general measure.

However, in general, there are recursive functions, that the
termination is not quite obvious, or it in fact is, but just difficult
for the termination checker to find a decreasing structure. For
example, following program interleaves two lists,
|*)

Require Import List. (* .none *)
Import ListNotations. (* .none *)
Fail Fixpoint interleave (A : Set) (l1 l2 : list A) : list A :=
  match l1 with
  | [] => []
  | h :: t => h :: interleave l2 t
  end. (* .fails *)

(*|
This function clearly terminates, while Coq just couldn't figure it
out. The reason is neither ``l1`` nor ``l2`` are decreasing every
cycle. But what if we consider a measure, defined to be ``length l1 +
length l2``? Then this measure clearly decreases every recursion.

So my question is, in the case of sophisticated situation, where code
is not straightforward to be organized in a termination checkable way,
how do you educate Coq and convince it to accept the fixpoint
definition?
|*)

(*|
Answer
******

You have multiple options and all of them boil down to structural
recursion in the end.

Preamble
========
|*)

Reset Initial. (* .none *)
From Coq Require Import List.
Import ListNotations.
Set Implicit Arguments.

(*|
Structural recursion
====================

Sometimes you can reformulate your algorithm in a structurally
recursive way:
|*)

Fixpoint interleave1 {A} (l1 l2 : list A) {struct l1} : list A :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | h1 :: t1, h2 :: t2 => h1 :: h2 :: interleave1 t1 t2
  end.

(*|
Incidentally, in some cases you can use a trick with nested ``fix``\
es -- see `this definition of Ackermann function
<https://stackoverflow.com/a/10303475/2747511>`__ (it wouldn't work
with just ``Fixpoint``).

``Program Fixpoint``
====================

You can use ``Program Fixpoint`` mechanism which lets you write your
program naturally and later prove that it always terminates.
|*)

From Coq Require Import Program Arith.

Program Fixpoint interleave2 {A} (l1 l2 : list A)
        {measure (length l1 + length l2)} : list A :=
  match l1 with
  | [] => l2
  | h :: t => h :: interleave2 l2 t
  end.
Next Obligation. simpl. rewrite Nat.add_comm. trivial with arith. Qed.

(*|
``Function``
============

Another option is to use the ``Function`` command which can be
somewhat limited compared to ``Program Fixpoint``. You can find out
more about their differences `here
<https://stackoverflow.com/q/44606245/2747511>`__.
|*)

From Coq Require Recdef.

Definition sum_len {A} (ls : (list A * list A)) : nat :=
  length (fst ls) + length (snd ls).

Function interleave3 {A} (ls : (list A * list A))
         {measure sum_len ls} : list A :=
  match ls with
  | ([], _) => []
  | (h :: t, l2) => h :: interleave3 (l2, t)
  end.
Proof.
  intros A ls l1 l2 h t -> ->. unfold sum_len.
  simpl. rewrite Nat.add_comm. trivial with arith.
Defined.

(*|
`Equations <http://mattam82.github.io/Coq-Equations/>`__ plugin
===============================================================

This is an external plugin which addresses many issues with defining
functions in Coq, including dependent types and termination.
|*)

From Equations Require Import Equations.

Equations interleave4 {A} (l1 l2 : list A) : list A
  by wf (length l1 + length l2) lt :=
  interleave4 nil l2 := l2;
  interleave4 (cons h t) l2 := cons h (interleave4 l2 t).
Next Obligation. rewrite Nat.add_comm. trivial with arith. Qed.

(*|
``Fix`` / ``Fix_F_2`` combinators
=================================

You can learn more about this (manual) approach if you follow the
links from `this question
<https://stackoverflow.com/q/42285235/2747511>`__ about ``mergeSort``
function. By the way, the ``mergeSort`` function can be defined
without using ``Fix`` if you apply the nested ``fix`` trick I
mentioned earlier. Here is a solution which uses ``Fix_F_2``
combinator since we have two arguments and not one like ``mergeSort``:
|*)

Definition ordering {A} (l1 l2 : list A * list A) : Prop :=
  length (fst l1) + length (snd l1) < length (fst l2) + length (snd l2).

Lemma ordering_wf' {A} : forall (m : nat) (p : list A * list A),
    length (fst p) + length (snd p) <= m -> Acc (@ordering A) p.
Proof.
  unfold ordering. induction m; intros p H; constructor; intros p'.
  - apply Nat.le_0_r, Nat.eq_add_0 in H as [-> ->].
    intros contra%Nat.nlt_0_r. contradiction.
  - intros H'. eapply IHm, Nat.lt_succ_r, Nat.lt_le_trans; eauto.
Defined.

Lemma ordering_wf {A} : well_founded (@ordering A).
Proof. now red; intro; eapply ordering_wf'. Defined.

(* it's in the stdlib but unfortunately opaque -- this blocks evaluation *)
Lemma destruct_list {A} (l : list A) :
  { x : A & {tl : list A | l = x :: tl} } + { l = [] }.
Proof.
  induction l as [|h tl]; [right | left]; trivial.
  exists h, tl. reflexivity.
Defined.

Definition interleave5 {A} (xs ys : list A) : list A.
  refine (Fix_F_2
            (fun _ _ => list A)
            (fun (l1 l2 : list A)
                 (interleave :
                    (forall l1' l2', ordering (l1', l2') (l1, l2) -> list A)) =>
               match destruct_list l1 with
               | inright _ => l2
               | inleft pf => let '(existT _ h (exist _ tl eq)) := pf
                              in h :: interleave l2 tl _
               end) (ordering_wf (xs, ys))).
  Proof.
    unfold ordering. rewrite eq, Nat.add_comm. auto.
  Defined.

(*|
Evaluation tests
================
|*)

Check eq_refl : interleave1 [1; 2; 3] [4; 5; 6] = [1; 4; 2; 5; 3; 6].
Check eq_refl : interleave2 [1; 2; 3] [4; 5; 6] = [1; 4; 2; 5; 3; 6].
Check eq_refl : interleave3 ([1; 2; 3], [4; 5; 6]) = [1; 4; 2; 5; 3; 6].
Check eq_refl : interleave4 [1; 2; 3] [4; 5; 6] = [1; 4; 2; 5; 3; 6].
Check eq_refl : interleave5 [1; 2; 3] [4; 5; 6] = [1; 4; 2; 5; 3; 6].

(*|
Exercise: what happens with this last check if you comment out
``destruct_list`` lemma?
|*)


(**

Definitions that are common to all chacha20 implementations. We expect
the following three variants of chacha20.

- An iterator that encrypts using the chacha20 cipher

- The HChaCha20 "hash" and the iterator for the xchacha20 cipher.

- A host endian variant of chacha20 keystream for use in csprg.

*)

Require Import Verse.

(**

First we define the underlying word type for the chacha20 primitive.

*)

Definition Word    := Word32.

(** ** Block

The block type is parameterised over the endianness as we need both
the standard little endian variant for the cipher and the host-endian
variant for use in the csprg.

*)

Definition BLOCK_SIZE := 16.
Definition KEY_SIZE   := 8.
Definition IV_SIZE    := 3.

Definition Block e := Array BLOCK_SIZE e Word.
Definition Key     := Array KEY_SIZE hostE Word.
Definition Counter := Word.
Definition IV   := Array IV_SIZE hostE Word.

(** ** Constants

Finally we have the constants that are used in the chacha20
algorithms.

*)

Definition C0 : constant Word := Ox "61:70:78:65".
Definition C1 : constant Word := Ox "33:20:64:6e".
Definition C2 : constant Word := Ox "79:62:2d:32".
Definition C3 : constant Word := Ox "6b:20:65:74".


Require Export CnfSpec.

Require Import List.
Require Import RatTheory.

Local Open Scope impure_scope.

Axiom next: forall {C}, (rupLCF C) * (list C) * solver_Input -> ?? (C + RatInput C).
Extract Constant next => "OracleRat.next_rat".

Definition unsatProver_msg: pstring := "UnsatProver.not_empty".

Definition unsatProver_loop_body (input: solver_Input) (f: ccnf): ?? option ccnf :=
      DO step <~ next ((mkNextInput f),input) ;;
      match step with
      | inl c =>  (* check that [next] has found a trivially UNSAT clause *)
         if isEmpty (rep c)
         then RET None
         else FAILWITH unsatProver_msg
      | inr ri => (* build a new CNF from the RAT bunch *)
          DO f' <~ learnRat ri ;;
          RET (Some f')
       end.
Extraction Inline unsatProver_loop_body.

Local Hint Resolve rep_sat.

Program Definition unsatProver input : forall f, ?? ~(exists m, csats f m) :=
  loop_until_None
     (unsatProver_loop_body input)
     (fun (f: ccnf) => exists m, csats f m) (* loop invariant *)
     .
Obligation 1.
  wlp_simplify.
  eapply isEmpty_correct; eauto.
Qed.


Require Import FcEtt.sigs.

Require Import FcEtt.imports.
Require Import FcEtt.tactics.

Require Import FcEtt.ett_ott.
Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_inf_cs.
Require Import FcEtt.ett_ind.
Require Import FcEtt.ett_par.

Require Import FcEtt.utils.

Module congruence
       (ext_weak : ext_weak_sig)
       (wf : fc_wf_sig)
       (weak : fc_weak_sig)
       (subst : fc_subst_sig)
       (ext_invert : ext_invert_sig).

Import ext_weak.
Import ext_invert.
Import wf weak subst.

Require Import FcEtt.fc_unique.
Module unique := fc_unique wf subst.
Import unique.

Require Import FcEtt.fc_invert.
Module invert := fc_invert wf weak subst.
Import invert.

Require Import FcEtt.erase.
Module erasem := erase wf weak subst ext_invert.
Import erasem.

Import FcEtt.erase_syntax.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* ------------------------------------------------------------- *)

Lemma congruence :
  (forall G a A, Typing G a A ->
           forall G1 G2 x A1 a1 a2 D,
             G = G2 ++ [(x, Tm A1)] ++ G1 ->
             Typing G1 a1 A1 ->
             DefEq G1 D a1 a2 A1 ->
             DefEq (map (tm_subst_tm_sort a1 x) G2 ++ G1)
                   D (tm_subst_tm_tm a1 x a) (tm_subst_tm_tm a2 x a)
                    (tm_subst_tm_tm a1 x A)) /\
  (forall G phi,     PropWff G phi       ->
           forall G1 G2 x A1 a1 a2 D,
             G = G2 ++ [(x, Tm A1)] ++ G1 ->
             Typing G1 a1 A1 ->
             DefEq G1 D a1 a2 A1 ->
             Iso (map (tm_subst_tm_sort a1 x) G2 ++ G1)
                    D (tm_subst_tm_constraint a1 x phi) (tm_subst_tm_constraint a2 x phi) ) /\
  (forall G D p1 p2, Iso G D p1 p2      -> True) /\
  (forall G D A B T,   DefEq G D A B T  -> True) /\
  (forall G,           Ctx G            -> True).
Proof.
  apply typing_wff_iso_defeq_mutual; try done.
  - intros G WFG _ G1 G2 x A1 a1 a2 D H0 H1 H2.
    simpl. eapply E_Refl. eapply E_Star.
    destruct (DefEq_regularity H2).
    eapply (fifth tm_substitution_mutual); eauto 2.
  - intros G x A WFG _ B G1 G2 x0 A1 a1 a2 D H1 H2 H3. subst.
    edestruct binds_cases as [ B1 | [B2 | B3]]; split_hyp; eauto 2.
    + replace (tm_subst_tm_tm a2 x0 (a_Var_f x)) with
      (tm_subst_tm_tm a1 x0 (a_Var_f x)).
      eapply (fourth tm_substitution_mutual); eauto 1.
      eapply E_Refl; eauto 1.
      eapply E_Var; eauto 1.
      autorewrite with lngen. reflexivity.
    + inversion H0. subst.
      rewrite tm_subst_tm_tm_var.
      rewrite tm_subst_tm_tm_var.
      eapply DefEq_weakening with (F:=nil)(G := G1); simpl; eauto 2.
      have CTX: Ctx (x0 ~ Tm A1 ++ G1) by eapply Ctx_strengthen; eauto.
      rewrite (tm_subst_fresh_1 _ H2 CTX); auto.
      eapply (fifth tm_substitution_mutual); eauto 1.
    + replace (tm_subst_tm_tm a2 x0 (a_Var_f x)) with
      (tm_subst_tm_tm a1 x0 (a_Var_f x)).
      eapply (fourth tm_substitution_mutual); eauto 1.
      eapply E_Refl; eauto 1.
      eapply E_Var; eauto 1.
      autorewrite with lngen. reflexivity.
  - (* pi *) intros L G rho A B K1 K2 K3 K4 G1 G2 x A1 a1 a2 D H2 H3 H4.
    simpl. subst.
    eapply (@E_PiCong2 (L \u singleton x)); eauto 2.
    + intros x0 Fr. assert (FrL: x0 `notin` L). auto.
    move: (K2 x0 FrL _ ([(x0, Tm A)] ++ G2) x _ _ _ _ eq_refl H3 H4) => h0.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm in h0.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm in h0.
    rewrite map_app in h0.
    replace (tm_subst_tm_tm a1 x (a_Var_f x0)) with (a_Var_f x0) in h0.
    replace (tm_subst_tm_tm a2 x (a_Var_f x0)) with (a_Var_f x0) in h0.
    eapply h0.
    rewrite tm_subst_tm_tm_var_neq. auto. auto.
    rewrite tm_subst_tm_tm_var_neq. auto. auto.
    eapply (DefEq_lc H4).
    eapply (DefEq_lc H4).
  - (* abs *)
    intros L G rho a A B H H0 H1 H2 RC G1 G2 x A1 a1 a2 D H3 H4 H5.
    subst. simpl.
    eapply (E_AbsCong (L \u singleton x \u fv_tm_tm_tm a1 \u fv_tm_tm_tm a2)); eauto 2.
    + intros x0 Fr. assert (FrL: x0 `notin` L). auto.
      move: (H0 x0 FrL _ ([(x0, Tm A)] ++ G2) x _ _ _ _ eq_refl H4 H5) => h0.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm in h0.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm in h0.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm in h0.
      replace (tm_subst_tm_tm a1 x (a_Var_f x0)) with (a_Var_f x0) in h0.
      replace (tm_subst_tm_tm a2 x (a_Var_f x0)) with (a_Var_f x0) in h0.
      eapply h0.
      rewrite tm_subst_tm_tm_var_neq. auto. auto.
      rewrite tm_subst_tm_tm_var_neq. auto. auto.
      eapply (DefEq_lc H5).
      eapply (DefEq_lc H5).
      eapply (DefEq_lc H5).
    + eapply (first tm_substitution_mutual _ _ _ H1); eauto 2.
    + intros x0 FrLx.
      have h0 := RC x0 ltac:(auto).
      have e1: a_Var_f x0 = tm_subst_tm_tm a1 x (a_Var_f x0); auto.
      * simpl.
        destruct eq_dec; try congruence.
        fsetdec.
      * rewrite e1.
        have lc1: lc_tm a1; try solve [apply Typing_lc in H4; destruct H4; eauto 2].
        rewrite -tm_subst_tm_tm_open_tm_wrt_tm; auto.
        inversion h0; subst.
        -- inversion h0; subst; clear h0.
           apply Rho_Rel; auto.
(*           apply tm_subst_tm_tm_lc_tm; auto. *)
        -- apply Rho_IrrRel; auto.
           inversion h0; subst; clear h0.
           apply tm_subst_tm_tm_fresh; auto.
    + intros x0 FrLx.
      have h0 := RC x0 ltac:(auto).
      have e1: a_Var_f x0 = tm_subst_tm_tm a2 x (a_Var_f x0); auto.
      * simpl.
        destruct eq_dec; try congruence.
        fsetdec.
      * rewrite e1.
        have lc1: lc_tm a2; try solve [apply DefEq_lc in H5 as [h1 [h2 h3]]; destruct H4; eauto 2].
        rewrite -tm_subst_tm_tm_open_tm_wrt_tm; auto.
        inversion h0; subst.
        -- inversion h0; subst; clear h0.
           apply Rho_Rel; auto.
(*           apply tm_subst_tm_tm_lc_tm; auto. *)
        -- apply Rho_IrrRel; auto.
           inversion h0; subst; clear h0.
           apply tm_subst_tm_tm_fresh; auto.
  - (* app rel *) intros G b a B A H K1 K2 K3 G1 G2 x A1 a1 a2 D H1 H2 H3.
    subst. simpl.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm.
    eapply E_AppCong; eauto 2.
    eapply K1; eauto 2.
    eapply (Typing_lc H2).
  - (* app irrel case *)
    intros G b B a A K0 K1 K2 K3 G1 G2 x A1 a1 a2 D H2 H3 H4. subst.
    simpl.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm.
    eapply E_IAppCong.
    eapply K1; eauto.
    fold tm_subst_tm_tm.
    eapply (first tm_substitution_mutual); eauto.
    eapply (DefEq_lc H4).
  - (* conv *)
    intros G a B A t H d H0 t0 H1 G1 G2 x A1 a1 a2 D H2 H3 H4.
    subst.
    move: (@H1 G1 G2 x A1 a1 a2 D eq_refl H3 H4) => h0.
    clear H1.
    move: (@H G1 G2 x A1 a1 a2 D eq_refl H3 H4) => h1.
    clear H.
    eapply E_EqConv. eauto.
    pose K := fourth tm_substitution_mutual _ _ _ _ _ d _ _ _ H3.
    eapply DefEq_weaken_available.
    apply K. auto.
  - (* cpi *)
    intros L G phi B t H p H0 G1 G2 x A1 a1 a2 D H1 H2 H3.
    subst. simpl.
    eapply (@E_CPiCong2 (L \u singleton x)).
    + eapply H0. eauto. eauto. eauto.
    + intros c Fr.
      assert (Frc : c `notin` L). auto.
      move: (@H c Frc G1 ([(c, Co phi)] ++ G2) x A1 a1 a2 D eq_refl H2 H3) => h0.
      rewrite tm_subst_tm_tm_open_tm_wrt_co in h0.
      rewrite tm_subst_tm_tm_open_tm_wrt_co in h0.
      rewrite map_app in h0.
      replace (tm_subst_tm_co a1 x (g_Var_f c)) with (g_Var_f c) in h0.
      replace (tm_subst_tm_co a2 x (g_Var_f c)) with (g_Var_f c) in h0.
      eapply h0.
      simpl. auto.
      simpl. auto.
      eapply (DefEq_lc H3).
      eapply (DefEq_lc H3).
  - (* cabs *)
    intros L G a phi B t H p H0 G1 G2 x A1 a1 a2 D H1 H2 H3.
    subst. simpl.
    eapply (E_CAbsCong (L \u singleton x)).
    + intros c Fr. assert (FrL: c `notin` L). auto.
      move: (@H c FrL _ ([(c, Co phi)] ++ G2) x _ _ _ _ eq_refl H2 H3) => h0.
      repeat (rewrite tm_subst_tm_tm_open_tm_wrt_co in h0).
      rewrite map_app in h0.
      repeat (replace (tm_subst_tm_co a1 x (a_Var_f x0)) with (a_Var_f x0) in h0).
      eapply h0.
      eapply (DefEq_lc H3).
      eapply (DefEq_lc H3).
      eapply (DefEq_lc H3).
    + eapply (second tm_substitution_mutual); eauto 1.
  - (* Capp *)
    intros G a1 B1 a b A t H d H0 G1 G2 x A1 a0 a2 D H1 H2 H3.
    subst. simpl.
    rewrite tm_subst_tm_tm_open_tm_wrt_co.
    eapply E_CAppCong with (a:=tm_subst_tm_tm a0 x a)(b:= tm_subst_tm_tm a0 x b); eauto 2.
    eapply (H _ _ x _ _ _ _ eq_refl H2 H3); eauto 2.
    fold tm_subst_tm_tm.
    eapply (fourth tm_substitution_mutual) in d; [idtac|apply H2|eauto].
    eapply DefEq_weaken_available in d.
    eauto.
    eapply (Typing_lc H2).
  - intros. simpl. subst G.
(*    move: (toplevel_to_const _ _ b) => h0.
    have CNil: Ctx [(x, Tm A)]. econstructor; auto.
    rewrite (tm_subst_fresh_2 _ h0 CNil). clear CNil. *)
    erewrite tm_subst_fresh_2.
    eapply E_Refl.
    eapply E_Const; eauto 2.
    eapply (fifth tm_substitution_mutual); eauto.
    eapply t. simpl. econstructor; eauto.
  - intros. simpl. subst G.
    move: (toplevel_closed b) => h0.
    move: (Typing_regularity h0) => h1.
    have CNil: Ctx [(x, Tm A)]. econstructor; auto.
    rewrite (tm_subst_fresh_2 _ h1 CNil). clear CNil.
    eapply E_Refl.
    eapply E_Fam; eauto 2.
    eapply (fifth tm_substitution_mutual); eauto.
  - intros G a b A t H t0 H0 t1 H1 G1 G2 x A1 a1 a2 D H2 H3 H4.
    simpl.
    pose K1 := H G1 G2 _ _ _ _ _ H2 H3 H4. clearbody K1. clear H.
    pose K2 := H0 _ _ _ _ _ _ _ H2 H3 H4. clearbody K2. clear H0.
    pose K3 := H1 _ _ _ _ _ _ _ H2 H3 H4. clearbody K3. clear H1.
    move: (DefEq_regularity K1) => wf1.
    move: (DefEq_regularity K2) => wf2.
    move: (DefEq_regularity K3) => wf3.
    simpl in K3.
    simpl in wf3.
    inversion wf1.
    inversion wf2.
    inversion wf3.
    subst.
    remember (tm_subst_tm_tm a1 x b) as b1.
    remember (tm_subst_tm_tm a2 x b) as b2.
    remember (tm_subst_tm_tm a1 x a) as a1'.
    remember (tm_subst_tm_tm a2 x a) as a2'.
    remember (tm_subst_tm_tm a1 x A) as A1'.
    remember (tm_subst_tm_tm a2 x A) as A2'.
    remember (map (tm_subst_tm_sort a1 x) G2 ++ G1) as G1'.
    assert (Iso G1' D (Eq a1' b1 A1') (Eq a2' b2 A1')).
    { eapply E_PropCong; eauto. }
    assert (Iso G1' D (Eq a2' b2 A1') (Eq a2' b2 A2')).
    { eapply E_IsoConv; eauto 2.
      eapply E_Wff; eauto 2.
      eapply E_Conv; eauto 2.
      eapply DefEq_weaken_available; eauto.
      eapply E_Conv; eauto 2.
      eapply DefEq_weaken_available; eauto.
    }
    eapply trans_iso. eapply H. auto.
Qed.

    Lemma map_map : forall a1 x G2,
        map erase_sort (map (tm_subst_tm_sort a1 x) G2) =
        map (tm_subst_tm_sort (erase a1) x) (map erase_sort G2).
    Proof.
      intros. induction G2.
      - simpl. auto.
      - simpl. destruct a.
        f_equal. f_equal.
        destruct s. simpl.
        rewrite subst_tm_erase_tm. auto.
        simpl. destruct (subst_tm_erase a1 x) as (_ & _ & _ & h).
        rewrite h. autorewcs. auto.
        auto.
    Qed.

Lemma an_congruence :
  forall G a A, AnnTyping G a A ->
           forall G1 x A1 g a1 a2 D,
             G = [(x, Tm A1)] ++ G1 ->
             AnnTyping G1 a1 A1 ->
             AnnTyping G1 a2 A1 ->
             AnnDefEq G1 D g a1 a2 ->
             exists g', AnnDefEq G1 D g'
                        (tm_subst_tm_tm a1 x a) (tm_subst_tm_tm a2 x a).
Proof.
  intros.
  move: (AnnTyping_erase H1) => EH1.
  move: (AnnDefEq_erase H3 H1) => EH2.
  move: (AnnTyping_erase H) => EH.
  subst G.
  assert (EQ: (erase_context ([(x, Tm A1)] ++ G1))  =
              ([(x, Tm (erase A1))] ++ erase_context G1)).
  { unfold erase_context. rewrite map_app.
    f_equal. }
  rewrite EQ in EH.
  have CTX: Ctx ([(x, Tm (erase A1))] ++ erase_context G1) by eauto.
  have CTX2: Ctx (erase_context G1) by eapply Ctx_strengthen; eauto.
  have ACTX2: AnnCtx G1 by eauto with ctx_wff.
  move: (AnnTyping_regularity H) => HA.
  move: (AnnTyping_erase HA) => EA. simpl in EA. simpl_env in EA.
  have TS: Typing (erase_context G1) a_Star a_Star
    by eauto.
  move: (first congruence _ _ _ EA _ nil _ _ _ _ _ eq_refl EH1 EH2) => CA.
  simpl in CA.
  destruct (fourth annotation_mutual _ _ _ _ _ CA) with (G0 := G1)
    as ( ga & a0 & b0 & A0  & E1 & E2 & E3 & DE1 & ATa0 & ATb0 )
  ; simpl; eauto 2.
  rewrite subst_tm_erase_tm in E1.
  rewrite subst_tm_erase_tm in E2.
  have Ta1: AnnTyping G1
                      (tm_subst_tm_tm a1 x a)
                      (tm_subst_tm_tm a1 x A) by
      eapply (AnnTyping_tm_subst); eauto.
  have Ta2: AnnTyping G1
                      (tm_subst_tm_tm a2 x a)
                      (tm_subst_tm_tm a2 x A) by
  eapply (AnnTyping_tm_subst); eauto.
  have Ta3: AnnTyping G1 (tm_subst_tm_tm a1 x A) a_Star.
  eapply (AnnTyping_regularity); eauto 1.
  have Ta4: AnnTyping G1 (tm_subst_tm_tm a2 x A) a_Star by
  eapply (AnnTyping_regularity); eauto.

  have DE2: exists g, AnnDefEq G1 D g  (tm_subst_tm_tm a1 x A) (tm_subst_tm_tm a2 x A).
  { eexists. eapply An_Trans2 with (a1 := a0).
    eapply An_EraseEq. eauto. eauto. eauto.
    eapply An_EraseEq. eauto. eapply AnnTyping_regularity; eauto. auto.
    eapply An_Refl. eauto.
    eapply An_Trans2 with (a1 := b0). eauto.
    eapply An_EraseEq. eauto. eauto. eauto.
    eapply An_EraseEq. eauto. eapply AnnTyping_regularity; eauto. auto. auto.
    eapply An_Refl. eauto. }
  destruct DE2 as (g1 & DEA1A2).

  clear DE1 ATa0 ATb0 E1 E2 E3 a0 b0 A0 ga.

  move: (first congruence _ _ _ EH _ nil _ _ _ _ _ eq_refl EH1 EH2) => CC.
  destruct (fourth annotation_mutual _ _ _ _ _ CC) with (G0 := G1)
    as ( ga & a0 & b0 & A0  & E1 & E2 & E3 & DE1 & ATa0 & ATb0 )
  ; simpl; eauto 2.
  rewrite subst_tm_erase_tm in E1.
  rewrite subst_tm_erase_tm in E2.
  rewrite subst_tm_erase_tm in E3.

  have DE3 : exists g, AnnDefEq G1 D g (tm_subst_tm_tm a1 x A) A0.
  { eexists. eapply An_EraseEq. eauto. eapply AnnTyping_regularity. eauto. eauto.
    eauto. }
  destruct DE3 as (g2 & DEA1A0).
  have DE4 : exists g, AnnDefEq G1 D g (tm_subst_tm_tm a2 x A) A0.
  { eexists. eapply An_Trans2 with (a1 := tm_subst_tm_tm a1 x A).
    eapply An_Sym; eauto. eauto. }
  destruct DE4 as (g3 & DEA2A0).

  eexists.
  eapply An_Trans2 with (a1 := a0).
  { eapply An_EraseEq; eauto 1.
    eapply AnnDefEq_weaken_available; eauto 2. }
  eapply An_Trans2 with (a1 := b0). eauto.
  { eapply An_EraseEq; eauto 1.
    eapply AnnDefEq_weaken_available; eauto 2.
    eapply An_Sym; eauto 2.
    eapply AnnTyping_regularity; eauto.
    eauto.
  }
  Unshelve.
Qed.

End congruence.


(* En este archivo se demuestra que la ejecución de
*  la acción sendBroadcast preserva los invariantes del sistema *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import MyList.
Require Import ListAuxFuns.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.
Require Import Semantica.

Section SendBroadcastInv.

Lemma SendBroadcastIsInvariant : forall (s s':System) (sValid:validstate s) (intt:Intent) (ic:iCmp) (maybeP:option Perm), pre_sendBroadcast intt ic maybeP s -> post_sendBroadcast intt ic maybeP s s' -> validstate s'.
Proof.
    intro.
    intro.
    intro.
    intro.
    intro.
    intro.
    intros.
    unfold validstate.
    unfold pre_sendBroadcast in H.
    unfold post_sendBroadcast in H0.
    destruct H0.
    unfold onlyIntentsChanged in H1.
    destruct_conj H1.
    assert (verified:= H10). clear H10.
    assert (H9 := H8). clear H8.

    unfold allCmpDifferent.
    split.
    intros.

    apply (inAppS'InAppS a1 s) in H8;auto.
    apply (inAppS'InAppS a2 s) in H10;auto.
    apply (inAppSameCmpId s sValid c1 c2 a1 a2);auto.

    unfold notRepeatedCmps.
    split.
    intros.
    apply (inAppS'InAppS a1 s) in H8;auto.
    apply (inAppS'InAppS a2 s) in H10;auto.
    apply (inAppSameCmp s sValid c a1 a2);auto.

    unfold notCPrunning.
    split.
    rewrite <-H5.
    destructVS sValid.
    auto.

    split.
    apply (delTmpRunS' s);auto.

    split.
    apply (cmpRunAppInsS' s);auto.

    split.
    apply (resContAppInstS' s);auto.

    split.
    apply (consistencyUnchanged s);auto.

    unfold notDupApp.
    split.
    rewrite <- H1.
    rewrite<-H2.
    destructVS sValid.
    auto.

    unfold notDupSysApp.
    split.
    rewrite <-H2.
    destructVS sValid.
    auto.

    split.
    apply (notDupPermS' s);auto.

    unfold allMapsCorrect.
    split.
    rewrite <-H2, <-H3, <-H4, <- H5, <-H6, <-H7, <-H9.
    repeat (split;auto; try mapcorrect sValid).

    split.
    apply (grantedPermsExistS' s);auto.

    unfold noDupSentIntents.
    intros.
    destruct H.
    destruct_conj H12.
    unfold addIntent in H0.
    destruct_conj H0.
    assert (H':=H0).
    specialize (H' i ic0 H8).
    assert (H'':=H0).
    specialize (H'' i' ic' H10).
    destruct H'.
    destruct H''.
    destructVS sValid.
    apply sentIntentsCorrectVS;auto.
    destruct H18.
    destruct H15.
    exists i, ic0.
    split;auto.
    rewrite H11.
    unfold createIntent in H19.
    rewrite H19.
    simpl.
    auto.

    destruct H''.
    destruct H16.
    destruct H15.
    exists i', ic'.
    split;auto.
    rewrite<- H11.
    unfold createIntent in H19.
    rewrite H19.
    simpl.
    auto.
    destruct H16, H18.
    split.
    rewrite<- H16;auto.
    rewrite H19;auto.
Qed.

End SendBroadcastInv.


Require Import Coq.Vectors.Vector
        Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Bool.Bvector
        Coq.Lists.List.

Require Import
        Fiat.Common.Tactics.CacheStringConstant
        Fiat.Computation.Decidable
        Fiat.Computation.FoldComp
        Fiat.QueryStructure.Automation.Common
        Fiat.QueryStructure.Automation.MasterPlan
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.BagADT
        Fiat.QueryStructure.Automation.IndexSelection
        Fiat.QueryStructure.Specification.SearchTerms.ListPrefix
        Fiat.QueryStructure.Automation.SearchTerms.FindPrefixSearchTerms
        Fiat.QueryStructure.Automation.QSImplementation.

Require Import
        Fiat.Examples.DnsServer.SimplePacket.

Definition DnsSchema :=
  Query Structure Schema
        [ relation sRRecords has
                   schema resourceRecordHeading
          where (fun t t' =>
                   (* Constraints on every pair of tuples: *)
                   (t!sNAME = t'!sNAME
                    -> RDataTypeToRRecordType (t!sRDATA) <> CNAME)
                   (* if a domain name is an alias, the CNAME record *)
                   (* is the only resource record in the table. *)
                   /\ (RDataTypeToRRecordType t!sRDATA = NS
                       -> RDataTypeToRRecordType t'!sRDATA <> NS
                       -> prefix (t!sNAME) (t'!sNAME)
                       -> t!sNAME = t'!sNAME)
        (* If the server delegates authority for a zone via a NS record *)
        (* Then any other (non-NS) records about that subzone have to be *)
        (* glue records, i.e. have the same label as the NS record.  *)
        )]
        enforcing [ ].


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Orders.
Import ListNotations.
Require Import Alphabet.

(** The terminal non-terminal alphabets of the grammar. **)
Module Type Alphs.
  Parameters terminal nonterminal : Type.
  Declare Instance TerminalAlph: Alphabet terminal.
  Declare Instance NonTerminalAlph: Alphabet nonterminal.
End Alphs.

(** Definition of the alphabet of symbols, given the alphabet of terminals
    and the alphabet of non terminals **)
Module Symbol(Import A:Alphs).

  Inductive symbol :=
    | T: terminal -> symbol
    | NT: nonterminal -> symbol.

  Program Instance SymbolAlph : Alphabet symbol :=
    { AlphabetComparable := {| compare := fun x y =>
        match x, y return comparison with
          | T _, NT _ => Gt
          | NT _, T _ => Lt
          | T x, T y => compare x y
          | NT x, NT y => compare x y
        end |};
      AlphabetFinite := {| all_list :=
        map T all_list++map NT all_list |} }.
  Next Obligation.
    destruct x; destruct y; intuition; apply compare_antisym.
  Qed.
  Next Obligation.
    destruct x; destruct y; destruct z; intuition; try discriminate.
    apply (compare_trans _ t0); intuition.
    apply (compare_trans _ n0); intuition.
  Qed.
  Next Obligation.
    intros x y.
    destruct x; destruct y; try discriminate; intros.
    rewrite (compare_eq t t0); now intuition.
    rewrite (compare_eq n n0); now intuition.
  Defined.
  Next Obligation.
    rewrite in_app_iff.
    destruct x; [left | right]; apply in_map; apply all_list_forall.
  Qed.

End Symbol.

(** A curryfied function with multiple parameters **)
Definition arrows_right: Type -> list Type -> Type :=
  fold_right (fun A B => A -> B).

Module Type T.
  Include Alphs <+ Symbol.

  (** [symbol_semantic_type] maps a symbols to the type of its semantic
     values. **)
  Parameter symbol_semantic_type: symbol -> Type.

  (** The type of productions identifiers **)
  Parameter production : Type.
  Declare Instance ProductionAlph : Alphabet production.

  (** Accessors for productions: left hand side, right hand side,
     and semantic action. The semantic actions are given in the form
     of curryfied functions, that take arguments in the reverse order. **)
  Parameter prod_lhs: production -> nonterminal.
  (* The RHS of a production is given in reversed order, so that symbols  *)
  Parameter prod_rhs_rev: production -> list symbol.
  Parameter prod_action:
    forall p:production,
      arrows_right
        (symbol_semantic_type (NT (prod_lhs p)))
        (map symbol_semantic_type (prod_rhs_rev p)).

  (** Tokens are the atomic elements of the input stream: they contain
     a terminal and a semantic value of the type corresponding to this
     terminal. *)
  Parameter token : Type.
  Parameter token_term : token -> terminal.
  Parameter token_sem :
    forall tok : token, symbol_semantic_type (T (token_term tok)).
End T.

Module Defs(Import G:T).

  (** The semantics of a grammar is defined in two stages. First, we
    define the notion of parse tree, which represents one way of
    recognizing a word with a head symbol. Semantic values are stored
    at the leaves.

      This notion is defined in two mutually recursive flavours:
    either for a single head symbol, or for a list of head symbols. *)
  Inductive parse_tree:
    forall (head_symbol:symbol) (word:list token), Type :=

  (** Parse tree for a terminal symbol. *)
  | Terminal_pt:
    forall (tok:token), parse_tree (T (token_term tok)) [tok]

  (** Parse tree for a non-terminal symbol.  *)
  | Non_terminal_pt:
    forall (prod:production) {word:list token},
      parse_tree_list (prod_rhs_rev prod) word ->
      parse_tree (NT (prod_lhs prod)) word

  (* Note : the list head_symbols_rev is reversed. *)
  with parse_tree_list:
    forall (head_symbols_rev:list symbol) (word:list token), Type :=

  | Nil_ptl: parse_tree_list [] []

  | Cons_ptl:
    forall {head_symbolsq:list symbol} {wordq:list token},
      parse_tree_list head_symbolsq wordq ->

    forall {head_symbolt:symbol} {wordt:list token},
      parse_tree head_symbolt wordt ->

      parse_tree_list (head_symbolt::head_symbolsq) (wordq++wordt).

  (** We can now finish the definition of the semantics of a grammar,
    by giving the semantic value assotiated with a parse tree. *)
  Fixpoint pt_sem {head_symbol word} (tree:parse_tree head_symbol word) :
    symbol_semantic_type head_symbol :=
    match tree with
    | Terminal_pt tok => token_sem tok
    | Non_terminal_pt prod ptl => ptl_sem ptl (prod_action prod)
    end
  with ptl_sem {A head_symbols word} (tree:parse_tree_list head_symbols word) :
    arrows_right A (map symbol_semantic_type head_symbols) -> A :=
    match tree with
    | Nil_ptl => fun act => act
    | Cons_ptl q t => fun act => ptl_sem q (act (pt_sem t))
    end.

  Fixpoint pt_size {head_symbol word} (tree:parse_tree head_symbol word) :=
    match tree with
      | Terminal_pt _ => 1
      | Non_terminal_pt _ l => S (ptl_size l)
    end
  with ptl_size {head_symbols word} (tree:parse_tree_list head_symbols word) :=
    match tree with
      | Nil_ptl => 0
      | Cons_ptl q t =>
         pt_size t + ptl_size q
    end.
End Defs.


Require Export CatSem.PCF_order_comp.RPCF_syntax_rep.
Require Export CatSem.PCF_order_comp.RPCF_rep_hom.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section weak_init.

Variable R : PCFPO_rep.

(** the initial morphism STS -> R *)

Fixpoint init V t (v : PCF V t) :
    R (retype (fun t0 => type_mor R t0) V) (type_mor R t) :=
  match v in PCF _ t return
        R (retype (fun t0 => type_mor R t0) V) (type_mor R t) with
  | Var t v => rweta (RMonad_struct := R) _ _ (ctype _ v)
  | App _ _ u v => app (PCFPO_rep_struct := R) _ _ _ (init u, init v)
  | Lam _ _ v => abs (PCFPO_rep_struct := R) _ _ _
        (rlift R
            (@der_comm TY (type_type R) (fun t => type_mor R t) _ V )
                   _ (init v))
  | Rec _ v => rec (PCFPO_rep_struct := R) _ _ (init v)
  | Bottom _  => bottom (PCFPO_rep_struct := R) _ _ tt
  | Const _ y => match y in Consts t1 return
                    R (retype (fun t2 => type_mor R t2) V) (type_mor R t1)
                 with
                 | Nats m => nats (PCFPO_rep_struct := R) m (retype _ V) tt
                 | succ => Succ (PCFPO_rep_struct := R) _ tt
                 | condN => CondN (PCFPO_rep_struct := R) _ tt
                 | condB => CondB (PCFPO_rep_struct := R) _ tt
                 | zero => Zero (PCFPO_rep_struct := R) _ tt
                 | ttt => tttt (PCFPO_rep_struct := R) _ tt
                 | fff => ffff (PCFPO_rep_struct := R) _ tt
                 | preds => Pred (PCFPO_rep_struct := R) _ tt
                 end
  end.

Obligation Tactic := idtac.

Lemma init_lift (V : IT) t (y : PCF V t) W (f : V ---> W) :
   (init (y //- f)) =
      rlift R (retype_map f) _ (init y).
Proof.
  intros V t y.
  induction y;
  simpl;
  intros.

  unfold rlift.
  assert (H':=rmod_hom_rmkl
      (bottom (PCFPO_rep_struct := R) t)).
      simpl in H'; auto.

  destruct c.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (nats n (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (tttt (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (ffff (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (Succ (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (Pred (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (Zero (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (CondN (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (CondB (PCFPO_rep_struct := R))).
      simpl in H'; auto.

  assert (H:=rlift_rweta R).
  simpl in H.
  rewrite H. auto.

  unfold rlift; simpl.
  rewrite IHy1.
  rewrite IHy2.
  assert (H':=rmod_hom_rmkl
      (app (PCFPO_rep_struct := R) s t)).
      simpl in H'.
  unfold rlift.
  rewrite <- H'.
  auto.

  unfold rlift.
  assert (H':=rmod_hom_rmkl
      (abs (PCFPO_rep_struct := R) t s)).
      simpl in H'.
  rewrite <- H'.
  apply f_equal.
  rewrite IHy.
  unfold rlift.
  simpl.
  rew (rklkl R).
  rew (rklkl R).
  simpl.
  apply (rkl_eq R).
  simpl.
  clear dependent y.
  intros r z.
  destruct z as [r z];
  simpl.
  assert (H2:=retakl R).
  simpl in H2.
  rewrite H2.
  rewrite H2.
  simpl.

  destruct z as [r z | ];
  simpl; auto.

  assert (Ht:=rlift_rweta R).
  simpl in Ht.
  rewrite Ht. auto.

  rewrite IHy.
  assert (H':=rmod_hom_rmkl
      (rec (PCFPO_rep_struct := R) t)).
      simpl in H'.
  unfold rlift.
  rewrite <- H'.
  auto.
Qed.

Lemma init_subst V t (y : PCF V t) W (f : SM_ipo _ V ---> PCFE W):
      init (y >>= f) =
        rkleisli (RMonad_struct := R)
           (SM_ind (V:= retype (fun t => type_mor R t)  V)
                   (W:= R (retype (fun t => type_mor R t)  W))
              (fun t v => match v with
                          | ctype t p => init (f t p)
                          end)) _ (init y).
Proof.
  intros V t y.
  induction y.
  simpl. intros.
  rerew (rmhom_rmkl (bottom t (PCFPO_rep_struct := R))).

  destruct c.
  simpl. intros.
  rerew (rmhom_rmkl (nats n (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (tttt (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (ffff (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (Succ (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (Pred (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (Zero (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (CondN (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (CondB (PCFPO_rep_struct := R))).

  simpl. intros.
  rew (retakl R).

  simpl; intros W f.
  rewrite IHy1.
  rewrite IHy2.
  rerew (rmhom_rmkl (app s t (PCFPO_rep_struct := R))).

  simpl; intros W f.
  assert (H := IHy _ (sshift (P:=PCFEM) t f)).
  simpl in *.
  rerew (rmhom_rmkl (abs t s (PCFPO_rep_struct := R))).
  apply f_equal.
  assert (H1:=rlift_rkleisli (M:=R)).
  simpl in H1.
  rewrite H1.
  transitivity
( (rlift R (a:=retype (fun t0 : TY => type_mor R t0) (opt t W))
   (b:=opt (type_mor R t) (retype (fun t0 : TY => type_mor R t0) W))
            (@der_comm _ _ _ _ _ )) (type_mor R s)
      (init (y >>= sshift_ (P:=PCFEM) (W:=W) f))).
  repeat apply f_equal.
  apply subst_eq.
  intros.
  rewrite shift_shift.
  auto.

  rewrite H.
  simpl.
  rew (rkleisli_rlift (M:=R)).
  apply (rkl_eq R).
  clear dependent y.
  simpl.
  intros t0 z.
  destruct z as [t0 z];
  simpl.
  destruct z as [t0 z | ];
  simpl.
  unfold inj.
  generalize (f t0 z).
  clear dependent z.
  intro z.
  assert (H := init_lift z (some t (A:=W))).
  rewrite lift_rename in H.
  simpl in H.
  rewrite H.
  rew (rlift_rlift R).
  apply (rlift_eq R).
  simpl.
  intros t1 y.
  destruct y;
  auto.

  rew (rlift_rweta R).

  simpl; intros W f.
  rewrite IHy.
  rerew (rmhom_rmkl (rec t (PCFPO_rep_struct := R))).
Qed.

Lemma init_eval V t (v v' : PCF V t) :
     eval v v' -> init v <<< init v'.
Proof.
  intros V t v v' H.
  induction H.
  unfold substar.
  assert (H3:= beta_red (PCFPO_rep_struct := R)).

  assert (H2 := H3 _ _ _ (rlift R
      (a:=retype (fun t0 : TY => type_mor R t0) (opt s V))
         (b:=opt (type_mor R s) (retype (fun t0 : TY => type_mor R t0) V))
         (@der_comm _ _ _ _ _) (type_mor R t) (init M))).
  assert (H4:=H2 (init N)).
  simpl in *.
  apply (IRel_eq_r H4).
  unfold Rsubstar.
  rew (rlift_rkleisli (M:=R)).
  assert (H':=init_subst M
      (SM_ind (V:=(opt s V))(W:=PCFEM V)
  ((fun (t0 : TY) (x0 : opt s V t0) =>
    match x0 in (opt _ _ r) return (PCF V r) with
    | some t1 v0 => Var (V:=V) (t:=t1) v0
    | none => N
    end)))).
  simpl in *.
  apply (eq_trans_2 H').
  apply (rkl_eq R).
  simpl.
  intros t0 z;
  destruct z as [t0 z];
  simpl.
  opt.

  assert (H:=CondN_t (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=CondN_f (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=CondB_t (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=CondB_f (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=Succ_red (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=Zero_t (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=Zero_f (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=Pred_Succ (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=Pred_Z (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.

  assert (H:=Rec_A (PCFPO_rep_struct := R)).
  simpl in *.
  apply H.
Qed.

Lemma init_eval_star V t (y z : PCF V t) :
  eval_star y z -> init y <<< init z.
Proof.
  intros V t y z H.
  induction H.
  apply init_eval;
  auto.
  simpl.
  apply (PO_mor_monotone
      (app (PCFPO_rep_struct := R) s t
         (retype (fun t => type_mor R t) V))).
  simpl.
  constructor.
  auto.
  reflexivity.
  simpl.
  apply (PO_mor_monotone
      (app (PCFPO_rep_struct := R) s t
         (retype (fun t => type_mor R t) V))).
  simpl.
  constructor.
  reflexivity.
  auto.

  simpl.
  apply (PO_mor_monotone
      (abs (PCFPO_rep_struct := R) s t
         (retype (fun t => type_mor R t) V))).
  simpl.
  apply (rlift R (@der_comm _ _ (fun t0 => type_mor R t0) _ _ )).
  auto.
  simpl.
  apply (PO_mor_monotone
      (rec (PCFPO_rep_struct := R) t
         (retype (fun t => type_mor R t) V))).
  simpl.
  auto.
Qed.

Lemma init_mono c t (y z : PCFE c t):
   y <<< z -> init y <<< init z.
Proof.
  intros c t y z H.
  induction H.
  reflexivity.
  transitivity (init y);
  auto.
  apply init_eval_star;
  auto.
Qed.

Program Instance init_car_pos :
forall c : TY -> Type,
ipo_mor_struct
  (a:=retype_ipo (fun t : TY => type_mor R t) (PCFE c))
  (b:=R (retype (fun t : TY => type_mor R t) c))
  (fun t y => match y with
     | ctype _ p => init  p
     end).
Next Obligation.
Proof.
  intros c t.
  unfold Proper;
  red.
  simpl.
  intros y z H.
  induction H.
  apply init_mono;
  auto.
Qed.

Definition init_c:
(forall c : ITYPE TY,
  (RETYPE_PO (fun t : TY => type_mor R t)) (PCFEM c) --->
  R ((RETYPE (fun t : TY => type_mor R t)) c)) :=
  fun c => Build_ipo_mor (init_car_pos c).

Program Instance init_rmon_s:
  gen_RMonad_Hom_struct (P:=PCFEM) (Q:=R)
    (G1:=RETYPE (fun t => type_mor R t))
    (G2:=RETYPE_PO (fun t => type_mor R t))
    (NNNT1 (fun t => type_mor R t)) init_c.
Next Obligation.
Proof.
  simpl.
  intros c t z.
  destruct z as [t z];
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V W f t z.
  destruct z as [t z];
  simpl.
  assert (H:=init_subst z f).
  simpl in *.
  transitivity
  ((rkleisli (RMonad_struct := R)(a:=retype (fun t : TY => type_mor R t) V)
       (b:=retype (fun t : TY => type_mor R t) W)
       (SM_ind (V:=retype (fun t : TY => type_mor R t) V)
          (W:=R (retype (fun t : TY => type_mor R t) W))
          (fun (t : type_type R)
             (v : retype (fun t0 : TY => type_mor R t0) V t) =>
           match
             v in (retype _ _ t0)
             return ((R (retype (fun t1 : TY => type_mor R t1) W)) t0)
           with
           | ctype t0 p => init (f t0 p)
           end))) (type_mor R t) (init z)).
           auto.
  apply (rkl_eq R).
  simpl.
  clear dependent z.
  clear t.
  intros t z.
  destruct z as [t z];
  simpl.
  auto.
Qed.

Definition initM : gen_RMonad_Hom PCFEM R
    (G1:=RETYPE (fun t => type_mor R t))
    (G2:=RETYPE_PO (fun t => type_mor R t))
    (NNNT1 (fun t => type_mor R t)) :=
Build_gen_RMonad_Hom init_rmon_s.

Obligation Tactic := simpl; intros; repeat elim_unit; auto.

Program Instance initR_s :
        PCFPO_rep_Hom_struct (P:=PCFE_rep)(R:=R)
        (f:=fun t => type_mor R t)
        (fun _ => eq_refl) initM.

Definition initR : PCFPO_rep_Hom PCFE_rep R :=
        Build_PCFPO_rep_Hom initR_s.

End weak_init.


(*|
#####################################
Lemma about ``list`` and ``rev list``
#####################################

:Link: https://stackoverflow.com/q/56860962
|*)

(*|
Question
********

Trying to prove the following lemma I got stuck. Usully theorems about
lists are proven using induction, but I don't know where to move next.
|*)

Require Import List. (* .none *)
Import ListNotations. (* .none *)
Lemma reverse_append : forall (T : Type) (h : T) (t : list T),
    h :: t = rev t ++ [h] -> t = rev t.
Proof.
  intros. induction t.
  - simpl. reflexivity.
  - simpl. simpl in H. (* .unfold *)
Admitted. (* .none *)

(*|
Answer
******

Main answer
===========

Before you start proving your theorem, you should try to *thoroughly*
understand what your theorem says. Your theorem is simply wrong.

Counterexample: ``2 :: [1;2] = rev [1;2] ++ [2]``, but ``[1;2]`` is
not a palindrome.

Full proof:
|*)

Require Import List.
Import ListNotations.

Lemma reverse_append_false :
  ~(forall (T : Type) (h : T) (t : list T),
       h :: t = rev t ++ [h] -> t = rev t).
Proof.
  intros H. specialize (H nat 2 [1;2] eq_refl). inversion H.
Qed.

(*|
----

Minor issues
============

``rev(t)`` should be just ``rev t``. Just an aesthetic point, but
probably you should get yourself more familiar to writing in
functional programming style.

    Usually theorems about lists are proven using induction

This is a pretty naive statement, though technically correct. There
are so many ways to do induction on a value, and choosing the
induction that works best is a crucial skill. To name a few:

- Induction on the list
- Induction on the *length* of the list

  - arises quite frequently when dealing with ``rev`` and other
    functions that preserve length
  - `Example <https://stackoverflow.com/a/18760596/4595904>`__

- If simple induction doesn't work, consider a custom induction scheme

  - `nat_ind2 <https://stackoverflow.com/a/56356131/4595904>`__
|*)


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 3 *)

Require Import Frap Pset3Sig.

Set Implicit Arguments.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

Lemma assumptionsHold_sound : forall state prs (st : state) pm,
    (forall x b, pm $? x = Some b
               -> match prs $? x with
                  | Some pr => pr st <-> b = true
                  | None => False
                  end)
  -> forall asms, assumptionsHold pm asms = true
  -> assumptionsAccurate prs asms st.
Proof.
  induct asms; simplify; propositional.

  cases (assertionHolds pm a); simplify; try equality.
  unfold assertionHolds, assertionAccurate in *.
  cases a; simplify.
  cases (pm $? AssumedPredicate); try equality.
  cases b.
  cases AssumedToBe; try equality.
  apply H in Heq0.
  cases (prs $? AssumedPredicate); propositional.
  cases AssumedToBe; try equality.
  apply H in Heq0.
  cases (prs $? AssumedPredicate); propositional.
  apply H.
  assumption.

  cases (assertionHolds pm a); simplify; equality.
Qed.

Lemma applyRule_sound : forall state (doIt : state -> state -> Prop)
                               prs x b st st' r pm pm',
  (forall x b, pm $? x = Some b
               -> match prs $? x with
                  | Some pr => pr st <-> b = true
                  | None => False
                  end)
  -> (forall x b, pm' $? x = Some b
                  -> match prs $? x with
                     | Some pr => pr st' <-> b = true
                     | None => False
                     end)
  -> applyRule pm pm' r $? x = Some b
  -> ruleAccurate prs doIt r
  -> doIt st st'
  -> match prs $? x with
     | Some pr => pr st' <-> b = true
     | None => False
     end.
Proof.
  unfold applyRule; simplify.
  cases r.
  cases (assumptionsHold pm Assumptions).
  cases (AssumedToBe Conclusion).

  cases (x ==v AssumedPredicate Conclusion); simplify.
  invert H1.
  unfold ruleAccurate in H2; simplify.
  apply H2 in H3.
  unfold assertionAccurate in H3.
  rewrite Heq0 in H3.
  cases (prs $? AssumedPredicate Conclusion); propositional.
  eapply assumptionsHold_sound.
  eassumption.
  assumption.
  apply H0; assumption.

  cases (x ==v AssumedPredicate Conclusion); simplify.
  invert H1.
  unfold ruleAccurate in H2; simplify.
  apply H2 in H3.
  unfold assertionAccurate in H3.
  rewrite Heq0 in H3.
  cases (prs $? AssumedPredicate Conclusion); propositional.
  eapply assumptionsHold_sound.
  eassumption.
  assumption.
  apply H0; assumption.

  apply H0; assumption.
Qed.

Lemma applyRules_sound' : forall state (doIt : state -> state -> Prop)
  (prs : fmap var (state -> Prop)) x b st st' pm,
  (forall x b, pm $? x = Some b
       -> match prs $? x with
          | Some pr => pr st <-> b = true
          | None => False
          end)
  -> doIt st st'
  -> forall rs pm', (forall r, In r rs -> ruleAccurate prs doIt r)
  -> applyRules pm pm' rs $? x = Some b
  -> (forall x b, pm' $? x = Some b
                  -> match prs $? x with
                     | None => False
                     | Some pr => pr st' <-> b = true
                     end)
  -> match prs $? x with
     | None => False
     | Some pr => pr st' <-> b = true
     end.
Proof.
  induct rs; simplify.

  apply H3.
  assumption.

  eapply IHrs; simplify.
  apply H1.
  propositional.
  eassumption.
  eapply applyRule_sound.
  apply H.
  eassumption.
  eassumption.
  apply H1; propositional.
  assumption.
Qed.

Theorem applyRules_sound : forall state (doIt : state -> state -> Prop)
  (prs : fmap var (state -> Prop)) x b st st' rs pm,
  (forall r, In r rs -> ruleAccurate prs doIt r)
  -> (forall x b, pm $? x = Some b
       -> match prs $? x with
          | Some pr => pr st <-> b = true
          | None => False
          end)
  -> applyRules pm $0 rs $? x = Some b
  -> doIt st st'
  -> match prs $? x with
     | None => False
     | Some pr => pr st' <-> b = true
     end.
Proof.
  simplify.
  eapply applyRules_sound'.
  eassumption.
  eassumption.
  eassumption.
  eassumption.
  simplify.
  equality.
Qed.

Theorem predicate_abstraction_simulates : forall pc state action
  (pc0 : pc) (st0 : state)
  (actionOf : pc -> action -> pc -> Prop)
  (doAction : action -> state -> state -> Prop)
  (pa : predicate_abstraction state action),
  predicate_abstraction_sound doAction pa
  -> simulates (paR pa)
               (actionSys pc0 st0 actionOf doAction)
               (predicate_abstract pc0 actionOf pa).
Proof.
  constructor; simplify.

  propositional; subst.
  exists (pc0, $0); propositional.
  constructor; simplify.
  equality.

  invert H1.
  invert H0.
  exists (pc2, match pa.(Rules) $? act with
               | None => $0
               | Some rs => applyRules pm $0 rs
               end); propositional.
  constructor; simplify.
  unfold predicate_abstraction_sound in H.
  cases (Rules pa $? act); simplify; try equality.
  eapply applyRules_sound.
  simplify.
  eapply H.
  eassumption.
  eassumption.
  eassumption.
  assumption.
  assumption.

  constructor; assumption.
Qed.

(* Optional part: using predicate abstraction for another example *)

Import Program2 ZArith.

Definition tr := {|AssumedPredicate := "np = npo";
                   AssumedToBe := true|}.
Definition fa := {|AssumedPredicate := "np = npo";
                   AssumedToBe := false|}.

Definition establish := [{|Assumptions := []; Conclusion := tr |}].
Definition preserve := [{|Assumptions := [tr]; Conclusion := tr |};
                         {|Assumptions := [fa]; Conclusion := fa |}].
Definition falsify := [{|Assumptions := [tr]; Conclusion := fa |}].

Definition locked := {|AssumedPredicate := "locked";
                       AssumedToBe := true|}.
Definition unlocked := {|AssumedPredicate := "locked";
                         AssumedToBe := false|}.
Definition take_lock := [{|Assumptions := []; Conclusion := locked |}].
Definition release_lock := [{|Assumptions := []; Conclusion := unlocked |}].
Definition preserve_lock := [{|Assumptions := [locked]; Conclusion := locked |};
                              {|Assumptions := [unlocked]; Conclusion := unlocked |}].
Definition while_false := [{|Assumptions := [fa]; Conclusion := locked |};
                            {|Assumptions := [tr; locked]; Conclusion := locked |}].

Definition sys_pa : predicate_abstraction state action := {|
  Predicates := $0 $+ ("np = npo", fun st => st.(NP) = st.(NPO))
                   $+ ("locked", fun st => st.(HasLock) = true);
  Rules := $0 $+ (LockOK, preserve ++ take_lock)
              $+ (AssignA, establish ++ preserve_lock)
              $+ (IfFalse, preserve ++ preserve_lock)
              $+ (IfTrue, preserve ++ preserve_lock)
              $+ (UnlockOK, preserve ++ release_lock)
              $+ (IncA, falsify ++ preserve_lock)
              $+ (WhileFalse, while_false)
              $+ (WhileTrue, preserve ++ preserve_lock)
|}.

Opaque Zplus.

Theorem sys_ok : forall np npo,
  invariantFor (sys np npo) (fun st => fst st = Unlock2 -> (snd st).(HasLock) = true).
Proof.
  simplify.
  eapply invariant_weaken.
  eapply invariant_simulates.
  eapply predicate_abstraction_simulates with (pa := sys_pa).

  unfold predicate_abstraction_sound; simplify.
  cases act; simplify; invert H; unfold ruleAccurate, assertionAccurate in *; simplify; propositional; subst;
    simplify; unfold assertionAccurate in *; simplify; propositional;
    invert H1; simplify; propositional; equality || (try linear_arithmetic).

  model_check_infer.

  simplify.
  invert H.
  simplify.
  propositional; subst; invert H1; simplify; try equality.
  specialize (H3 "locked" true); simplify.
  cases (HasLock st); propositional; equality.
Qed.