(* This file is part of the Linear Logic  formalization in Coq: https://github.com/meta-logic/coq-ll *)

(** ** Focused System Meta-theory
In this file we prove several invertibility lemmas for the focused system.
 *)

(*Add LoadPath "../" .  *)
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export LL.SequentCalculiBasicTheory.
Require Import LL.Eqset.

Set Implicit Arguments.

Module FLLMetaTheory (DT : Eqset_dec_pol).

  Module Export Sys :=  SqBasic DT.
  Ltac EquivPosCase H IH m L Hinv :=
    match goal with
      [_ : AsynchronousF _ = false |- _] =>
      apply IH with(m:=L_weight L) in Hinv;
        auto using (fun n m => eq_ind _ _ (Nat.le_add_r m n) _ (Nat.add_comm m n));
      simpl;eapply tri_store;auto
    end.

  #[export] Hint Rewrite Neg2pos Ng_involutive : core .
  #[export] Hint Constructors Asynchronous : core .
  #[export] Hint Constructors IsNegativeAtom : core .
  #[export] Hint Resolve l_nil l_sin l_cos : core .
  #[export] Hint Unfold Lexp_weight Dual_LExp : core .
  (*Hint Constructors Release. *)
  #[export] Hint Constructors NotAsynchronous : core .
  #[export] Hint Resolve wt_refl wt_symm wt_trans : core .
  (* Hint Constructors PosOrPosAtom. *)
  (*Hint Constructors NotPosOrPosAtom.
  Hint Resolve exp_weight_inv. *)
  #[export] Hint Unfold Exp_weight : core .

  Theorem EquivAuxBot : forall B  L L' M ,  |-F- B ; M ; UP (L ++ L') -> |-F- B ; M ;  UP (L ++ [Bot] ++ L').
  Proof with solveF.
    intros.
    remember (L_weight L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .
    induction w as [| w' IH] using strongind ; intros M B L' L H Hw  ;  destruct L as [|l] ...

    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl;simpl in H;inversion Hw'; inversion H;subst;solveF;
        try(
            match goal with [|- |-F- _ ; _ ; UP (?l :: _) ] =>
                            let solve_tac1 := (apply tri_store;solveF; apply IH with (m:= L_weight  L);solveF;try lia ) in
                            match l with
                            | Perp _ => solve_tac1
                            | Atom _ => solve_tac1
                            | 1   => solve_tac1
                            | 0   => solve_tac1
                            | _ ** _ => solve_tac1
                            | _ ⊕ _ => solve_tac1
                            | ! _  => solve_tac1
                            | E{ _ }   => solve_tac1
                            | Bot => apply tri_bot;apply IH with (m:= L_weight  L);solveF;try(lia)
                            | ? _ => apply tri_quest;apply IH with (m:= L_weight  L);solveF;try(lia)
                            end
            end ) .
      ++ (* par *)
        inversionF H ...
        apply IH  with (L:= F :: G :: L) (m:= (Exp_weight  F) + (Exp_weight G) + L_weight L) in H6 ...  autounfold. lia.
      ++(* with *)
        inversion H...
        apply IH with (L:= F :: L) (m:= (Exp_weight  F) + L_weight  L) in H7;autounfold;try(lia) ...
        apply IH with (L:= G :: L) (m:= (Exp_weight  G) + L_weight  L) in H8;autounfold;try(lia) ...
      ++ (* forall *)
        inversion H...
        simpl; eapply tri_fx;auto; intro x. eapply IH with (L:=Subst FX x  :: L) ...
        rewrite <- subs_weight_weak with (x:=x).  lia.
  Qed.

  Theorem EquivAuxWith : forall B  L L' M F G ,
      |-F- B ; M ; UP (L ++ [F] ++ L') ->
                   |-F- B ; M ; UP (L ++ [G] ++ L') ->
                                |-F- B ; M ;  UP (L ++ [F & G] ++ L').
  Proof with solveF .
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .
    induction w as [| w' IH] using strongind  ; intros  M B L' L H H' Hw  ;  destruct L as [|l] ...
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl;simpl in H;inversion Hw' ;inversionF H;solveF;subst;
        try(
            match goal with [|- |-F- _ ; _ ; UP (?l :: _) ] =>
                            let solve_tac1 := (inversionF H'; apply tri_store;solveF; apply IH with (m:= L_weight  L);auto;try lia ) in
                            match l with
                            | 1   => solve_tac1
                            | 0   => solve_tac1
                            | _ ** _ => solve_tac1
                            | _ ⊕ _ => solve_tac1
                            | ! _  => solve_tac1
                            | E{ _ }   => solve_tac1
                            | Atom _ => solve_tac1
                            | Perp _ => solve_tac1
                            | Bot => inversion H';solveF;subst; apply tri_bot; apply IH with (m:= L_weight  L);auto
                            end end ) .
      ++ (* par *)
        inversion H;solveF;inversion H';solveF;subst; apply tri_par ...
        eapply IH with (L:= F0 :: G0 :: L) (m:= Exp_weight(F0) + Exp_weight(G0) +  L_weight L) ...
        lia.
      ++ (* with *)
        inversion H ...
        inversion H' ...
        apply tri_with .
        eapply IH with (L:= F0 :: L) (m:= Exp_weight(F0) + L_weight L) ...
        autounfold ; lia.
        eapply IH with (L:= G0 :: L) (m:= Exp_weight(G0) + L_weight L) ...
        autounfold ; lia.
      ++  (* quest *)
        inversion H ...
        inversion H';subst ...
        apply tri_quest.
        eapply IH with   (m:= L_weight L) ...
        lia.
      ++ (* forall  *)
        inversion H ...
        inversion H' ...
        assert(forall x, |-F- B; M; UP (((Subst FX x) ::L) ++ [F & G] ++ L')) as Hp.
        intro.
        generalize(H4 x);intros; generalize(H5 x);intros.
        eapply IH with (m:=  Exp_weight  (Subst FX x) + L_weight  L ) ...
        rewrite <- subs_weight_weak with (x:=x).  lia ...
        apply tri_fx ...
  Qed.

  Theorem EquivAuxPar : forall B  L L' M F G  n,  n |-F- B ; M ; UP (L ++ [F ; G] ++ L') -> |-F- B ; M ;  UP (L ++ [F $ G] ++ L').
  Proof with solveF .
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l] ...
    + simpl. simpl in H.
      eapply tri_par;auto.
      eapply AdequacyTri1;eauto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;inversion Hw' ;inversionF H;solveF;
        try(
            match goal with [|- |-F- _ ; _ ; UP (?l :: _) ] =>
                            let solve_tac1 := apply tri_store;solveF; eapply IH  with (m:=  L_weight L) ;eauto;try lia in
                                                  match l with
                                                  | 1   => solve_tac1
                                                  | 0   => solve_tac1
                                                  | _ ** _ => solve_tac1
                                                  | _ ⊕ _ => solve_tac1
                                                  | ! _  => solve_tac1
                                                  | E{ _ }   => solve_tac1
                                                  | Atom _ => solve_tac1
                                                  | Perp _ => solve_tac1
                                                  | Bot => apply tri_bot ; eapply IH  with (m:=  L_weight L);eauto
                                                  | Par _ _ => apply tri_par ;
                                                               eapply IH  with (L:= F0 :: G0 :: L) (m:= Exp_weight F0 + Exp_weight G0 +  L_weight L);eauto;simpl;lia
                                                  | ? _ => apply tri_quest; eapply IH  with (m:=  L_weight L);eauto; lia
                                                  end end ) .
      ++ (* with *)
        apply IH  with (L:= F0 :: L) (m:=  Exp_weight F0 + L_weight L) in H8;autounfold;try(lia);auto.
        apply IH  with (L:= G0 :: L) (m:=  Exp_weight G0 + L_weight L) in H9;autounfold;try(lia);auto.
      ++ (* forall *)
        assert(forall x, |-F- B; M; UP (((Subst FX x) ::L) ++ [F $ G] ++ L')) as Hp.
        intro.
        generalize(H5 x);intros.
        eapply IH with (m:=  exp_weight(FX unit tt) + L_weight L ) ;eauto.
        simpl.
        rewrite <- subs_weight_weak with (x:=x). auto.
        simpl. eapply tri_fx;auto;intro.
  Qed.

  #[export] Hint Resolve AsyncEqNeg : core .
  Theorem EquivAuxSync : forall B  L L' M  F ,  ~ Asynchronous F ->  |-F- B ; M ++ [F] ; UP (L ++ L') -> |-F- B ; M ;  UP (L ++ [F] ++ L').
  Proof with solveF .
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind; intros   M   B  L'  L  H1 Hw; destruct L as [|l] ...
    + simpl in Hw. (* Hw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;inversion Hw';inversionF H1;subst;solveF;

        try(
            match goal with
              [ H : |-F- _; (_ ++ [?F]) ++ [?G]; UP (?L ++ ?L') |- |-F- _ ; _ ; UP ( ?G :: ?L  ++ ?F :: ?L')] =>
              assert (Hch:  (M ++ [F]) ++ [G] =mul=  (M ++ [G]) ++ [F]) by solve_permutation;
              rewrite Hch in H;
              apply IH  with (m:=  L_weight L) in H;
                auto using (fun n m => eq_ind _ _ (Nat.le_add_r m n) _ (Nat.add_comm m n))
            end).
      ++ (* bot *)
        apply tri_bot.
        apply IH    with (m:=  L_weight L);auto.
      ++ (* PAR *)
        apply IH  with (L:= F0 :: G :: L) (m:= Exp_weight F0 + Exp_weight G +  L_weight L) in H7;try(simpl; lia);auto.
      ++ (* WITH *)
        apply IH  with (L:= F0 :: L) (m:= Exp_weight F0 + L_weight L) in H8;try(autounfold;simpl; lia);auto.
        apply IH  with (L:= G :: L) (m:= Exp_weight G + L_weight L) in H9;try(autounfold;simpl; lia);auto.
      ++ (* quest *)
        apply IH  with  (m:= L_weight L) in H6;try(simpl; lia);auto.
      ++ (* forall *)
        assert(forall x, |-F- B; M; UP (((Subst FX x) ::L) ++ [F] ++ L')) as Hp.
        intro.
        generalize(H5 x);intros.
        eapply IH with (m:=  exp_weight(FX unit tt) + L_weight L ) ;eauto.
        rewrite <- subs_weight_weak with (x:=x). auto.
        eapply tri_fx;auto.
  Qed.

  Theorem EquivAuxQuest : forall B  L L' M  n F,  n |-F- B ++ [F] ; M ; UP (L ++ L') ->  |-F- B ; M ;  UP (L ++ [? F] ++ L').
  Proof with solveF .
    intros.
    remember (L_weight L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l] ...
    + simpl. simpl in H.
      eapply tri_quest;auto.
      eapply AdequacyTri1;eauto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl in *;inversion Hw';inversionF H;solveF;
        try(
            match goal with
              [ Hx : _ |-F- _ ++ [?F]; _ ++ [_]; UP (?L ++ ?L') |- _] =>
              apply IH  with (m:=  L_weight L) in Hx;
                auto using (fun n m => eq_ind _ _ (Nat.le_add_r m n) _ (Nat.add_comm m n))
            end).
      ++ (* bot *)
        apply tri_bot.
        apply IH  with (m:=  L_weight L) in H5;
          auto using (fun n m => eq_ind _ _ (Nat.le_add_r m n) _ (Nat.add_comm m n)).
      ++ (* par *)
        apply IH  with (L:=F0 :: G :: L)  (m:=  Exp_weight F0 + Exp_weight G + L_weight L) in H7;
          auto using (fun n m => eq_ind _ _ (Nat.le_add_r m n) _ (Nat.add_comm m n)).
        simpl. lia.
      ++ (* with *)
        apply IH  with (L:=F0 :: L)  (m:=  Exp_weight F0 + L_weight L) in H8;auto;try(autounfold;simpl;lia).
        apply IH  with (L:=G :: L)  (m:=  Exp_weight G + L_weight L) in H9;auto;try(autounfold;simpl;lia).
      ++ (* quest *)
        apply tri_quest.
        eapply IH  with   (m:=  L_weight L);auto;try(autounfold;simpl;lia).
        MReplace ( (B ++ [F0]) ++ [F]) ((B ++ [F]) ++ [F0]) ...
        eauto.
      ++ (* FORALL *)
        assert(forall x, |-F- B ; M; UP (((Subst FX x) ::L) ++ [? F] ++ L')) as Hp.
        intro.
        generalize(H5 x);intros.
        eapply IH with (m:=  exp_weight(FX unit tt) + L_weight L ) ;simpl;eauto.
        rewrite <- subs_weight_weak with (x:=x). auto.
        eapply tri_fx;auto.
  Qed.

  Theorem EquivAuxTop : forall B  L L' M ,  |-F- B ; M ;  UP (L ++ [Top] ++ L').
  Proof with solveF .
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind;  intros M B L' L Hw  ;  destruct L as [|l] ...
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl in *;inversion Hw'; solveF;
        try(apply tri_store;solveF;auto  ; apply IH  with (m:=  L_weight L);try(lia);auto).
      ++ (* bot *)
        apply tri_bot.
        apply IH  with (m:=  L_weight L);try(lia);auto.
      ++ (*  PAR *)
        apply tri_par.
        eapply IH  with  (L:= F :: G :: L) (m:= Exp_weight F + Exp_weight G + L_weight L);
          auto; try(rewrite H2);simpl;autounfold;try(lia).
      ++ (* with *)
        apply tri_with.
        eapply IH  with  (L:= F :: L) (m:= Exp_weight F + L_weight L);
          auto; try(rewrite H2);simpl;autounfold;try(lia).
        eapply IH  with  (L:= G :: L) (m:= Exp_weight G + L_weight L);
          auto; try(rewrite H2);simpl;autounfold;try(lia).
      ++ (* quest *)
        apply tri_quest.
        apply IH  with (m:=  L_weight L);try(lia);auto.
      ++ (* forall *)
        apply tri_fx.
        intro.
        apply IH with (L:= Subst FX x :: L) (m:= exp_weight  (FX unit tt) + L_weight L);simpl; try( rewrite Hw');auto.
        rewrite <- subs_weight_weak with (x:=x). auto.
  Qed.

  Theorem EquivAuxForAll : forall B  L L' M   FX, (forall x,  |-F- B ; M ; UP (L ++ [Subst FX x]++ L')) ->  |-F- B ; M ;  UP (L ++ [F{FX}] ++ L').
  Proof with solveF .
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros M B L' L H Hw ;  destruct L as [|l] ...
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + caseLexp l ; inversion Hw as [Hw'];solveF;
        try(
            match goal with [|- |-F- _ ; _ ; UP (?l :: _) ] =>
                            let solve_tac1 := assert(Hp: forall x,  |-F- B; M ++ [l]; UP (L ++ [Subst FX x] ++ L')) by
                                    (intro;generalize (H x); intro Hp'; try(inversionF Hp';solveF);
                                     apply IH  with (m:= L_weight  L) in Hp;auto);
                                              apply tri_store;subst;solveF; simpl in Hw';inversion Hw';
                                                                                apply IH  with (m:= L_weight  L) in Hp;try(lia);auto in
                                                                                match l with
                                                                                | Atom _ => solve_tac1
                                                                                | Perp _ => solve_tac1
                                                                                | 1   => solve_tac1
                                                                                | 0   => solve_tac1
                                                                                | Plus _ _ => solve_tac1
                                                                                | _ ** _ => solve_tac1
                                                                                | ! _  => solve_tac1
                                                                                | E{ _ }  => solve_tac1
                                                                                end
            end) .
      ++ (* bot *)
        assert(Hp: forall x,  |-F- B; M; UP (L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst ...
        apply IH  with (m:= L_weight  L) in Hp; try(apply tri_bot);try(lia);auto.
      ++ (* par *)
        assert(Hp: forall x,  |-F- B; M; UP ( F :: G :: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst ... auto.
        apply IH  with (L:= F :: G :: L) (m:= Exp_weight  F + Exp_weight G + L_weight  L) in Hp ...
        subst. simpl in Hw';inversion Hw';auto ...
        lia.
      ++ (* With *)
        assert(Hp1: forall x,  |-F- B; M; UP ( F:: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp1'; inversion Hp1'; subst ... auto.
        assert(Hp2: forall x,  |-F- B; M; UP ( G:: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp2'; inversion Hp2'; subst ... auto.
        inversion Hw'. subst.
        apply IH  with (L:= F :: L) (m:= Exp_weight F + L_weight L) in Hp1;try(lia); subst;autounfold;simpl;try(lia); auto.
        apply IH  with (L:= G :: L) (m:= Exp_weight G + L_weight L) in Hp2;try(lia); subst;autounfold;simpl;try(lia); auto.
      ++  (* quest *)
        assert(Hp: forall x,  |-F- B ++ [F]; M; UP (L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst;LexpContr... auto.
        apply IH  with (m:= L_weight  L) in Hp;auto.
        subst;inversion Hw';lia.
      ++ (* forall *)
        subst.
        assert(Hp: forall x x', |-F- B; M; UP ((Subst FX0 x') :: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst ... auto.
        apply tri_fx;intro.
        apply IH with (L:= Subst FX0 x :: L) (m:= Exp_weight  (Subst FX0  x) + L_weight  L) ...
        simpl in Hw';inversion Hw'. autounfold.
        rewrite <- subs_weight_weak with (x:=x). auto.
  Qed.

  Theorem EquivUpArrow : forall B L L' M n, n |-F- B ; M ; UP L -> L =mul= L' ->|-F- B ; M ;  UP L'.
  Proof with solveF .
    intros.
    remember (L_weight L) as w.
    generalize dependent n .
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind;  intros ;  destruct L as [|l] ...
    + assert (L'= []) by( apply emp_mult;auto) ...
      subst.
      eapply AdequacyTri1;eauto.
    + inversion Heqw.
      generalize(exp_weight0  l);intros.
      lia.
    + assert (L'= []) by( apply emp_mult;auto).
      subst.
      eapply AdequacyTri1;eauto.
    + destruct L'.
      (* H0 is inconsisten *)
      apply DestructMulFalse in H0. contradiction.
      apply DestructMSet2 in H0 as Heq.
      destruct Heq as [Heq | Heq].
      ++ (* case 1 *)
        destruct Heq;subst.
        inversionF H;subst;try(simpl in Heqw; inversion Heqw; subst;simpl;try(lia)).
        +++ (* bottom *)
          eapply IH with (L' :=L') in H6;auto.
        +++ (* par *)
          eapply IH with (L' := F::G::L') in H6;auto.
          simpl. autounfold. lia.
        +++ (* with *)
          eapply IH with (m:= L_weight (F::L)) (L:= F ::L) (L' := F :: L') in H7;auto.
          eapply IH with (m:= L_weight (G::L)) (L := G :: L) (L' := G :: L') in H8;auto.
          simpl. autounfold. lia.
          simpl. autounfold. lia.
        +++  (* quest *)
          eapply IH with (m:= L_weight L) (L' :=L') in H6;auto.
          lia.
        +++  (* store *)
          eapply IH with (m:= L_weight L) (L' :=L') in H8;auto.
          generalize(exp_weight0  a);intro.
          lia.
        +++ (* forall *)
          eapply tri_fx;auto.
          intro.
          generalize (H6 x);intro.
          eapply IH with (m:= Exp_weight (Subst FX x) + L_weight L) (L' := Subst FX x :: L') in H1;auto.
          simpl. rewrite <- subs_weight_weak with (x:=x). auto.
      ++ (* case 2 *)
        destruct Heq as [L1 [L2 [L1' [L2' Heq]]]].
        destruct Heq as [Heq [Heq1 Heq2]];subst.
        inversion H;subst.
        +++ (* top *)
          eapply EquivAuxTop with (L:= a :: L1').
        +++ (* bottom *)
          eapply IH with (m:= L_weight(L1 ++ a :: L2))(L:=L1 ++ a :: L2) (L' := [a] ++ L1' ++ L2') in H5 ...
          simpl in H5.
          eapply AdequacyTri2 in H5. destruct H5.
          apply EquivAuxBot with (L:= a :: L1') ...
          apply AdequacyTri1 in H1 ...
          simpl in Heqw. inversion Heqw. auto ...
        +++ (* par *)
          eapply IH with (m:= L_weight(F :: G :: L1 ++ a :: L2))
                         (L:=F :: G :: L1 ++ a :: L2)
                         (L' := [a] ++ L1' ++ [F ; G] ++ L2') in H5  ...
          eapply AdequacyTri2 in H5. destruct H5.
          eapply EquivAuxPar with (L:= a :: L1');eauto.
          simpl in Heqw. inversion Heqw. auto.
          simpl. rewrite Nat.add_assoc. auto ...
        +++ (* with *)
          eapply IH with (m:= L_weight(F :: L1 ++ a :: L2))
                         (L:=F :: L1 ++ a :: L2)
                         (L' := [a] ++ L1' ++ [F ] ++ L2') in H6 ...
          eapply IH with (m:= L_weight(G :: L1 ++ a :: L2))
                         (L:=G :: L1 ++ a :: L2)
                         (L' := [a] ++ L1' ++ [G ] ++ L2') in H7 ...

          apply EquivAuxWith with (L := a :: L1'); simpl;auto .
          unfold Exp_weight; lia.
          unfold Exp_weight; lia.
        +++ (* quest *)
          eapply IH with (m:= L_weight(L1 ++ a :: L2))(L:=L1 ++ a :: L2) (L' := [a] ++ L1' ++ L2') in H5 ...
          eapply AdequacyTri2 in H5. destruct H5.
          eapply EquivAuxQuest with (L := a :: L1');eauto.
          simpl in Heqw. inversion Heqw. lia.
        +++ (* copy *)
          eapply IH with (m:= L_weight(L1 ++ a :: L2))(L:=L1 ++ a :: L2) (L' := [a] ++ L1' ++ L2') in H7 ...
          eapply EquivAuxSync with (L:=a :: L1');eauto.
          simpl in Heqw. rewrite L_weightApp in Heqw. simpl in Heqw.
          rewrite L_weightApp.
          generalize(exp_weight0  l);intro.
          simpl; lia.
        +++ (* forall *)
          assert(forall x, |-F- B; M; UP ((a :: L1' ) ++ [Subst FX x] ++ L2')) ...
          intro x.
          eapply IH with (m:= L_weight(Subst FX x :: L1 ++ a :: L2)) (L:=Subst FX x :: L1 ++ a :: L2)  ...
          inversion Heqw. simpl.
          rewrite <- subs_weight_weak with (x:=x) ...
          eapply EquivAuxForAll with (L:= a::L1') ...
  Qed.

  Theorem EquivUpArrow2 : forall B L L' M , |-F- B ; M ; UP L -> L =mul= L' ->|-F- B ; M ;  UP L'.
    intros.
    apply AdequacyTri2 in H.
    destruct H.
    eapply EquivUpArrow in H;eauto.
  Qed.

  (* Weakening *)
  Theorem TriWeakening : forall B L F X n, n |-F- B ; L ; X -> n |-F- B ++ [F] ; L ; X.
  Proof with solveF .
    intros.
    generalize dependent L .
    generalize dependent B .
    generalize dependent F .
    generalize dependent X .
    generalize dependent n .
    induction n using strongind;intros ...
    + (* Base *)
      inversionF H ...
      apply trih_init2 with (B' := B' ++ [F]) ... eauto.
    + (* Inductive *)
      inversion H0;subst ...
      ++ eapply H in H3;auto.
         eapply H in H4;auto.
         eapply trih_tensor;eauto.
      ++  eapply H with (B := B ++ [F0]) (F:=F) in H2 ...
          eapply trih_quest ...
          MReplace ( (B ++ [F]) ++ [F0]) ( (B ++ [F0]) ++ [F]) .
          auto.
      ++ eapply H in H4 ...
         eapply trih_dec1 with (F:=F0);eauto.
      ++ eapply H with (F:=F) in H4;auto.
         rewrite H3. rewrite H3 in H4.
         eapply trih_dec2 with (F:=F0);eauto.
      ++ eapply H in H2;auto.
         eapply trih_ex;eauto.
  Qed.

  (* Up and Down relation *)
  Lemma UpExtension: forall B M L F n, LexpPos (M ++ [F]) -> n |-F- B; M ++ [F] ; UP L ->
                                                                                exists m, m<= S n /\ m |-F- B; M ; UP (L ++ [F]).
  Proof with solveF .
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent B .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind .  intros n  M HPos  B L HD Hw ...
    + (* w = 0 *)
      destruct L. (* L must be empty. The second case is trivial *)
      exists ((S n)).
      split;auto.
      simpl.
      eapply trih_store ;auto.

      generalize(LPos3 M [F] (meq_refl (M ++ [F])) HPos);intro.
      inversion H;auto.

      simpl in Hw.
      apply AsyncEqNeg;auto.

      apply exp_weight0LF in Hw;contradiction.

    + intros.
      destruct L. (* L cannot be empty *)
      inversion Heqw ...
      inversionF H0;auto;subst;inversion Heqw;subst ...
      ++ (* top *)
        exists 0%nat;split ...
      ++ (* bot *)
        apply IH with (m:= L_weight  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n');split;auto. lia.
      ++  (* PAR *)
        apply IH with (m:= Exp_weight  F0 + Exp_weight  G + L_weight  L) in H5 ...
        destruct H5 as [n'  [IHn IHd]].
        exists (S n');split;auto. lia. simpl ... lia.
      ++ (* with *)
        apply IH with (m:= Exp_weight  F0 + L_weight  L) in H6 ...
        apply IH with (m:= Exp_weight  G + L_weight L) in H7 ...
        destruct H6 as [n'  [IHn IHd]].
        destruct H7 as [m'  [IHn' IHd']].
        simpl.
        exists (S (Init.Nat.max n' m'));split ...
        lia.
        autounfold. lia.
        autounfold. lia.
      ++  (* quest *)
        apply IH with (m:= L_weight  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n');split;auto. lia. simpl; eauto.
        lia.
      ++ (* Store *)
        MReplaceIn ((M ++ [F]) ++ [l]) ((M ++ [l]) ++ [F]) H7.
        apply IH with (m:= L_weight L) in H7;auto.
        destruct H7.
        destruct H1.
        exists (S x).
        split;auto.
        lia.
        eauto using WeightLeq ...
        MReplace ((M ++ [l]) ++ [F]) ((M ++ [F]) ++ [l]) ...
      ++  (* FORALL *)
        assert(forall x, exists m, m <= S n0 /\ m |-F- B; M; UP ((Subst FX x :: L)  ++ [F])).
        intro.
        generalize (H5 x);intro.
        eapply IH with (m:=Exp_weight (Subst FX x) + L_weight L) ...
        rewrite <- subs_weight_weak with (x:=x). auto.
        apply ax_subs_prop in H1.
        destruct H1 as [n H1].
        destruct H1 as [H1 H1'].
        exists (S n). split.
        lia.
        eapply trih_fx.
        intro x.
        generalize (H1' x); intro Hx ...
  Qed.
End FLLMetaTheory.


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

(** Extraction to OCaml of native 63-bit machine integers. *)

From Coq Require Uint63 Sint63 Extraction.

(** Basic data types used by some primitive operators. *)

Extract Inductive prod => "( * )" [ "" ].
Extract Inductive DoubleType.carry => "Uint63.carry" [ "Uint63.C0" "Uint63.C1" ].

(** Primitive types and operators. *)
Extract Constant Uint63.int => "Uint63.t".
Extraction Inline Uint63.int.
(* Otherwise, the name conflicts with the primitive OCaml type [int] *)

Extract Constant Uint63.lsl => "Uint63.l_sl".
Extract Constant Uint63.lsr => "Uint63.l_sr".
Extract Constant Sint63.asr => "Uint63.a_sr".
Extract Constant Uint63.land => "Uint63.l_and".
Extract Constant Uint63.lor => "Uint63.l_or".
Extract Constant Uint63.lxor => "Uint63.l_xor".

Extract Constant Uint63.add => "Uint63.add".
Extract Constant Uint63.sub => "Uint63.sub".
Extract Constant Uint63.mul => "Uint63.mul".
Extract Constant Uint63.mulc => "Uint63.mulc".
Extract Constant Uint63.div => "Uint63.div".
Extract Constant Uint63.mod => "Uint63.rem".
Extract Constant Sint63.div => "Uint63.divs".
Extract Constant Sint63.rem => "Uint63.rems".

Extract Constant Uint63.eqb => "fun x y -> Caml_bool.to_coq (Uint63.equal x y)".
Extract Constant Uint63.ltb => "fun x y -> Caml_bool.to_coq (Uint63.lt x y)".
Extract Constant Uint63.leb => "fun x y -> Caml_bool.to_coq (Uint63.le x y)".
Extract Constant Sint63.ltb => "fun x y -> Caml_bool.to_coq (Uint63.lts x y)".
Extract Constant Sint63.leb => "fun x y -> Caml_bool.to_coq (Uint63.les x y)".

Extract Constant Uint63.addc => "Uint63.addc".
Extract Constant Uint63.addcarryc => "Uint63.addcarryc".
Extract Constant Uint63.subc => "Uint63.subc".
Extract Constant Uint63.subcarryc => "Uint63.subcarryc".

Extract Constant Uint63.diveucl => "Uint63.diveucl".
Extract Constant Uint63.diveucl_21 => "Uint63.div21".
Extract Constant Uint63.addmuldiv => "Uint63.addmuldiv".

Extract Constant Uint63.compare => "fun x y -> Caml_comparison.to_coq (Uint63.compare x y)".
Extract Constant Sint63.compare => "fun x y -> Caml_comparison.to_coq (Uint63.compares x y)".

Extract Constant Uint63.head0 => "Uint63.head0".
Extract Constant Uint63.tail0 => "Uint63.tail0".


Require Import Denotational.
Require Export DenotationalTyped.
Require Export ContextualCausality.
Require Import Tactics.
Require Import Equivalence.

(* Specialisation (a.k.a. partial evaluation) of contracts. *)

Import ListNotations.

Definition ExtEnvP := ExtEnv' (option Val).

Definition EnvP := list (option Val).

Definition fromLit (e : Exp) : option Val :=
  match e with
    | OpE (RLit r) nil => Some (RVal r)
    | OpE (BLit b) nil => Some (BVal b)
    | _ => None
  end.

Definition toLit (e : Val) : Exp :=
  match e with
    | RVal r => OpE (RLit r) nil
    | BVal b => OpE (BLit b) nil
  end.

Lemma toLit_fromLit x v : fromLit x = Some v -> toLit v = x.
Proof.
  intros. destruct x; try solve [simpl in H; inversion H].
  destruct op; simpl in H; try solve [inversion H]; destruct args;
  inversion H; subst; reflexivity.
Qed.

Definition fromBLit (e : Exp) : option bool :=
  match e with
    | OpE (BLit b) nil => Some b
    | _ => None
  end.

Definition fromRLit (e : Exp) : option R :=
  match e with
    | OpE (RLit r) nil => Some r
    | _ => None
  end.

Definition isZeroLit (e : Exp) : bool :=
  match e with
    | OpE (RLit r) nil => Reqb r 0
    | _ => false
end.

Definition isOneLit (e : Exp) : bool :=
  match e with
    | OpE (RLit r) nil => Reqb r 1
    | _ => false
end.

Definition specialiseOpSimp (op : Op) (args : list Exp) : option Exp :=
  liftM toLit (mapM fromLit args >>= OpSem op).

Definition specialiseOp (op : Op) (args : list Exp) : option Exp :=
  match op with
    | Cond => match args with
                | [e1; e2; e3] => match fromBLit e1 with
                                      | Some true => Some e2
                                      | Some false => Some e3
                                      | _ => None
                                  end
                | _ => None
              end
    | And => match args with
               | [e1;e2] => match fromBLit e1, fromBLit e2 with
                              | Some false, _ => Some e1
                              | _, Some false => Some e2
                              | Some true, _ => Some e2
                              | _, Some true => Some e1
                              | _, _ => None
                            end
               | _ => None
             end
    | Or => match args with
               | [e1;e2] => match fromBLit e1, fromBLit e2 with
                              | Some true, _ => Some e1
                              | _, Some true => Some e2
                              | Some false, _ => Some e2
                              | _, Some false => Some e1
                              | _, _ => None
                            end
               | _ => None
             end
    | Add => match args with
               | [e1;e2] => if isZeroLit e1 then Some e2
                            else if isZeroLit e2 then Some e1
                                 else specialiseOpSimp op args
               | _ => None
             end
    | Mult => match args with
               | [e1;e2] => if isOneLit e1 then Some e2
                            else if isOneLit e2 then Some e1
                                 else if isZeroLit e1 || isZeroLit e2
                                      then Some (OpE (RLit 0) [])
                                      else specialiseOpSimp op args
               | _ => None
             end
    | _ =>  specialiseOpSimp op args
  end.

Fixpoint lookupEnvP (v : Var) (env : EnvP) : option Val :=
  match v, env with
    | V1, x::_ => x
    | VS v, _::xs => lookupEnvP v xs
    | _,_ => None
  end.

Definition specialiseFun f  (env : EnvP) (ext : ExtEnvP) :=
  fun l r => fromLit(f (r :: env) (adv_ext (Z.of_nat l) ext)).

Fixpoint specialiseExp (e : Exp) (env : EnvP) (ext : ExtEnvP)  : Exp :=
    match e with
      | OpE op args => let args' := map (fun e' => specialiseExp e' env ext) args
                       in default (OpE op args') (specialiseOp op args')
      | Obs obs t => default e (liftM toLit (ext obs t))
      | VarE v => default e (liftM toLit (lookupEnvP v env))
      | Acc f l z => let ext' := adv_ext (-Z.of_nat l) ext in
                     let ze := (specialiseExp z env ext') in
                     let fe := (specialiseExp z (None :: env) ext) in
                     let z' := fromLit ze in
                     let f' := specialiseFun (specialiseExp f) env ext'
                     in default (Acc f l ze) (liftM toLit (Acc_sem f' l z'))
    end.

(* Definition of instantiation of external and internal environments *)

Definition ext_inst (extp : ExtEnvP) (ext : ExtEnv) : Prop := forall l t v, extp l t = Some v -> ext l t = v.

Definition env_inst : EnvP -> Env -> Prop := all2 (fun p v => forall v', p = Some v' -> v' = v).

Hint Unfold env_inst.

Lemma env_inst_lookup rp r v x : env_inst rp r -> lookupEnvP v rp = Some x -> lookupEnv v r = Some x.
Proof.
  intros I L. generalize dependent r. generalize dependent rp. induction v;intros;simpl in *.
  - destruct I;tryfalse. apply H in L. subst. reflexivity.
  - destruct I;tryfalse. eapply IHv; eauto.
Qed.

Lemma Esem_toLit v env ext :  E[|toLit v|] env ext = Some v.
Proof.
  destruct v; reflexivity.
Qed.

Lemma Esem_fromLit e env ext v : fromLit e = Some v -> E[|e|] env ext = Some v.
Proof.
  simpl. intros. destruct e;tryfalse.
  destruct op; simpl in H; tryfalse; destruct args; tryfalse; auto.
Qed.

Definition TypeExtP (extp : ExtEnvP) := forall z l t, |-O l ∶ t -> |-V' (extp l z)  ∶ t.
Definition TypeEnvP (g : TyEnv) (envp : EnvP) : Prop := all2 TypeVal' envp g.

Hint Unfold TypeEnvP.

Lemma ext_inst_typed ext extp : ext_inst extp ext -> TypeExt ext -> TypeExtP extp.
Proof.
  unfold TypeExt, TypeExtP. intros I T z l t O.
  cases (extp l z) as R;constructor.
  apply I in R. rewrite <- R. auto.
Qed.

Lemma env_inst_typed env envp G : env_inst envp env -> TypeEnv G env -> TypeEnvP G envp.
Proof.
  intros I T. generalize dependent G. induction I;intros; inversion T; econstructor.
  destruct x. assert (Some v = Some v) as V by reflexivity. apply H in V. rewrite V.
  auto. auto.  unfold TypeEnvP in *. eauto.
Qed.

Lemma toLit_typed x t g : |-V x ∶ t -> g |-E toLit x ∶ t.
Proof.
  intros. destruct x; simpl; inversion H; eauto.
Qed.

Lemma fromLit_typed e t g : g |-E e ∶ t -> |-V' fromLit e ∶ t.
Proof.
  intros. destruct e;auto.
  inversion H. clear H. subst. destruct op; simpl; try constructor;
                               destruct args;try inversion H3; auto.
 Qed.

  Ltac inv := match goal with
                | [T : all2 (TypeExp _)  _ _ |- _] => inversion T; clear T;subst
                | [_: context[match ?x with _ => _ end]|- _] => destruct x
                | [T: Some _ = Some _|- _] => inversion T;clear T; subst
            end.

Lemma specialiseOpSimp_typed op es e G ts t :
|-Op op ∶ ts => t -> all2 (TypeExp G) es ts -> specialiseOpSimp op es = Some e
                -> G |-E e ∶ t.
Proof.
  intros O A S. unfold specialiseOpSimp in *.
  eapply OpSem_typed_total in O. decompose [ex and] O. rewrite H0 in S.
  simpl in S. unfold compose, pure in *. inversion S. apply toLit_typed. assumption.
  clear O. option_inv_auto. clear H2. generalize dependent x0. induction A;constructor.
  simpl in H1. option_inv_auto. eexists. split. eassumption. apply fromLit_typed in H.
  rewrite H0 in H. inversion H. rewrite <- H1 in H0. inversion H0. subst. assumption.
  simpl in H1. option_inv_auto. eauto.
Qed.

Lemma specialiseOp_typed op es e G ts t :
|-Op op ∶ ts => t -> all2 (TypeExp G) es ts -> specialiseOp op es = Some e
                -> G |-E e ∶ t.
Proof.

  intros O A S. inversion O;subst;clear O; simpl in *; tryfalse;
  repeat inv; tryfalse; eauto using specialiseOpSimp_typed.
Qed.

Lemma lookupEnvP_typed G envp v t : TypeEnvP G envp -> G |-X v ∶ t -> |-V' lookupEnvP v envp ∶ t.
Proof.
  intros E V. generalize dependent envp. generalize dependent G.
  induction v;intros.
  - simpl. destruct envp. auto. inversion E. subst. inversion V. subst. assumption.
  - simpl. destruct envp. constructor. inversion V. subst. inversion E. subst. eauto.
Qed.

Lemma adv_extp_type: forall (e : ExtEnvP) (d : Z), TypeExtP e -> TypeExtP (adv_ext d e).
Proof.
  unfold TypeExtP, adv_ext. intros. auto.
Qed.

Hint Resolve adv_extp_type.

Lemma constFoldAcc_typed ext f l z t :
  TypeExtP ext
  -> (forall i x, |-V' x ∶ t -> |-V' f i x ∶ t)
  -> (|-V' z ∶ t)
  -> |-V' Acc_sem f l z ∶ t.
Proof.
  intros. induction l;intros; simpl; auto using adv_extp_type.
Qed.

Lemma TypeVal_Some v t : |-V' Some v ∶ t -> |-V v ∶ t.
Proof.
  intros H. inversion H. auto.
Qed.

Tactic Notation "destruct_toLit" ident (d')
  := match goal with
       | [|- context[liftM toLit ?x]] => let d := fresh in
                                         cases x as d'
     end.

Lemma specialiseExp_typed G e t extp envp :
  G |-E e ∶ t -> TypeEnvP G envp -> TypeExtP extp
      -> G |-E specialiseExp e envp extp ∶ t.
Proof.
  intros E V R. generalize dependent envp. generalize dependent extp.
  induction E using TypeExp_ind'; intros.
  - simpl.
        do 4 (eapply all2_apply in H1; try eassumption).
    apply all2_map_all2 in H1. rewrite map_id in H1.
    cases (specialiseOp op (map (fun e' : Exp => specialiseExp e' envp extp) es)) as S.
    + simpl.  eapply specialiseOp_typed in S; eassumption.
    + simpl. econstructor; eassumption.
  - simpl. cases (extp o z) as O.
    + simpl. apply toLit_typed. unfold TypeExtP in *. apply R with (z:=z) in H. rewrite O in H.
      inversion H. assumption.
    + simpl. auto.
  - simpl. cases (lookupEnvP v envp) as L.
    + simpl. apply toLit_typed. eapply lookupEnvP_typed in H;eauto. rewrite L in H. inversion H.
      assumption.
    + simpl. auto.
  - simpl. destruct_toLit S.
    + apply toLit_typed. apply TypeVal_Some. rewrite <- S. eapply constFoldAcc_typed.
      * eassumption.
      * intros. eapply fromLit_typed. apply IHE1; auto.
      * intros. eapply fromLit_typed. apply IHE2; auto.
    + simpl. auto.
Qed.

Lemma fromBLit_Some b x : fromBLit x = Some b -> x = OpE (BLit b) [].
Proof.
  intros. destruct x;tryfalse. simpl in *. destruct op;tryfalse. destruct args;tryfalse.
  inversion H. reflexivity.
Qed.

Lemma isZeroLit_true x : isZeroLit x = true -> x = OpE (RLit 0) [].
Proof.
  intros. destruct x;tryfalse. destruct args; destruct op;tryfalse.
  simpl in H. apply Reqb_iff in H. subst. reflexivity.
Qed.

Lemma isOneLit_true x : isOneLit x = true -> x = OpE (RLit 1) [].
Proof.
  intros. destruct x;tryfalse. destruct args; destruct op;tryfalse.
  simpl in H. apply Reqb_iff in H. subst. reflexivity.
Qed.

Lemma specialiseOpSimp_sound (op : Op) es e env ext G ts t:
|-Op op ∶ ts => t -> all2 (TypeExp G) es ts -> TypeEnv G env -> TypeExt ext ->
  specialiseOpSimp op es = Some e -> E[|OpE op es|] env ext = E[|e|] env ext.
Proof.
  intros O A E X R. unfold specialiseOpSimp in R. option_inv_auto. simpl.
  rewrite Esem_toLit. rewrite sequence_map. eapply mapM_monotone' in H1.
  rewrite H1. assumption.  simpl. intros. auto using Esem_fromLit.
Qed.

Lemma specialiseOp_sound (op : Op) es e env ext G ts t:
|-Op op ∶ ts => t -> all2 (TypeExp G) es ts -> TypeEnv G env -> TypeExt ext ->
  specialiseOp op es = Some e -> E[|OpE op es|] env ext = E[|e|] env ext.
Proof.
  Ltac inv' := match goal with
                | [T : all2 (TypeExp _)  _ _ |- _] => inversion T; clear T;subst
                | [_: context[match ?x with _ => _ end]|- _] => cases x;tryfalse
                | [T : fromBLit _ = Some _ |- _] => apply fromBLit_Some in T
                | [T : isZeroLit _ = true |- _] => apply isZeroLit_true in T
                | [T : isOneLit _ = true |- _] => apply isOneLit_true in T
                | [T : ?x || ?y = true |- _] => cases x;cases y;simpl in T; tryfalse
                | [T: Some _ = Some _|- _] => inversion T;clear T; subst
                | [T: specialiseOpSimp _ _ = Some _ |- _] => eapply specialiseOpSimp_sound in T;eauto
              end.
  Ltac tot := match goal with
                | [T : TypeExp _ _ _ |- _] => eapply Esem_typed_total in T; eauto; decompose [ex and] T; clear T
                | [T : _ = Some _ |- _ ] => rewrite T; simpl in *
                | [|-context [match ?x with _ => _ end]] => cases x;tryfalse
                | [T : TypeVal _ _ |- _] => inversion T; clear T;subst
              end.

  intros O A E X R.
 inversion O;subst;clear O; simpl in *;tryfalse;
 repeat inv'; simpl; repeat tot; try reflexivity; try destruct b;
 try first [reflexivity|rewrite Rplus_0_l|rewrite Rplus_0_r|rewrite Rmult_1_l|rewrite Rmult_1_r|rewrite Rmult_0_l|rewrite Rmult_0_r]; try first [reflexivity|assumption].
Qed.

Lemma ext_inst_adv extp ext z : ext_inst extp ext -> ext_inst (adv_ext z extp) (adv_ext z ext).
Proof.
  unfold ext_inst, adv_ext. intros. auto.
Qed.

Hint Resolve env_inst_typed ext_inst_typed specialiseExp_typed ext_inst_adv.

Lemma lookupEnvP_sound envp env v x :
  env_inst envp env -> lookupEnvP v envp = Some x -> lookupEnv v env = Some x.
Proof.
  intros I L. generalize dependent x. generalize dependent envp. generalize dependent env.
  induction v;intros; simpl in *; destruct envp;tryfalse; inversion I; subst.
  - erewrite <- H1; reflexivity.
  - eapply IHv;eauto.
Qed.

Theorem specialiseExp_sound G e t extp ext envp env :
  G |-E e ∶ t -> TypeExt ext -> TypeEnv G env ->
      ext_inst extp ext -> env_inst envp env ->
      E[|specialiseExp e envp extp|] env ext  = E[|e|] env ext.
Proof.
  intros T R V I J. generalize dependent ext. generalize dependent extp.
  generalize dependent env. generalize dependent envp.
  induction T using TypeExp_ind';intros.
  - simpl.
    apply all2_all in H1. do 8 (eapply all_apply in H1;eauto). apply map_rewrite in H1.
    cases (specialiseOp op (map (fun e' : Exp => specialiseExp e' envp extp) es)) as S.
    + eapply specialiseOp_sound in S;eauto. simpl in *. rewrite <- S.
      rewrite map_map. rewrite H1. reflexivity.
      rewrite <- map_id.  eapply all2_map; eauto.
    + simpl. rewrite map_map. rewrite H1. reflexivity.
  - simpl. cases (extp o z) as O; simpl. apply I in O. rewrite O.
    apply Esem_toLit. reflexivity.
  - simpl. cases (lookupEnvP v envp) as L.
    + simpl. rewrite Esem_toLit. erewrite lookupEnvP_sound;eauto.
    + reflexivity.
  - generalize dependent ext. generalize dependent extp.
    generalize dependent env. generalize dependent envp. induction n;intros.
    + simpl. destruct_toLit S.
      * eapply Esem_fromLit in S. rewrite IHT2 in S; eauto.
        simpl. rewrite Esem_toLit. auto.
      * simpl. auto.
    + assert (g |-E Acc e1 n e2 ∶ t) as A by auto.
      eapply Esem_typed_total with (ext:= adv_ext (-1) ext) in A; eauto.
      assert (g |-E specialiseExp (Acc e1 n e2) envp (adv_ext (-1) extp) ∶ t) as As
                                                                                by (apply specialiseExp_typed;eauto).
      eapply Esem_typed_total with (ext := adv_ext (-1) ext) in As;eauto.
      simpl in *. destruct_toLit S.
      * simpl. rewrite Esem_toLit.
        unfold Fsem at 1. simpl. simpl in IHn. repeat rewrite adv_ext_step'.
        erewrite <- IHn with (extp:=adv_ext (-1) extp) (envp := envp); eauto.
        destruct_toLit S'.
        simpl. rewrite Esem_toLit. simpl.
        eapply Esem_fromLit with (env := v0 :: env) in S. rewrite <- S.
        eapply IHT1;eauto. constructor;eauto.
        decompose [ex and] As.  simpl in H0. rewrite Esem_toLit in H0. inversion H0. assumption.
        constructor;auto.
        intros. rewrite <- adv_ext_step' in S'. rewrite S' in H. inversion H. reflexivity.
        repeat rewrite adv_ext_iter.
        assert (Z.neg (Pos.of_succ_nat n) + Z.of_nat (Datatypes.S n) =
                (-1) + (- Z.of_nat n + Z.pos (Pos.of_succ_nat n)))%Z as E by
        (rewrite Zneg_of_succ_nat; rewrite Zpos_P_of_succ_nat; repeat rewrite Nat2Z.inj_succ; omega) .
        rewrite E. auto.

        simpl. unfold specialiseFun in S. decompose [ex and] A.
        eapply Esem_fromLit with (env := x :: env) (ext :=(adv_ext (Z.pos (Pos.of_succ_nat n))
        (adv_ext (- Z.of_nat n) (adv_ext (-1) ext)))) in S.
        rewrite <- S. rewrite IHT1;eauto. rewrite IHT2;eauto. rewrite H0.
        simpl. reflexivity. constructor;auto.
        intros. unfold specialiseFun in S'.
        rewrite <- adv_ext_step in S'. rewrite <- Zneg_of_succ_nat in S'.
        rewrite S' in H. inversion H. repeat rewrite adv_ext_iter.
        assert (Z.neg (Pos.of_succ_nat n) + Z.of_nat (Datatypes.S n) =
                (-1) + (- Z.of_nat n + Z.pos (Pos.of_succ_nat n)))%Z as E by
        (rewrite Zneg_of_succ_nat; rewrite Zpos_P_of_succ_nat; repeat rewrite Nat2Z.inj_succ; omega) .
        rewrite E. auto.
      * simpl. rewrite IHT2;auto.
Qed.

Fixpoint elimVarV (v1 v2 : Var) : option Var :=
  match v1, v2 with
    | V1,V1 => None
    | V1,VS v2' => Some v2'
    | VS v1', V1 => Some V1
    | VS v1', VS v2' => liftM VS (elimVarV v1' v2')
  end.

(* Checks whether the given variable occurs in the given expression. *)

Fixpoint elimVarE (v : Var) (e : Exp) : option Exp :=
  match e with
    | OpE op args => liftM (OpE op) (sequence (map (elimVarE v) args))
    | Obs _ _ => Some e
    | VarE v' => liftM VarE (elimVarV v v')
    | Acc e1 l e2 => liftM2 (fun e1' e2' => Acc e1' l e2') (elimVarE (VS v) e1) (elimVarE v e2)
  end.

(* Two internal environments are equivalent up to a variable. *)
Inductive elimVarEnv {A} : Var -> list A -> list A -> Prop :=
  | elimVarEnv_nil v : elimVarEnv v [] []
  | elimVarEnv_V1 r x : elimVarEnv V1 (x::r) r
  | elimVarEnv_VS r1 r2 x v : elimVarEnv v r1 r2 ->
                                elimVarEnv (VS v) (x::r1) (x::r2).

Hint Constructors elimVarEnv.

Lemma elimVarEnv_map {A B} v xs ys (f : A -> B) : elimVarEnv v xs ys -> elimVarEnv v (map f xs) (map f ys).
Proof.
  intro E. induction E;intros;simpl in *;eauto.
Qed.

Lemma Acc_sem_ext {A} l (e1 e2 : A) f1 f2 :
  e1 = e2 -> (forall x y, f1 x y = f2 x y) ->  Acc_sem f1 l e1 = Acc_sem f2 l e2.
Proof.
  intros E F. induction l.
  - simpl. assumption.
  - simpl. rewrite IHl. apply F.
Qed.

Lemma elimVarE_sound v vs1 vs2 ext e e': elimVarE v e = Some e' -> elimVarEnv v vs1 vs2 ->
                                       E[|e|]vs1 ext = E[|e'|]vs2 ext.
Proof.
  intros O U. generalize dependent ext. generalize dependent vs1. generalize dependent vs2.
  generalize dependent v. generalize dependent e'.
  induction e using Exp_ind';intros;simpl in *.
  - option_inv_auto. simpl. apply bind_equals;auto.
    generalize dependent x. induction H;intros.
    + simpl in H1. inversion H1. reflexivity.
    + simpl in H1. option_inv_auto. simpl. f_equal;eauto.
  - inversion O. reflexivity.
  - option_inv_auto. simpl. generalize dependent v. generalize dependent x.
    induction U;intros.
    + destruct x;destruct v0;reflexivity.
    + destruct v;tryfalse. simpl in *. inversion H0. reflexivity.
    + destruct v0; simpl in *. inversion H0. reflexivity.
      option_inv_auto. simpl. apply IHU. assumption.
  - option_inv_auto. simpl. generalize dependent ext.
    induction d;intros.
    + simpl in *. eapply IHe2;eauto.
    + rewrite adv_ext_step. simpl. erewrite IHd.
      unfold Fsem. apply bind_equals. apply Acc_sem_ext; auto.
      intros. erewrite IHe1;eauto.
Qed.

Lemma elimVarE_typed v g1 g2 e e' t: elimVarE v e = Some e' -> elimVarEnv v g1 g2 ->
                                         g1 |-E e ∶ t -> g2 |-E e' ∶ t.
Proof.
  intros O U T. generalize dependent g1. generalize dependent g2.
  generalize dependent t. generalize dependent e'. generalize dependent v.
  induction e using Exp_ind';intros;simpl in *;first[option_inv' O|inversion O];inversion T;clear T;subst.
  - econstructor;eauto. clear H4. generalize dependent x. induction H6;intros.
    + simpl in H2. inversion H2. constructor.
    + simpl in H2. option_inv' H2. inversion H. subst. constructor; eauto.
  - auto.
  - constructor. generalize dependent v. generalize dependent x. induction U;intros.
    + destruct v0;destruct v;tryfalse; simpl in *; inversion H1;inversion H2;auto.
    + destruct v;tryfalse. simpl in *. inversion H1. inversion H2. subst. assumption.
    + destruct v0; simpl in *. inversion H1. inversion H2. subst. auto.
      option_inv_auto. inversion H2. subst. eauto.
  - constructor;eauto.
Qed.

Fixpoint elimVarC (v : Var) (c : Contr) : option Contr :=
  match c with
    | Zero => Some c
    | Transfer _ _ _ => Some c
    | Let e c' => liftM2 Let (elimVarE v e) (elimVarC (VS v) c')
    | Scale e c' => liftM2 Scale (elimVarE v e) (elimVarC v c')
    | Translate l c' => liftM (Translate l) (elimVarC v c')
    | Both c1 c2 => liftM2 Both (elimVarC v c1) (elimVarC v c2)
    | If e l c1 c2 => liftM3 (fun e' c1' c2' => If e' l c1' c2') (elimVarE v e) (elimVarC v c1) (elimVarC v c2)
  end.

Lemma elimVarC_sound v vs1 vs2 ext c c' : elimVarC v c = Some c' -> elimVarEnv v vs1 vs2 ->
                                         C[|c|]vs1 ext = C[|c'|]vs2 ext.
Proof.
  intros O U. generalize dependent ext. generalize dependent vs1. generalize dependent vs2.
  generalize dependent v. generalize dependent c'.
  induction c;intros; simpl in *;try first [option_inv' O|inversion O];simpl;
  try solve [reflexivity|eauto using bind_equals, elimVarE_sound|f_equal;eauto using bind_equals, elimVarE_sound].

  generalize dependent ext. induction n;intros;simpl;erewrite elimVarE_sound;eauto;erewrite IHc1;eauto.
  - erewrite IHc2;eauto.
  - erewrite IHn;eauto.
Qed.

Lemma elimVarC_typed v g1 g2 c c' : elimVarC v c = Some c' -> elimVarEnv v g1 g2 ->
                                         g1 |-C c -> g2 |-C c'.
Proof.
  intros O U T. generalize dependent g1. generalize dependent g2.
  generalize dependent c'. generalize dependent v.
  induction c;intros;simpl in *;first[option_inv' O|inversion O];inversion T;clear T;subst;
  eauto using elimVarE_typed.
Qed.

(* Smart contructor for let bindings. If the bound variable of the let
bindings occurs in the given contract, a let binding is constructed
otherwise the input contract is returned. *)

Definition smartLet (e : Exp) (c : Contr) : Contr :=
  match elimVarC V1 c with
    | None => Let e c
    | Some c' => c'
  end.

(* The smart let binding is equivalent to the ordinary let binding. *)

Lemma smartLet_sound e c vs ext t g :
  g |-E e ∶ t -> TypeEnv g vs -> TypeExt ext -> C[|smartLet e c|]vs ext = C[|Let e c|]vs ext.
Proof.
  intros T G R. unfold smartLet. cases (elimVarC V1 c); try reflexivity.
  simpl.
  eapply Esem_typed_total in T;eauto. decompose [ex and] T.
  rewrite H0. simpl. erewrite <- elimVarC_sound;eauto.
Qed.

Lemma smartLet_typed e c g :
  g |-C Let e c -> g |-C smartLet e c.
Proof.
  intros T. inversion T. unfold smartLet. cases (elimVarC V1 c); eauto using elimVarC_typed.
Qed.

Corollary smartLet_equiv e c g :
  g |-C Let e c -> smartLet e c ≡[g] Let e c.
Proof.
  intros. unfold equiv. repeat split; auto.
  - apply smartLet_typed. assumption.
  - intros. inversion H. eauto using smartLet_sound.
Qed.

(* Smart constructor for scaling *)

Definition smartScale e c : Contr :=
  if isZeroLit e then Zero
  else match c with
         | Zero => Zero
         | c' => Scale e c'
       end.

Lemma smartScale_sound e c vs ext g:
  g |-C Scale e c -> TypeEnv g vs -> TypeExt ext -> C[|smartScale e c|]vs ext = C[|Scale e c|]vs ext.
Proof.
  intros T G R. inversion T. subst.
  unfold smartScale. cases (isZeroLit e) as E. apply isZeroLit_true in E.
  subst. simpl. eapply Csem_typed_total in H3;eauto. destruct H3. rewrite H. simpl.
  unfold compose. rewrite scale_trace_0. reflexivity.
  destruct c; try reflexivity.
  simpl. eapply Esem_typed_total in H2;eauto. decompose [ex and] H2. rewrite H0.
  inversion H1. simpl. unfold compose. rewrite scale_empty_trace. reflexivity.
Qed.

Lemma smartScale_typed e c g :
  g |-C Scale e c -> g |-C smartScale e c.
Proof.
  intros T. inversion T. unfold smartScale. cases (isZeroLit e); cases c; eauto.
Qed.

Corollary smartScale_equiv e c g :
  g |-C Scale e c -> smartScale e c ≡[g] Scale e c.
Proof.
  intros. unfold equiv. repeat split; auto.
  - apply smartScale_typed. assumption.
  - intros. inversion H. eauto using smartScale_sound.
Qed.

Definition smartBoth c1 c2 : Contr :=
  match c1, c2 with
    | Zero, c' => c'
    | c', Zero => c'
    | c1', c2' => Both c1' c2'
  end.

Lemma smartBoth_sound c1 c2 vs ext g:
  g |-C Both c1 c2 -> TypeEnv g vs -> TypeExt ext -> C[|smartBoth c1 c2|]vs ext = C[|Both c1 c2|]vs ext.
Proof.
  intros T G R. inversion T. subst.
  eapply Csem_typed_total in H2;eauto. destruct H2 as [t1 C1].
  eapply Csem_typed_total in H3;eauto. destruct H3 as [t2 C2].
  destruct c1;destruct c2;unfold smartBoth; simpl in *; unfold compose;try reflexivity;
  try first[rewrite add_empty_trace_l|rewrite add_empty_trace_r]; try reflexivity;
  first[rewrite C1|rewrite C2]; simpl;unfold compose;
  first[rewrite add_empty_trace_l|rewrite add_empty_trace_r]; try reflexivity.
Qed.

Lemma smartBoth_typed c1 c2 g :
  g |-C Both c1 c2 -> g |-C smartBoth c1 c2.
Proof.
  intros T. inversion T. destruct c1;destruct c2; simpl; eauto.
Qed.

Corollary smartBoth_equiv c1 c2 g :
  g |-C Both c1 c2 -> smartBoth c1 c2 ≡[g] Both c1 c2.
Proof.
  intros. unfold equiv. repeat split; auto.
  - apply smartBoth_typed. assumption.
  - intros. inversion H. eauto using smartBoth_sound.
Qed.

Open Scope nat.

Definition smartTranslate l c : Contr :=
  match l with
    | 0 => c
    | _ => match c with
             | Zero => Zero
             | _ => Translate l c
           end
end.

Lemma smartTranslate_sound l c vs ext:
  C[|smartTranslate l c|]vs ext = C[|Translate l c|]vs ext.
Proof.
  destruct l.
  - simpl. erewrite liftM_ext. rewrite liftM_id. rewrite adv_ext_0. reflexivity.
    intros. simpl. apply delay_trace_0.
  - destruct c;try reflexivity. simpl. unfold compose. simpl.
    rewrite delay_empty_trace. reflexivity.
Qed.

Lemma smartTranslate_typed l c g :
  g |-C Translate l c -> g |-C smartTranslate l c.
Proof.
  intros T. inversion T. destruct l;auto;destruct c; auto.
Qed.

Corollary smartTranslate_equiv l c g :
  g |-C Translate l c -> smartTranslate l c ≡[g] Translate l c.
Proof.
  intros. unfold equiv. repeat split; auto.
  - apply smartTranslate_typed. assumption.
  - intros. inversion H. eauto using smartTranslate_sound.
Qed.

Fixpoint traverseIf (env:EnvP) (ext : ExtEnvP) (e: Exp) (c1 c2 : ExtEnvP -> Contr) (d : nat) (l : nat) : option Contr :=
  match fromBLit (specialiseExp e env ext) with
      | Some true => Some (smartTranslate d (c1 ext))
      | Some false => match l with
                        | O => Some (smartTranslate d (c2 ext))
                        | S l' => traverseIf env (adv_ext 1 ext) e c1 c2 (S d) l'
                        end
      | _ => None
  end.

Fixpoint specialise (c : Contr) (env : EnvP) (ext : ExtEnvP) : Contr :=
  match c with
    | Zero => c
    | Transfer _ _ _ => c
    | Let e c' => let e' := specialiseExp e env ext in
                  smartLet e' (specialise c' (fromLit e' :: env) ext)
    | Scale e c' => smartScale (specialiseExp e env ext) (specialise c' env ext)
    | Translate l c' => smartTranslate l (specialise c' env (adv_ext (Z.of_nat l) ext))
    | Both c1 c2 => smartBoth (specialise c1 env ext) (specialise c2 env ext)
    | If e l c1 c2 => default c (traverseIf env ext e (specialise c1 env) (specialise c2 env) 0 l)
  end.

Hint Resolve smartTranslate_typed smartBoth_typed smartScale_typed
     smartLet_typed specialiseExp_typed fromLit_typed : SmartTyped.

Theorem specialise_typed g env ext  c :
  g |-C c -> TypeEnvP g env -> TypeExtP ext -> g |-C specialise c env ext.
Proof.
  intros T E R. generalize dependent env. generalize dependent ext. generalize dependent g.
  induction c;intros; inversion T;subst;simpl; eauto 9 with SmartTyped.
  (* all cases except If are caught by eauto *)
  match goal with [|-context[default _ ?x]] => cases x as S end;try auto.
  generalize dependent c. generalize dependent ext. generalize 0.
  induction n;intros.
  - simpl in *. cases (fromBLit (specialiseExp e env ext)) as B;tryfalse.
    destruct b; inversion S; auto with SmartTyped.
  - simpl in *. cases (fromBLit (specialiseExp e env ext)) as B;tryfalse.
    destruct b; inversion S; auto with SmartTyped. apply IHn in S;eauto.
Qed.

Hint Resolve  Esem_fromLit smartTranslate_typed smartBoth_typed smartScale_typed
     smartLet_typed specialiseExp_typed specialise_typed fromLit_typed smartTranslate_sound
     smartBoth_sound smartScale_sound  smartLet_sound specialiseExp_sound   : SmartSound.

Lemma Esem_fromBLit e r vs ext : fromBLit e = Some r -> E[|e|]vs ext = Some (BVal r).
Proof.
  intros. apply fromBLit_Some in H. subst. reflexivity.
Qed.

Definition pequiv g envp extp c1 c2 := forall env ext,
                                        TypeEnv g env -> TypeExt ext ->
                                        ext_inst extp ext ->
                                        env_inst envp env ->
                                        C[|c1|] env ext = C[|c2|] env ext.
Hint Unfold pequiv.

Notation "c1 '≡[' g ',' envp ',' extp ']' c2" := (pequiv g envp extp c1 c2) (at level 50).

Theorem specialise_sound g envp extp  c :
  g |-C c -> specialise c envp extp ≡[g,envp,extp] c.
Proof.
  unfold pequiv.
  intros T env ext E R I J. generalize dependent env. generalize dependent ext.
  generalize dependent envp. generalize dependent extp. generalize dependent g.
  induction c;intros; inversion T;subst;simpl; eauto.
  - erewrite smartLet_sound by eauto 9 with SmartSound. simpl.
    erewrite specialiseExp_sound by eauto. pose H2 as HT. eapply Esem_typed_total in HT;eauto.
    decompose [ex and] HT. rewrite H0. simpl.
    eapply IHc; eauto 9 with SmartSound. constructor.
    intros. eapply Esem_fromLit in H. erewrite specialiseExp_sound in H; eauto.
    rewrite H0 in H. inversion H. reflexivity. auto.
  - erewrite smartScale_sound by eauto 9 with SmartSound. simpl. erewrite IHc by eauto.
    erewrite specialiseExp_sound by eauto.  reflexivity.
  - erewrite smartTranslate_sound by eauto. simpl. erewrite IHc by eauto. reflexivity.
  - erewrite smartBoth_sound by eauto 9 with SmartSound. simpl. erewrite IHc1 by eauto.
    erewrite IHc2 by eauto. reflexivity.

  - match goal with [|-context[default _ ?x]] => cases x as S end;try auto.
    generalize dependent c. generalize dependent ext. generalize dependent extp.
    assert (forall (n0 : nat) (extp : ExtEnvP) (ext : ExtEnv),
              TypeExt (adv_ext (Z.of_nat n0) ext) ->
              ext_inst extp (adv_ext (Z.of_nat n0) ext) ->
              forall c : Contr,
                traverseIf envp extp e (specialise c1 envp) (specialise c2 envp) n0 n =
                Some c ->
                C[|c|] env ext =
                liftM (delay_trace n0) (within_sem C[|c1|] C[|c2|] e n env (adv_ext (Z.of_nat n0) ext))) as G.

    induction n;intros;
    simpl in *; pose H3 as HT; eapply Esem_typed_total in HT;eauto;
    decompose [ex and] HT; inversion H7; subst; rewrite H4;
    cases (fromBLit (specialiseExp e envp extp)) as B;tryfalse;
    eapply Esem_fromBLit in B; erewrite specialiseExp_sound in B by eauto;
    rewrite B in H4; inversion H4; subst;
    destruct b; inversion H1; try rewrite smartTranslate_sound; simpl; f_equal; eauto.
    + rewrite liftM_liftM. erewrite liftM_ext.
      rewrite adv_ext_iter'.
      assert (1 + Z.of_nat n0 = Z.of_nat (1 + n0))%Z as Q.
      rewrite Nat2Z.inj_succ. omega. rewrite Q. eapply IHn; eauto.
      rewrite <- Q. rewrite <- adv_ext_iter'. auto.
      rewrite <- Q. rewrite <- adv_ext_iter'. auto.
      intros. unfold compose. rewrite delay_trace_iter. reflexivity.
    + intros. simpl. erewrite G;eauto;rewrite adv_ext_0;auto. erewrite liftM_ext by (apply delay_trace_0).
      rewrite liftM_id. reflexivity.
Qed.

Lemma fromRLit_fromLit e r : fromRLit e = Some r -> fromLit e = Some (RVal r).
Proof.
  intros. destruct e;tryfalse. destruct op;tryfalse. destruct args;tryfalse. simpl in *.
  inversion H. reflexivity.
Qed.

Lemma fromBLit_fromLit e r : fromBLit e = Some r -> fromLit e = Some (BVal r).
Proof.
  intros. destruct e;tryfalse. destruct op;tryfalse. destruct args;tryfalse. simpl in *.
  inversion H. reflexivity.
Qed.

Lemma specialise_fromLit e env envp ext extp v g t :
  g |-E e ∶ t -> TypeEnv g env -> TypeExt ext ->
  ext_inst extp ext -> env_inst envp env ->
  fromLit (specialiseExp e envp extp) = Some v -> E[|e|] env ext = Some v.
Proof.
  intros. erewrite <- specialiseExp_sound by eauto. apply Esem_fromLit. assumption.
Qed.

Module Timed.

Lemma toLit_timed ts t v : CausalE ts t (toLit v).
Proof.
  destruct v; simpl; auto.
Qed.

Hint Resolve toLit_timed.

  Ltac inv := match goal with
                | [T: specialiseOpSimp _ _ = _ |- _] => unfold specialiseOpSimp in T; option_inv_auto
                | [T : all _ _ |- _] => inversion T; clear T;subst
                | [_: context[match ?x with _ => _ end]|- _] => destruct x
                | [T: Some _ = Some _|- _] => inversion T;clear T; subst
            end.

Lemma specialiseOp_timed op es e ts t :
all (CausalE ts t) es -> specialiseOp op es = Some e -> CausalE ts t e.
Proof.
  intros A S. destruct op; repeat (inv;tryfalse;simpl in *;eauto).
Qed.

Lemma specialiseExp_timed ts e t extp envp :
  CausalE ts t e -> CausalE ts t (specialiseExp e envp extp).
Proof.
  intros E. generalize dependent extp.
  generalize dependent ts. generalize dependent t.
  induction e using Exp_ind'; intros.
  - simpl. inversion E. subst.
    do 2 (eapply all_apply in H; try eassumption).
    apply all_mp in H; try eassumption.
    eapply all_apply in H; try eassumption.
    eapply all_map in H.
    cases (specialiseOp op (map (fun e' : Exp => specialiseExp e' envp extp) args));simpl;
    eauto using specialiseOp_timed.
  - simpl. destruct (extp l i);simpl; auto.
  - simpl. destruct (lookupEnvP v envp); simpl; auto.
  - simpl. destruct_toLit S.
    + simpl. auto.
    + simpl. inversion E. subst. eauto.
Qed.

Lemma elimVarE_timed v ts1 ts2 e e' t:
  elimVarE v e = Some e' -> elimVarEnv v ts1 ts2 ->
  CausalE ts1 t e -> CausalE ts2 t e'.
Proof.
  intros O U T. generalize dependent ts1. generalize dependent ts2.
  generalize dependent t. generalize dependent e'. generalize dependent v.
  induction e using Exp_ind';intros;simpl in *;first[option_inv' O|inversion O];inversion T;clear T;subst.
  - econstructor;eauto. generalize dependent x. induction H4;intros.
    + simpl in H2. inversion H2. constructor.
    + simpl in H2. option_inv' H2. inversion H. subst. constructor; eauto.
  - auto.
  - constructor. generalize dependent v. generalize dependent x. induction U;intros.
    + destruct v0;destruct v;tryfalse; simpl in *; inversion H1; subst;inversion H3;auto.
    + destruct v;tryfalse. simpl in *. inversion H1. inversion H3. subst. assumption.
    + destruct v0; simpl in *. inversion H1. inversion H3. subst. auto.
      option_inv_auto. inversion H3. subst. eauto.
  - constructor;eauto using elimVarEnv_map.
Qed.

Lemma elimVarC_timed v ts1 ts2 c c' t : elimVarC v c = Some c' -> elimVarEnv v ts1 ts2 ->
                                         CausalC ts1 t c -> CausalC ts2 t c'.
Proof.
  intros O U T. generalize dependent ts1. generalize dependent ts2. generalize dependent t.
  generalize dependent c'. generalize dependent v.
  induction c;intros;simpl in *;first[option_inv' O|inversion O];inversion T;clear T;subst;
  eauto 6 using elimVarE_timed,elimVarEnv_map.
Qed.

Lemma smartLet_timed e c ts t:
  CausalC ts t (Let e c) -> CausalC ts t (smartLet e c).
Proof.
  intros T. inversion T. unfold smartLet. cases (elimVarC V1 c); eauto using elimVarC_timed.
Qed.

Lemma smartScale_timed e c t ts :
  CausalC ts t (Scale e c) -> CausalC ts t (smartScale e c).
Proof.
  intros T. inversion T. unfold smartScale. cases (isZeroLit e); cases c; eauto.
Qed.

Lemma smartBoth_timed c1 c2 ts t :
  CausalC ts t (Both c1 c2) -> CausalC ts t (smartBoth c1 c2).
Proof.
  intros T. inversion T. destruct c1;destruct c2; simpl; eauto.
Qed.

Lemma smartTranslate_timed l c ts t :
  CausalC ts t (Translate l c) -> CausalC ts t (smartTranslate l c).
Proof.
  intros T. inversion T.
  destruct l;auto;destruct c; simpl;
  try rewrite map_tsub'_0 in *; try rewrite tsub'_0 in *; eauto.
Qed.

Hint Resolve smartTranslate_timed smartBoth_timed smartScale_timed
     smartLet_timed specialiseExp_timed : SmartTimed.

Lemma all2_tle_tsub' n ts : all2 tle (map (tsub' n) ts) ts.
Proof.
  apply all2_map_forall;intros. destruct x;simpl;constructor; omega.
Qed.

Open Scope time.

Lemma tle_tsub' n t : tsub' n t <= t.
Proof.
  destruct t;simpl;constructor;omega.
Qed.

Lemma tsub_0 t : tsub 0 t = t.
Proof.
  unfold tsub. simpl. apply tadd_0.
Qed.

Lemma map_tsub_0 t : map (tsub 0) t = t.
Proof.
  erewrite map_ext. apply map_id. apply tsub_0.
Qed.

Lemma traverseIf_timed ts t c1 c2 n d l e ext env c :
  (forall ext', CausalC ts t (c1 ext')) -> (forall ext', CausalC (map (tsub' n) ts) (tsub' n t) (c2 ext')) ->
  CausalE ts (Time 0) e -> n = d + l -> traverseIf env ext e c1 c2 d l = Some c ->
  CausalC ts t c.
Proof.
  intros C1 C2 E N T. generalize dependent l. generalize dependent d. generalize dependent c.
  generalize dependent ext.
  induction n;intros.
  - symmetry in N. apply plus_is_O in N. destruct N. subst.
    simpl in *. cases (fromBLit (specialiseExp e env ext)) as L;tryfalse.
    rewrite tsub'_0, map_tsub'_0 in *.
    destruct b;option_inv_auto;auto.
  -  generalize dependent T. generalize dependent n. generalize dependent d.
     generalize dependent ext. generalize dependent c. induction l;intros.
    + simpl in *. cases (fromBLit (specialiseExp e env ext)) as L;tryfalse.
      destruct b;option_inv_auto;auto;
      apply smartTranslate_timed; constructor.
      eapply CausalC_open. apply all2_tle_tsub'. apply tle_tsub'. auto.
      rewrite <- plus_n_O in *. subst. auto.
    + simpl in T. cases (fromBLit (specialiseExp e env ext)) as L;tryfalse.
      destruct b;option_inv_auto;auto. apply smartTranslate_timed; constructor.
      eapply CausalC_open. apply all2_tle_tsub'. apply tle_tsub'. auto.
      assert (S n = S d + l) by omega.
      eapply IHl;eauto.
Qed.

Lemma specialise_timed ts t env ext  c :
  CausalC ts t c -> CausalC ts t (specialise c env ext).
Proof.
  intros T. generalize dependent env. generalize dependent ext.
  generalize dependent ts. generalize dependent t.
  induction c;intros; inversion T;clear T;subst;simpl; eauto 9 with SmartTimed.
  (* all cases except If are caught by eauto *)

  cases (traverseIf env ext e (specialise c1 env) (specialise c2 env) 0 n) as T;simpl;auto.
  eapply traverseIf_timed in T;eauto.
Qed.

Require Import TimedTyping.

Theorem specialise_preservation ts t env ext  c :
  TiTyC ts t c -> TypeEnvP (map type ts) env -> TypeExtP ext ->
  TiTyC ts t (specialise c env ext).
Proof.
  intros T Ev Ex. rewrite TiTyC_decompose in *. destruct T.
  split;eauto using specialise_typed, specialise_timed.
Qed.

End Timed.
Export Timed.


Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.PartialUnfold.

Section normalization_by_evaluation.
  Context (var : TypeCode -> Type).

  Definition pnormalize {T} (term : has_parse_term (normalized_of var) T) : has_parse_term var T
    := match term with
       | RFix2 G_length up_to_G_length f default valid_len valids nt_idx
         => RFix2 G_length up_to_G_length
                  (normalize f)
                  (normalize default)
                  valid_len valids nt_idx
       end.
End normalization_by_evaluation.

Definition polypnormalize {T} (term : polyhas_parse_term T) : polyhas_parse_term T
  := fun var => pnormalize (term _).


From Rela Require Import Loc.
From Rela Require Import Aexp.
Import AexpNotations.
From Rela Require Import Bexp.
Import BexpNotations.
From Rela Require Import Proc.
From Rela Require Import Sigma.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
Import ListNotations.

(** Definition of assertion **)

Definition assertion : Type := list sigma -> Prop.

(** Defintion of command and program **)

Inductive com : Type :=
| CSkip
| CAss (x : Loc.t) (a : aexp)
| CAssr (x : Loc.t) (a : aexp)
| CAssert (b: assertion )
| CSeq (p1 : com) (p2 : com)
| CIf (b : bexp) (p1 p2 : com)
| CWhile (b : bexp) (p : com) (inv : assertion)
| CCall (f: Proc.t).

(** Definition of procedure environment :
    a map from procedure name to the associated commands **)

Module Psi.

  Definition psi : Type := Proc.t -> com.

  Definition empty_psi: psi := fun _ => CSkip.
End Psi.

(** Evaluation command as a relation **)

Inductive ceval : com -> sigma -> Psi.psi -> sigma -> Prop :=
  | E_Skip : forall s ps,
      ceval CSkip s ps s
  | E_Ass : forall s ps x a n,
      aeval s a = n ->
      ceval (CAss x a) s ps (x !-> n ; s)
  | E_Assr : forall s ps x a n,
      aeval s a = n ->
      ceval (CAssr x a) s ps ((s x) !-> n ; s)
  | E_Assert: forall s ps (b : assertion),
      ceval (CAssert b) s ps s
  | E_IfTrue : forall s s' ps b p1 p2,
      beval s b = true ->
      ceval p1 s ps s' ->
      ceval (CIf b p1 p2) s ps s'
  | E_IfFalse : forall s s' ps b p1 p2,
      beval s b = false ->
      ceval p2 s ps s' ->
      ceval (CIf b p1 p2) s ps s'
  | E_Seq : forall s s' s'' ps p1 p2,
      ceval p1 s ps s' ->
      ceval p2 s' ps s'' ->
      ceval (CSeq p1 p2) s ps s''
  | E_WhileFalse : forall b s ps p inv,
      beval s b = false ->
      ceval (CWhile b p inv) s  ps s
  | E_WhileTrue : forall b s s' s'' ps p inv,
      beval s b = true ->
      ceval p s ps s' ->
      ceval (CWhile b p inv) s' ps s'' ->
      ceval (CWhile b p inv) s  ps s''
  | E_Call : forall s s' f ps,
      ceval ( ps f) s ps s' ->
      ceval (CCall f) s  ps s'
.

(** Facts about ceval **)

Lemma ceval_inf_loop s ps s' :
ceval (CWhile BTrue CSkip (fun _ => True)) s ps s' -> False.
Proof.
  intros Heval.
  remember (CWhile BTrue CSkip (fun _ : list Sigma.sigma => True)) as original_command eqn:Horig.
  induction Heval;try inversion Horig.
  * inversion Horig;subst. inversion H.
  * inversion Horig;subst.
    apply IHHeval2. reflexivity.
Qed.

(** Notations for program **)

Declare Scope com_scope.
Open Scope com_scope.
Declare Custom Entry com.

Module ComNotations.
Notation "<[ e ]>" := (e) (e custom com at level 0) : com_scope.
Notation "{ x }" := x (in custom com at level 0, x constr) : com_scope.
Notation "'skip'" := (CSkip) (in custom com at level 1) : com_scope.
Notation "x := y" := (CAss x y)
            (in custom com at level 89,
             x custom aexp,
             y custom aexp,
             no associativity) : com_scope.
Notation "'°' x := y" := (CAssr x y)
            (in custom com at level 89,
             x custom aexp,
             y custom aexp,
             no associativity) : com_scope.
Notation "'assert' b" := (CAssert b)
            (in custom com at level 89,
            b constr at level 0) : com_scope.
Notation "x ; y" := (CSeq x y)
           (in custom com at level 70, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=  (CIf x y z)
           (in custom com at level 89,
           x custom bexp at level 0,
           y custom com at level 0,
           z custom com at level 0) : com_scope.
Notation "'while' x 'inv' i 'do' y 'end'" := (CWhile x y i)
            (in custom com at level 89,
            x custom bexp at level 0,
            y custom com at level 0,
            i constr at level 0) : com_scope.
Notation "'call' f" := (CCall f)
            (in custom com at level 89,
            f constr at level 0) : com_scope.
End ComNotations.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* This is all of the LN infrastructure packed in a module for types. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax.
Require Export Cyclone_LN_Types.
Require Export Cyclone_LN_Terms.
(* Substituting a type into a term for a type variable. *)

Module TTM. (* T = Types TM = Terms *)

Fixpoint subst_e (tau : Tau) (alpha : var) (e : E) {struct e} : E :=
 match e with
   | v_e v         => v_e v
   | i_e i         => i_e i
   | p_e x p       => p_e x p
   | f_e f         =>        (f_e (subst_f  tau alpha f))
   | amp e'        => amp    (subst_e     tau alpha e')
   | star e'       => star   (subst_e     tau alpha e')
   | cpair e1 e2   => cpair  (subst_e     tau alpha e1) (subst_e tau alpha e2)
   | dot e' i      => dot    (subst_e     tau alpha e') i
   | assign e1 e2  => assign (subst_e     tau alpha e1) (subst_e tau alpha e2)
   | appl  e1 e2   => appl   (subst_e     tau alpha e1) (subst_e tau alpha e2)
   | call s        => call   (subst_st    tau alpha s)
   | inst e' t     => inst   (subst_e     tau alpha e') (T.subst tau alpha t)
   | pack t e' t'  => pack   (T.subst tau alpha t) (subst_e tau alpha e')
                             (T.subst tau alpha t')
 end
with subst_st (tau : Tau) (alpha : var) (s: St) {struct s} : St :=
  match s with
    | e_s e         => e_s      (subst_e tau alpha e)
    | retn e        => retn     (subst_e tau alpha e)
    | seq s1 s2     => seq      (subst_st tau alpha s1) (subst_st tau alpha s2)
    | if_s e s1 s2  => if_s     (subst_e tau alpha e)
                                (subst_st tau alpha s1) (subst_st tau alpha s2)
    | while e s     => while    (subst_e tau alpha e)   (subst_st tau alpha s)
    | letx e s      => letx     (subst_e tau alpha e)   (subst_st tau alpha s)
    | openx     e s  => openx     (subst_e tau alpha e)   (subst_st tau alpha s)
    | openstar e s  => openstar (subst_e tau alpha e)   (subst_st tau alpha s)
end
with subst_f (tau : Tau) (alpha : var) (f : F) {struct f} : F  :=
 match f with
   | (dfun tau1 tau2 s) =>
     (dfun (T.subst tau alpha tau1) (T.subst tau alpha tau2) (subst_st tau alpha s))
   | ufun k f => (ufun k (subst_f tau alpha f))
end.

Hint Resolve subst_e.
Hint Resolve subst_st.
Hint Resolve subst_f.

Notation "[ t 'TTM_e>'  alpha ] tm" := (subst_e  t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'TTM_st>' alpha ] tm" := (subst_st t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'TTM_f>'  alpha ] tm" := (subst_f  t alpha tm) (at level 68) : cyclone_scope.

Function subst (tau : Tau) (alpha : var) (t: Term) {struct t} : Term :=
  match t with
    | term_st s => term_st (subst_st tau alpha s)
    | term_e  e => term_e  (subst_e tau alpha e)
    | term_f  f => term_f  (subst_f tau alpha f)
  end.

Hint Resolve subst.

Notation "[ t 'TTM>' alpha ] tm" := (subst t alpha tm) (at level 68) : cyclone_scope.

(* Open a type binder in a term. *)

Definition open_rec_v (k : nat) (t : Tau) (v : V)  : V :=
  match v with
    | fevar i => fevar i
    | bevar i => bevar i
  end.

Fixpoint open_rec_st  (k : nat) (t : Tau) (s : St)  {struct s}  : St :=
 match s with
    | e_s  e        => e_s      (open_rec_e  k t e)
    | retn e        => retn     (open_rec_e  k t e)
    | seq s0 s1     => seq      (open_rec_st k t s0) (open_rec_st k t s1)
    | if_s e s1 s2  => if_s     (open_rec_e  k t e)
                                (open_rec_st k t s1) (open_rec_st k t s2)
    | while e s     => while    (open_rec_e  k t e)  (open_rec_st k t s)
    | letx e s      => letx     (open_rec_e  k t e)  (open_rec_st k t s)
    | openx e s      => openx     (open_rec_e  k t e)  (open_rec_st k t s)
    | openstar e s  => openstar (open_rec_e  k t e)  (open_rec_st k t s)
  end
with open_rec_e   (k : nat) (t : Tau) (e : E) {struct e}  : E :=
  match e with
    | v_e v         => v_e (open_rec_v k t v)
    | i_e i         => i_e i
    | p_e x p       => p_e x p
    | f_e f         => f_e    (open_rec_f  k t f)
    | amp e         => amp    (open_rec_e  k t e)
    | star e        => star   (open_rec_e  k t e)
    | cpair e1 e2   => cpair  (open_rec_e  k t e1) (open_rec_e k t e2)
    | dot  e ipe    => dot    (open_rec_e  k t e) ipe
    | assign e1 e2  => assign (open_rec_e  k t e1) (open_rec_e k t e2)
    | appl e1 e2    => appl   (open_rec_e  k t e1) (open_rec_e k t e2)
    | call s        => call   (open_rec_st k t s)
    | inst e t'      => inst   (open_rec_e  k t e) (T.open_rec k t t')
    | pack t0 e t1  => pack   (T.open_rec k t t0) (open_rec_e k t e) (T.open_rec k t t1)
end
with open_rec_f   (k : nat) (t : Tau) (f : F) {struct f} : F :=
  match f with
    | dfun tau1 tau2 s => dfun (T.open_rec k t tau1) (T.open_rec k t tau2)
                               (open_rec_st k t s)
    | ufun k' f        => ufun k' (open_rec_f k t f)
  end.

Function open_rec  (k : nat) (t : Tau) (T : Term) : Term :=
  match T with
    | term_st s    => term_st (open_rec_st k t s)
    | term_e  e    => term_e  (open_rec_e  k t e)
    | term_f  f    => term_f  (open_rec_f  k t f)
  end.

Definition open t T := open_rec 0 t T.

Notation "{ k TTM_v> u } t"  := (open_rec_v k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM_e> u } t"  := (open_rec_e k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM_st> u } t" := (open_rec_st k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM_f> u } t"  := (open_rec_f k u t) (at level 67) : cyclone_scope.
Notation "{ k TTM> u }   t"  := (open_rec k u t) (at level 67) : cyclone_scope.

Notation "t 'TTM^^' u"    := (open u t)       (at level 67) : cyclone_scope.
Notation "t 'TTM^' alpha" := (open alpha t)   (at level 67) : cyclone_scope.

(* Closing a type variable in a term. *)

Function close_rec_v (k : nat) (v : var) (v' : V) {struct v}  : V := v'.

Fixpoint close_rec_st  (k : nat) (v : var) (s : St)  {struct s}  : St :=
 match s with
    | e_s  e        => e_s      (close_rec_e  k v e)
    | retn e        => retn     (close_rec_e  k v e)
    | seq s0 s1     => seq      (close_rec_st k v s0) (close_rec_st k v s1)
    | if_s e s1 s2  => if_s     (close_rec_e  k v e)
                                (close_rec_st k v s1) (close_rec_st k v s2)
    | while e s     => while    (close_rec_e  k v e)  (close_rec_st k v s)
    | letx e s      => letx     (close_rec_e  k v e)  (close_rec_st k v s)
    | openx e s     => openx    (close_rec_e  k v e)  (close_rec_st k v s)
    | openstar e s  => openstar (close_rec_e  k v e)  (close_rec_st k v s)
  end
with close_rec_e   (k : nat) (v : var) (e : E) {struct e}  : E :=
  match e with
    | v_e v'        => v_e (close_rec_v k v v')
    | i_e i         => i_e i
    | p_e x p       => p_e (close_rec_v k v x) p
    | f_e f         => f_e    (close_rec_f  k v f)
    | amp e         => amp    (close_rec_e  k v e)
    | star e        => star   (close_rec_e  k v e)
    | cpair e1 e2   => cpair  (close_rec_e  k v e1) (close_rec_e k v e2)
    | dot  e ipe    => dot    (close_rec_e  k v e) ipe
    | assign e1 e2  => assign (close_rec_e  k v e1) (close_rec_e k v e2)
    | appl e1 e2    => appl   (close_rec_e  k v e1) (close_rec_e k v e2)
    | call s        => call   (close_rec_st k v s)
    | inst e t      => inst   (close_rec_e  k v e) (T.close_rec k v t)
    | pack t0 e t1  => pack   (T.close_rec     k v t0)
                              (close_rec_e  k v e) (T.close_rec k v t1)
end
with close_rec_f   (k : nat) (v : var) (f : F) {struct f} : F :=
  match f with
    | dfun tau1 tau2 s => dfun (T.close_rec k v tau1) (T.close_rec k v tau2)
                               (close_rec_st k v s)
    | ufun k' f        => ufun k' (close_rec_f k v f)
  end.

Notation "{ k <TTM_e alpha } t" := (close_rec_e k alpha t) (at level 67) : cyclone_scope.
Notation "{ k <TTM_st alpha } t" := (close_rec_st k alpha t) (at level 67) : cyclone_scope.
Notation "{ k <TTM_f alpha } t" := (close_rec_f k alpha t) (at level 67) : cyclone_scope.

Function close_rec  (k : nat) (v : var) (t : Term) : Term :=
  match t with
    | term_st s    => term_st (close_rec_st k v s)
    | term_e  e    => term_e  (close_rec_e  k v e)
    | term_f  f    => term_f  (close_rec_f  k v f)
  end.

Definition close v t := close_rec 0 v t.

Notation "{ k <TTM alpha } t" := (T.close_rec k alpha t) (at level 67) : cyclone_scope.

(* Free type variables of a term. *)

Function fv_v (v : V) : vars :=
  match v with
    | (bevar i) => \{}
    | (fevar x) => \{}
  end.

Hint Extern 1 (_ \notin fv_v _) => simpl; notin_solve.

Fixpoint fv_st (t : St) {struct t} : vars :=
  match t with
    | e_s  e       => fv_e e
    | retn e       => fv_e e
    | seq s0 s1    => (fv_st s0) \u (fv_st s1)
    | if_s e s0 s1 => (fv_e e) \u (fv_st s0) \u (fv_st s1)
    | while e s0   => (fv_e e) \u (fv_st s0)
    | letx e s     => (fv_e e) \u (fv_st s)
    | openx e s     => (fv_e e) \u (fv_st s)
    | openstar e s => (fv_e e) \u (fv_st s)
  end
with  fv_e (e : E) {struct e} : vars :=
  match e with
    | v_e v         => fv_v v
    | i_e  i        => \{}
    | p_e x _       => \{}
    | f_e f         => fv_f f
    | amp e         => fv_e e
    | star e        => fv_e e
    | cpair e0 e1   => (fv_e e0) \u (fv_e e1)
    | dot e _       => fv_e e
    | assign e1 e2  => (fv_e e1) \u (fv_e e2)
    | appl e1 e2    => (fv_e e1) \u (fv_e e2)
    | call s        => fv_st s
    | inst e t      => (fv_e e) \u (T.fv t)
    | pack t0 e t1  => (T.fv t0) \u (fv_e e) \u (T.fv t1)
  end
with  fv_f (f : F) {struct f} : vars :=
  match f with
  | dfun t1 t2 s    => (T.fv t1) \u (T.fv t2) \u (fv_st s)
  | ufun k f        => fv_f f
end.

Hint Extern 1 (_ \notin fv_st _) => simpl; notin_solve.
Hint Extern 1 (_ \notin fv_e _) => simpl; notin_solve.
Hint Extern 1 (_ \notin fv_f _) => simpl; notin_solve.

Function fv (t : Term) {struct t} : vars :=
  match t with
    | term_st s    => fv_st s
    | term_e  e    => fv_e e
    | term_f  f    => fv_f f
 end.

Hint Extern 1 (_ \notin fv _) => simpl; notin_solve.

Definition closed x := fv x = \{}.

(* Is a term locally closed on type variables. *)

Inductive lc_v : V -> Prop :=
 | lc_fevar : forall x, lc_v (fevar x).

Inductive lc_st : St -> Prop :=
 | lc_st_e_s  : forall e, lc_e  e -> lc_st (e_s e)
 | lc_retn    : forall e, lc_e  e -> lc_st (retn e)
 | lc_seq     : forall s0 s1, lc_st s0 -> lc_st s1 -> lc_st (seq s0 s1)
 | lc_if      : forall e s0 s1, lc_e  e -> lc_st s0 -> lc_st s1 ->
                                    lc_st (if_s e s0 s1)
 | lc_while   : forall e s, lc_e  e -> lc_st s -> lc_st (while e s)
 | lc_st_letx : forall e s,
                       lc_e  e -> lc_st s ->
                       lc_st (letx e s)
 | lc_open   : forall e s,
                     lc_e  e -> lc_st s -> lc_st (openx e s)
 | lc_openstar  : forall e s,
                        lc_e  e -> lc_st s -> lc_st (openstar e s)
with      lc_e : E -> Prop :=
 | lc_v_e     : forall v, lc_v v -> lc_e (v_e v)
 | lc_i_e     : forall i, lc_e  (i_e i)
 | lc_p_e     : forall x p, lc_e  (v_e (fevar x)) -> lc_e  (p_e (fevar x) p)
 | lc_f_e     : forall f, lc_f f -> lc_e  (f_e f)
 | lc_amp     : forall e, lc_e  e -> lc_e  (amp e)
 | lc_star    : forall e, lc_e  e -> lc_e  (star e)
 | lc_cpair   : forall e0 e1, lc_e  e0 -> lc_e  e1 -> lc_e  (cpair e0 e1)
 | lc_dot     : forall e ipe, lc_e  e -> lc_e  (dot e ipe)
 | lc_assign  : forall e1 e2, lc_e  e1 -> lc_e  e2 -> lc_e  (appl e1 e2)
 | lc_appl    : forall e1 e2, lc_e  e1 -> lc_e  e2 -> lc_e  (appl e1 e2)
 | lc_call    : forall s, lc_st s -> lc_e  (call s)
 | lc_inst    : forall e t, lc_e  e -> T.lc t -> lc_e  (inst e t)
 | lc_pack    : forall t0 e t1, T.lc t0 -> lc_e  e -> T.lc t1 ->
                                lc_e  (pack t0 e t1)
with      lc_f : F -> Prop :=
 | lc_dfun : forall t1 t2 s, T.lc t1 -> T.lc t2 -> lc_st s ->
                                     lc_f (dfun t1 t2 s)
 | lc_ufun : forall k f, lc_f f -> lc_f (ufun k f).

Inductive lc : Term -> Prop :=
  | lc_as_st : forall s, lc_st s -> lc (term_st s)
  | lc_as_e  : forall e, lc_e  e -> lc (term_e  e)
  | lc_as_f  : forall f, lc_f  f -> lc (term_f  f).

Scheme lc_st_ind_mutual := Induction for lc_st Sort Prop
with   lc_e_ind_mutual  := Induction for lc_e Sort Prop
with   lc_f_ind_mutual  := Induction for lc_f Sort Prop.
Combined Scheme lc_ind_mutual from lc_st_ind_mutual, lc_e_ind_mutual, lc_f_ind_mutual.

Hint Constructors lc_st.
Hint Constructors lc_e.
Hint Constructors lc_f.
Hint Constructors lc.

Definition body t :=
  exists L, forall alpha, alpha \notin L -> lc (open (ftvar alpha) t).

Definition body_st t :=
  exists L, forall alpha, alpha \notin L -> lc_st (open_rec_st 0 (ftvar alpha) t).

End TTM.


(** Coq coding by choukh, May 2022 **)

From ZF Require Import Basic.

(*** 序数 ***)
Section Ordinal.
Context {𝓜 : ZF}.
Implicit Type P : 𝓜 → Prop.
Implicit Type R : 𝓜 → 𝓜 → Prop.

Inductive Ord : 𝓜 → Prop :=
  | Ord_S x : x ∈ₚ Ord → x⁺ ∈ₚ Ord
  | Ord_U x : x ⊆ₚ Ord → ⋃ x ∈ₚ Ord.

Lemma 空集是序数 : ∅ ∈ₚ Ord.
Proof. rewrite <- 并空. constructor. zf. Qed.

Lemma Ord传递 : Ord ⊑ 传递.
Proof. induction 1. now apply 后继传递. now apply 并传递. Qed.

Lemma Ord传递类 : 传递类 Ord.
Proof.
  intros α β αβ βO. induction βO as [β βO IH|β βO IH].
  - apply 后继 in αβ as [->|]; auto.
  - apply 并集 in αβ as [γ []]. eapply IH; eauto.
Qed.

(** 整体良序 **)

Lemma Ord对关系的归纳法 R :
  (∀ x y, R x y → R y x → R x⁺ y) →
  (∀ x y, (∀ z, z ∈ x → R z y) → R (⋃ x) y) →
  ∀ x y ∈ₚ Ord, R x y.
Proof.
  intros H1 H2 x xO y. revert y.
  induction xO as [x _ IHx|x xO IHx]; intros y yO.
  - apply H1. apply IHx. apply yO.
    induction yO as [y yO IHy|y _ IHy].
    + apply H1. apply IHy. apply IHx. apply yO.
    + apply H2. apply IHy.
  - apply H2. intros z zx. now apply IHx.
Qed.

Lemma Ord弱线序_引理 : ∀ x y ∈ₚ Ord, x ⊆ y ∨ y⁺ ⊆ x.
Proof.
  apply Ord对关系的归纳法.
  - intros x y [xy|pyx] [yx|pxy]; auto.
    + right. rewrite (外延 xy yx). zf.
    + right. enough (x ⊆ x⁺) by firstorder. zf.
  - intros x y H. 排中 (∃ z ∈ x, z ⊈ y) as [[z [zx zny]]|false].
    + right. destruct (H z zx) as [zy|pzy]. easy.
      enough (z ⊆ ⋃ x). zf. now apply 并得父集.
    + left. apply 并得子集. intros z zx. 反证.
      apply false. now exists z.
Qed.

Lemma Ord弱线序 x y : x ∈ₚ Ord → y ∈ₚ Ord → x ⊆ y ∨ y ⊆ x.
Proof. intros xO yO. destruct (Ord弱线序_引理 xO yO); zf. Qed.

Lemma Ord线序 x y : x ∈ₚ Ord → y ∈ₚ Ord → x ⊆ y ∨ y ∈ x.
Proof. intros xO yO. destruct (Ord弱线序_引理 xO yO); zf. Qed.

Lemma Ord三歧 x y : x ∈ₚ Ord → y ∈ₚ Ord → x = y ∨ x ∈ y ∨ y ∈ x.
Proof.
  intros xO yO. destruct (Ord线序 xO yO); auto.
  destruct (Ord线序 yO xO); auto. left. now apply 外延.
Qed.

(* Ord与任意类的非空交有⊆最小元 *)
Lemma Ord良基 P x : x ∈ₚ Ord ⊓ P → ex (最小 (Ord ⊓ P)).
Proof.
  intros [xO xP]. induction (正则 x) as [x _ IH].
  排中 (∃ y ∈ x, y ∈ₚ Ord ∧ y ∈ₚ P) as [[y [yx [yO yP]]]|].
  - now apply (IH y).
  - exists x. repeat split; auto. intros y [yO yP].
    destruct (Ord线序 xO yO). auto.
    contradict H. now exists y.
Qed.

(** 内部良序 **)

Definition ϵ反自反 A := ∀ a ∈ A, a ∉ a.
Definition ϵ传递 A := ∀ a b c ∈ A, a ∈ b → b ∈ c → a ∈ c.
Definition ϵ偏序 A := ϵ反自反 A ∧ ϵ传递 A.

Definition ϵ三歧 A := ∀ a b ∈ A, a = b ∨ a ∈ b ∨ b ∈ a.
Definition ϵ线序 A := ϵ偏序 A ∧ ϵ三歧 A.

Definition ϵ最小 := λ A m, m ∈ A ∧ ∀ x ∈ A, m ⊆ x.
Definition ϵ良基 A := ∀ B, 非空 B → B ⊆ A → ex (ϵ最小 B).
Definition ϵ良序 A := ϵ线序 A ∧ ϵ良基 A.

Lemma Ord_ϵ反自反 : Ord ⊑ ϵ反自反.
Proof. intros _ _ x _. apply 无循环1. Qed.

Lemma Ord_ϵ传递 : Ord ⊑ ϵ传递.
Proof.
  induction 1 as [α _ IH|A HA IH].
  - intros x [->|]%后继 y [->|]%后继 z [->|]%后继 xy yz; trivial.
    + exfalso. eapply 无循环2; eauto.
    + exfalso. eapply 无循环3; eauto.
    + exfalso. eapply 无循环2; eauto.
    + eapply IH. 4:apply xy. all: trivial.
  - intros x [α [xα αA]]%并集 y [β [yβ βA]]%并集 z [γ [zγ γA]]%并集 xy yz.
    assert (tr: γ ∈ₚ 传递). apply Ord传递, HA, γA.
    assert (yγ: y ∈ γ). eapply tr; eauto.
    assert (xγ: x ∈ γ). eapply tr; eauto.
    assert (ϵtr: γ ∈ₚ ϵ传递). apply IH, γA.
    eapply ϵtr. 4:apply xy. all: trivial.
Qed.

Lemma Ord_ϵ三歧 : Ord ⊑ ϵ三歧.
Proof.
  induction 1 as [α _ IH|A HA IH].
  - intros x [->|]%后继 y [->|]%后继; firstorder.
  - intros x [α [xα αA]]%并集 y [β [yβ βA]]%并集.
    destruct (@Ord弱线序 α β). 1-2:apply HA; trivial.
    + apply H in xα. apply IH in βA. apply βA; trivial.
    + apply H in yβ. apply IH in αA. apply αA; trivial.
Qed.

Lemma Ord_ϵ良基 : Ord ⊑ ϵ良基.
Proof with zf; eauto.
  destruct 1 as [α αO|A HA].
  - intros A [β βA] sub.
    destruct (@Ord良基 (λ x, x ∈ A) β) as [μ [[μO μB] min]]. split...
    + apply sub in βA as [->|]%后继... apply Ord传递类 with α...
    + exists μ. split... intros x xA. apply min. split...
      apply sub in xA as [->|]%后继... apply Ord传递类 with α...
  - intros B [β βB] sub.
    destruct (@Ord良基 (λ x, x ∈ B) β) as [μ [[μO μB] min]]. split...
    + apply sub in βB as [γ [βγ γA]]%并集. apply Ord传递类 with γ...
    + exists μ. split... intros x xB. apply min. split...
      apply sub in xB as [γ [βγ γA]]%并集. apply Ord传递类 with γ...
Qed.

(** 等价于ϵ良序传递集之类 **)

Lemma ϵ线序集对子集封闭 A B : B ⊆ A → ϵ线序 A → ϵ线序 B.
Proof with auto.
  intros ub lin. repeat split.
  - intros x Hx. apply lin...
  - intros x Hx y Hy z Hz. apply lin...
  - intros x Hx y Hy. apply lin...
Qed.

Lemma ϵ良基集对子集封闭 A B : B ⊆ A → ϵ良基 A → ϵ良基 B.
Proof. intros BA wf C ne CB. apply wf; auto. firstorder. Qed.

Lemma ϵ良序集对子集封闭 A B : B ⊆ A → ϵ良序 A → ϵ良序 B.
Proof with auto.
  intros sub [lin wf]. split.
  - apply ϵ线序集对子集封闭 with A...
  - apply ϵ良基集对子集封闭 with A...
Qed.

Definition ϵ良序传递 A := ϵ良序 A ∧ 传递 A.

Lemma ϵ良序传递_传递类 : 传递类 ϵ良序传递.
Proof with auto.
  intros β α Hβα [wo tr]. split.
  - apply ϵ良序集对子集封闭 with α... apply 传递_子集表述...
  - intros δ γ Hδγ Hγβ.
    assert (Hγα: γ ∈ α). apply tr with β...
    assert (Hδα: δ ∈ α). apply tr with γ...
    apply wo with γ...
Qed.

Lemma ϵ良序传递_反自反 α : ϵ良序传递 α → α ∉ α.
Proof. intros αO 反设. cut (α ∉ α); auto. apply αO; auto. Qed.

Lemma ϵ良序传递_传递 α β γ : ϵ良序传递 γ → α ∈ β → β ∈ γ → α ∈ γ.
Proof. intros. eapply H; eauto. Qed.

Lemma ϵ良序传递_强序等价 α β : ϵ良序传递 α → ϵ良序传递 β → α ∈ β ↔ α ⊂ β.
Proof with auto.
  intros αO βO. split.
  - split. apply 传递_子集表述... apply βO.
    intros sub. apply ϵ良序传递_反自反 with α...
  - intros [αβ βα]. set (β ∩ₚ (λ x, x ∉ α)) as δ.
    assert (wf: ϵ良基 β) by apply βO.
    destruct (wf δ) as [μ [[μβ μα]%分离 min]].
    + apply 非子集 in βα as [γ Hγ]. exists γ. apply 分离...
    + intros x []%分离...
    + assert (μO: ϵ良序传递 μ). apply ϵ良序传递_传递类 with β...
      replace α with μ... apply 外延; intros x Hx; 反证.
      * assert (xδ: x ∈ δ). apply 分离. split... apply βO with μ...
        apply min in xδ. apply xδ in Hx. apply 无循环1 with x...
      * apply αβ in Hx as xβ. assert (tri: ϵ三歧 β) by apply βO.
        destruct (tri x xβ μ μβ) as [->|[]]...
        apply μα. apply αO with x...
Qed.

Notation "a ⋸ b" := (a = b ∨ a ∈ b) (at level 70).

Lemma ϵ良序传递_弱序等价 α β : ϵ良序传递 α → ϵ良序传递 β → α ⊆ β ↔ α ⋸ β.
Proof with zf.
  intros αO βO. split.
  - intros. 排中 (β ⊆ α). left. apply 外延... right. apply ϵ良序传递_强序等价...
  - intros [->|]... apply ϵ良序传递_强序等价...
Qed.

Lemma ϵ良序传递_对二元交封闭 α β : ϵ良序传递 α → ϵ良序传递 β → ϵ良序传递 (α ∩ₚ (λ x, x ∈ β)).
Proof with eauto.
  intros [woα trα] [woβ trβ]. split.
  - apply ϵ良序集对子集封闭 with α... intros x []%分离...
  - intros δ γ δγ [γα γβ]%分离.
    apply 分离. split. eapply trα... eapply trβ...
Qed.

Lemma ϵ良序传递_三歧 α β : ϵ良序传递 α → ϵ良序传递 β → α = β ∨ α ∈ β ∨ β ∈ α.
Proof with auto.
  intros αO βO.
  assert (iO: ϵ良序传递 (α ∩ₚ (λ x, x ∈ β))). apply ϵ良序传递_对二元交封闭...
  assert (H1: α ∩ₚ (λ x, x ∈ β) ⊆ α). intros x []%分离...
  assert (H2: α ∩ₚ (λ x, x ∈ β) ⊆ β). intros x []%分离...
  apply ϵ良序传递_弱序等价 in H1 as [H1|H1], H2 as [H2|H2]...
  - left. congruence.
  - right. left. congruence.
  - right. right. congruence.
  - exfalso. apply ϵ良序传递_反自反 with (α ∩ₚ (λ x, x ∈ β))... apply 分离...
Qed.

Lemma ϵ良序传递_弱线序 α β : ϵ良序传递 α → ϵ良序传递 β → α ⊆ β ∨ β ⊆ α.
Proof.
  intros αO βO. destruct (ϵ良序传递_三歧 αO βO) as [->|[]]; zf.
  - left. apply ϵ良序传递_弱序等价; auto.
  - right. apply ϵ良序传递_弱序等价; auto.
Qed.

Lemma ϵ良序传递_线序 α β : ϵ良序传递 α → ϵ良序传递 β → α ⊆ β ∨ β ∈ α.
Proof.
  intros αO βO. destruct (ϵ良序传递_三歧 αO βO) as [->|[]]; zf.
  left. apply ϵ良序传递_弱序等价; auto.
Qed.

Lemma ϵ良序传递_良基 P x : x ∈ₚ ϵ良序传递 ⊓ P → ex (最小 (ϵ良序传递 ⊓ P)).
Proof with eauto.
  intros [xO xP]. 排中 (最小 (ϵ良序传递 ⊓ P) x). exists x...
  assert (wf: ϵ良基 x). apply xO.
  destruct (wf (x ∩ₚ P)) as [μ [[μx μP]%分离 min]]...
  - apply 非空I. intros H0. apply H. split...
    intros y [yO yP]. destruct (@ϵ良序传递_线序 x y)...
    exfalso. eapply 空集. rewrite <- H0. apply 分离...
  - intros y []%分离...
  - assert (μO: ϵ良序传递 μ). apply ϵ良序传递_传递类 with x...
    exists μ. split... intros y [yO yP]. destruct (@ϵ良序传递_线序 μ y)...
    apply min, 分离. split... apply xO with μ...
Qed.

Lemma ϵ良序传递集之集_ϵ良序 A : A ⊆ₚ ϵ良序传递 → ϵ良序 A.
Proof with auto.
  intros. repeat split; intros α Hα.
  - apply ϵ良序传递_反自反...
  - intros β _ γ Hγ. apply ϵ良序传递_传递...
  - intros β Hβ. apply ϵ良序传递_三歧...
  - intros sub. destruct Hα as [β βα].
    destruct (@ϵ良序传递_良基 (λ x, x ∈ α) β) as [μ [[μO μα] min]]...
    exists μ. split...
Qed.

Lemma ϵ良序传递集之传递集 A : A ⊆ₚ ϵ良序传递 → 传递 A → ϵ良序传递 A.
Proof. intros sub tr. split; trivial. apply ϵ良序传递集之集_ϵ良序; auto. Qed.

Lemma ϵ良序传递_后继 α : ϵ良序传递 α → ϵ良序传递 α⁺.
Proof.
  intros αO. apply ϵ良序传递集之传递集.
  - intros x Hx. apply 后继 in Hx as [->|]; trivial.
    eapply ϵ良序传递_传递类; eauto.
  - apply 后继传递, αO.
Qed.

Lemma ϵ良序传递_二分 α : α ∈ₚ ϵ良序传递 → (∃ β, α = β⁺) ∨ α = ⋃ α.
Proof with zf.
  intros Hα. 排中 (α = ⋃ α) as [|neq]... left.
  assert (sub: α ⊈ ⋃ α). {
    intros sub. apply neq. apply 外延...
    apply 并得子集, 传递_子集表述, Hα.
  }
  apply 非子集 in sub as [β [Hβ Hβ']].
  exists β. 反证. destruct (@ϵ良序传递_三歧 β⁺ α) as [|[]]...
  - apply ϵ良序传递_后继, ϵ良序传递_传递类 with α...
  - apply Hβ'. apply 并集. exists β⁺...
  - apply 后继 in H as [->|].
    eapply 无循环1; eauto. eapply 无循环2; eauto.
Qed.

Theorem Ord_ϵ良序传递 α : α ∈ₚ Ord ↔ α ∈ₚ ϵ良序传递.
Proof with zf. split.
  - intros αO. split. 2:apply Ord传递... repeat split.
    apply Ord_ϵ反自反... apply Ord_ϵ传递... apply Ord_ϵ三歧... apply Ord_ϵ良基...
  - intros H. induction (正则 α) as [α _ IH].
    destruct (ϵ良序传递_二分 H) as [[β ->]| ->]; constructor.
    + apply IH. zf. apply ϵ良序传递_传递类 with β⁺...
    + intros β βα. apply IH... apply ϵ良序传递_传递类 with α...
Qed.

End Ordinal.