Require Import Undecidability.Shared.Libs.PSL.Bijection. (* [injective] *)
From Undecidability.TM Require Import ProgrammingTools.
From Undecidability Require Import TM.Code.CompareValue.
From Undecidability Require Import TM.Code.CasePair TM.Code.CaseList.
From Undecidability.TM.Hoare Require Import Hoare HoareLegacy.

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

Set Default Proof Using "Type".
(* * Lookup an entry in an associative list *)

Section LookupAssociativeList.

  Variable (sigX sigY : finType).
  Variable (X : eqType) (Y : Type) (cX : codable sigX X) (cY : codable sigY Y).

  Notation sig := (sigList (sigPair sigX sigY)).

  Hypothesis (cX_injective : injective cX).

  Fixpoint lookup (x : X) (xs : list (X * Y)) {struct xs} : option Y :=
    match xs with
    | nil => None
    | (x', y) :: xs' => if Dec (x = x') then Some y else lookup x xs'
    end.

  Local Definition retr_sig_sigX : Retract sigX sig := _.
  Local Definition retr_sig_sigY : Retract sigY sig := _.

  Definition Lookup_Step : pTM sig^+ (option bool) 4 :=
    If (CaseList (FinType(EqType(sigPair sigX sigY))) @ [|Fin0; Fin2|] )
       (CasePair _ _  ⇑ _ @ [|Fin2; Fin3|];;
        If (CompareValues _ ⇑ retr_sig_sigX  @ [|Fin1; Fin3|])
           (Return (MoveValue _ @ [|Fin2; Fin1|];; Reset _ @ [|Fin3|];; Reset _ @ [|Fin0|]) (Some true))
           (Return (Reset _ @ [|Fin3|];; Reset _ @ [|Fin2|]) None))
       (Return (ResetEmpty1 _ @ [|Fin0|]) (Some false)).

  Definition Lookup_Step_size {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (xs : list (X*Y)) (x:X) : Vector.t (nat->nat) 4 :=
    match xs with
    | (x', y) :: xs' =>
      if Dec (x=x')
      then [| (*0*) CaseList_size0 (x', y) >> Reset_size xs';
              (*1*) MoveValue_size_y y x; (* [CompareValue] doesn't use space *)
              (*2*) CaseList_size1 (x', y) >> CasePair_size0 x' >> MoveValue_size_x y;
              (*3*) CasePair_size1 x' >> Reset_size x' |]
      else [| (*0*) CaseList_size0 (x',y);
              (*1*) id; (* [CompareValue] doesn't use space *)
              (*2*) CaseList_size1 (x',y) >> CasePair_size0 x' >> Reset_size y;
              (*3*) CasePair_size1 x' >> Reset_size x' |]
    | nil => [| ResetEmpty1_size; id; id; id|]
    end.

  Definition Lookup_Step_steps_Compare {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (x x' : X) (y : Y) (xs : list (X*Y)) :=
    if Dec (x=x')
    then 2 + MoveValue_steps y x + Reset_steps x' + Reset_steps xs
    else 1 + Reset_steps x' + Reset_steps y.

  Definition Lookup_Step_steps_CaseList {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (xs : list (X*Y)) (x : X) :=
    match xs with
    | nil => ResetEmpty1_steps
    | (x',y) :: xs' => 2 + CompareValues_steps x x' + CasePair_steps x' + Lookup_Step_steps_Compare x x' y xs'
    end.

  Definition Lookup_Step_steps {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (xs : list (X*Y)) (x : X) :=
    1 + CaseList_steps xs + Lookup_Step_steps_CaseList xs x.

  Lemma Lookup_Step_SpecT_space (xs : list (X*Y)) (x : X) (ss : Vector.t nat 4) :
    TripleT
      (≃≃([],withSpace ([|Contains _ xs; Contains _ x; Void; Void|]) ss))
      (Lookup_Step_steps xs x)
      Lookup_Step
      (fun yout =>
         ≃≃([match xs with
                  | [] => yout = Some false
                | (x',y)::xs' => yout = if Dec (x=x') then Some true else None
         end], withSpace
           (match xs with
            | nil => [|Void; Contains _ x; Void; Void|]
            | (x',y) :: xs' =>
              if Dec (x=x') then [|Void; Contains _ y; Void; Void|] else [|Contains _ xs'; Contains _ x; Void; Void|]
           end)
              (appSize (Lookup_Step_size xs x) ss))).
  Proof using cX_injective.
    start_TM.
    unfold Lookup_Step. unfold Lookup_Step_size; cbn.
    eapply If_SpecTReg with (k1 := CaseList_steps xs) (k2 := Lookup_Step_steps_CaseList xs x) (k3 := Lookup_Step_steps_CaseList xs x).
    - hstep; cbn. apply CaseList_SpecT_size.
    - (* First "Then"; we have [xs = (x',y) :: xs']. *)
      cbn. destruct xs as [ | (x', y) xs']. all:hintros [=].
      hstep.
      + (* CasePair *)
        hstep; cbn. hstep; cbn. now hstep; cbn. cbn. tspec_ext.
      + cbn. intros _.
        eapply If_SpecTReg with (k1 := CompareValues_steps x x') (k2 := Lookup_Step_steps_Compare x x' y xs') (k3 := Lookup_Step_steps_Compare x x' y xs').
        * hsteps_cbn; cbn. apply CompareValue_SpecT_size with (X := X). assumption. cbn. tspec_ext.
        * cbn. hintros ->. (* Second "Then"; we have [x=x'] *) decide (x'=x') as [Hx | ]. 2:easy.
          hstep. (* Return *) hstep. (* Seq *)
          -- (* MoveValue *) hstep; cbn. apply MoveValue_SpecT_size with (X := Y) (Y := X).
          -- cbn. intros _. hstep. (* Seq *)
             ++ (* Reset X *) hstep; cbn.  apply Reset_SpecT_space with (X := X).
             ++ (* Reset Y *) cbn. intros _. hstep. cbn. apply Reset_SpecT_space with (X := list (X*Y)).
             ++ reflexivity.
          -- unfold Lookup_Step_steps_Compare. decide _. 2:easy. lia.
          -- cbn. intros _. tspec_ext.
        * cbn. hintros ?. (* "Else": We have [x<>x'] *) decide (x=x') as [ | Hx]. easy.
          hstep. hstep.
          -- hstep. cbn. eapply Reset_SpecT_space with (X := X).
          -- cbn. intros _. hstep. cbn. apply Reset_SpecT_space with (X := Y).
          -- unfold Lookup_Step_steps_Compare. dec_neg (x=x'). reflexivity.
          -- cbn. intros _. tspec_ext.
        * cbn. intros []. all:reflexivity.
      + cbn. lia.
    - cbn. hintros H'. (* The top-most "Else": We have [xs=nil] *) destruct xs as [ | ]. 2:easy.
      hstep. hstep; cbn. eapply ResetEmpty1_SpecT_space with (X := list (X*Y)). reflexivity. cbn. tspec_ext.
    - cbn. intros ? ->. destruct _;reflexivity.
  Qed.

  Definition Lookup_Loop := While Lookup_Step.

  Fixpoint Lookup_Loop_size {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (xs : list (X*Y)) (x : X) : Vector.t (nat->nat) 4 :=
    match xs with
    | nil => Lookup_Step_size xs x
    | (x',y) :: xs' =>
      if Dec(x=x')
      then Lookup_Step_size xs x
      else Lookup_Step_size xs x >>> Lookup_Loop_size xs' x
    end.

  Fixpoint Lookup_Loop_steps {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (x : X) (xs : list (X*Y)) { struct xs } :=
    match xs with
    | nil => Lookup_Step_steps xs x
    | (x',y) :: xs' => if Dec(x=x')
                      then Lookup_Step_steps xs x
                      else 1 + Lookup_Step_steps xs x + Lookup_Loop_steps x xs'
    end.

  Lemma Lookup_Loop_SpecT_space (xs : list (X*Y)) (x : X) (ss : Vector.t nat 4) :
  TripleT
    (≃≃([],withSpace ([|Contains _ xs; Contains _ x; Void; Void|]) ss))
    (Lookup_Loop_steps x xs) Lookup_Loop
    (fun yout =>
      tspec
        ([yout = match lookup x xs with Some _ => true | _ => false end], withSpace
            match lookup x xs with
            | Some y => [|Void; Contains _ y; Void; Void|]
            | None => [|Void; Contains _ x; Void; Void|]
            end (appSize (Lookup_Loop_size xs x) ss))).
  Proof using cX_injective.
  unfold Lookup_Loop.
  refine (While_SpecTReg
  (PRE := fun '(xs, x, ss) => (_,_)) (INV := fun '(xs, x, ss) y => (_,_)) (POST := fun '(xs, x, ss) y => (_,_))
  (f__step := fun '(xs,x,ss) => _) (f__loop := fun '(xs,x,ss) => _) _ _ ((xs,x,ss))); clear x xs ss; intros ((xs, x), ss).
  { apply Lookup_Step_SpecT_space. }
  cbn. split.
  - intros b Hb. set (sizeStep := Lookup_Step_size xs x);set (sizeLoop := Lookup_Loop_size xs x). destruct xs as [ | (x', y) xs'].
    + inv Hb. cbn. split. tspec_ext. reflexivity.
    + cbn - [sizeLoop sizeStep]. cbn in sizeStep,sizeLoop. decide (x=x'). 2:easy.
      inv Hb. split. 2:reflexivity. tspec_ext.
  -intros Hb.  set (sizeStep := Lookup_Step_size xs x);set (sizeLoop := Lookup_Loop_size xs x).
   destruct xs as [ | []]. easy. cbn - [sizeLoop sizeStep]. cbn in *|-.  decide _. easy.
    eexists (_, _, _); cbn - [sizeLoop sizeStep]. repeat apply conj.
    all:reflexivity.
  Qed.

  Definition Lookup : pTM sig^+ bool 5 :=
    CopyValue _ @ [|Fin0; Fin4|];; Lookup_Loop @ [|Fin4; Fin1; Fin2; Fin3|].

  Definition Lookup_size {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (xs : list (X*Y)) (x : X) : Vector.t (nat->nat) 5 :=
    ([|CopyValue_size xs|] @>> [|Fin4|]) >>>
    (Lookup_Loop_size xs x @>>[|Fin4; Fin1; Fin2; Fin3|]).

  Definition Lookup_Rel : pRel sig^+ bool 5 :=
    fun tin '(yout, tout) =>
      forall (xs : list (X*Y)) (x : X) (s0 s1 s2 s3 s4 : nat),
        let size := Lookup_size xs x in
        tin[@Fin0] ≃(;s0) xs ->
        tin[@Fin1] ≃(;s1) x ->
        isVoid_size tin[@Fin2] s2 -> isVoid_size tin[@Fin3] s3 -> isVoid_size tin[@Fin4] s4 ->
        match yout, lookup x xs with
        | true, Some y =>
          tout[@Fin0] ≃(;size@>Fin0 s0) xs /\
          tout[@Fin1] ≃(;size@>Fin1 s1) y /\
          isVoid_size tout[@Fin2] (size@>Fin2 s2) /\
          isVoid_size tout[@Fin3] (size@>Fin3 s3) /\
          isVoid_size tout[@Fin4] (size@>Fin4 s4)
        | false, None =>
          tout[@Fin0] ≃(;size@>Fin0 s0) xs /\
          tout[@Fin1] ≃(;size@>Fin1 s1) x /\
          isVoid_size tout[@Fin2] (size@>Fin2 s2) /\
          isVoid_size tout[@Fin3] (size@>Fin3 s3) /\
          isVoid_size tout[@Fin4] (size@>Fin4 s4)
        | _, _ => False
        end.

  Definition Lookup_steps {sigX sigY : Type} {X : eqType} {Y : Type} {cX : codable sigX X} {cY : codable sigY Y} (x : X) (xs : list (X*Y)) :=
    1 + CopyValue_steps xs + Lookup_Loop_steps x xs.

    Lemma Lookup_SpecT_space (xs : list (X*Y)) (x : X) (ss : Vector.t nat 5) :
    TripleT
      (≃≃([],withSpace ([|Contains _ xs; Contains _ x; Void; Void; Void|]) ss))
      (Lookup_steps x xs) Lookup
      (fun yout =>
         tspec
           ([yout = match lookup x xs with Some y => true | _ => false end],
           withSpace
           [|Contains _ xs; (match lookup x xs with Some y => Contains _ y | _ =>  Contains _ x end); Void; Void; Void|]
           (appSize (Lookup_size xs x) ss))).
  Proof using cX_injective.
    start_TM.
    unfold Lookup. hsteps_cbn; cbn.
    apply Lookup_Loop_SpecT_space.
    intros yout;cbn.
    hintros ->. destruct (lookup x xs); cbn. 1-2:now tspec_ext. reflexivity.
  Qed.

  (* Legacy Lemma *)
  Lemma Lookup_Realise : Lookup ⊨ Lookup_Rel.
  Proof using cX_injective.
    repeat (eapply RealiseIntroAll;intro). eapply Realise_monotone.
    -eapply TripleT_Realise, (Lookup_SpecT_space x x0 [|x1;x2;x3;x4;x5|]).
    -intros ? [] H **. modpon H.
    {unfold "≃≃",withSpace;cbn. intros i; destruct_fin i;cbn. all:assumption. }
    repeat destruct _;unfold "≃≃",withSpace in H;cbn in H;destruct H as [H' H].
    2,3:discriminate.
    all:specializeFin H;tauto.
  Qed.

  Definition Lookup_T : tRel sig^+ 5 :=
    fun tin k =>
      exists (xs : list (X*Y)) (x : X),
        tin[@Fin0] ≃ xs /\
        tin[@Fin1] ≃ x /\
        isVoid tin[@Fin2] /\ isVoid tin[@Fin3] /\ isVoid tin[@Fin4] /\
        Lookup_steps x xs <= k.

  (* legacy Lemma *)
  Lemma Lookup_Terminates : projT1 Lookup ↓ Lookup_T.
  Proof using cX_injective.
    repeat (eapply TerminatesInIntroEx;intro). eapply TerminatesIn_monotone.
    -eapply TripleT_TerminatesIn. eapply TripleT_RemoveSpace,Lookup_SpecT_space.
    -intros ? k H **. modpon H.
    split. 2:eassumption.
    unfold "≃≃",withSpace;cbn. intros i; destruct_fin i;cbn. all:assumption.
  Qed.

End LookupAssociativeList.

Arguments Lookup_steps {sigX sigY X Y cX cY} : simpl never.
Arguments Lookup_size {sigX sigY X Y cX cY} : simpl never.

Ltac hstep_LookupAssociativeList :=
  match goal with
  | [ |- TripleT ?P ?k (Lookup _ _) ?Q ] => eapply Lookup_SpecT_space
  end.


Require Import Coq.Arith.Wf_nat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metalib.Metatheory.
Require Export Metalib.LibLNgen.

Require Export syntaxn_ott.

(** NOTE: Auxiliary theorems are hidden in generated documentation.
    In general, there is a [_rec] version of every lemma involving
    [open] and [close]. *)

(* *********************************************************************** *)
(** * Induction principles for nonterminals *)

Scheme nexp_ind' := Induction for nexp Sort Prop.

Definition nexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 =>
  nexp_ind' H1 H2 H3 H4 H5 H6.

Scheme nexp_rec' := Induction for nexp Sort Set.

Definition nexp_mutrec :=
  fun H1 H2 H3 H4 H5 H6 =>
  nexp_rec' H1 H2 H3 H4 H5 H6.

(* *********************************************************************** *)
(** * Close *)

Fixpoint close_nexp_wrt_nexp_rec (n1 : nat) (x1 : var) (e1 : nexp) {struct e1} : nexp :=
  match e1 with
    | ne_var_f x2 => if (x1 == x2) then (ne_var_b n1) else (ne_var_f x2)
    | ne_var_b n2 => if (lt_ge_dec n2 n1) then (ne_var_b n2) else (ne_var_b (S n2))
    | ne_lit i => ne_lit i
    | ne_abs e2 => ne_abs (close_nexp_wrt_nexp_rec (S n1) x1 e2)
    | ne_app e2 e3 => ne_app (close_nexp_wrt_nexp_rec n1 x1 e2) (close_nexp_wrt_nexp_rec n1 x1 e3)
  end.

Definition close_nexp_wrt_nexp x1 e1 := close_nexp_wrt_nexp_rec 0 x1 e1.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_nexp (e1 : nexp) {struct e1} : nat :=
  match e1 with
    | ne_var_f x1 => 1
    | ne_var_b n1 => 1
    | ne_lit i => 1
    | ne_abs e2 => 1 + (size_nexp e2)
    | ne_app e2 e3 => 1 + (size_nexp e2) + (size_nexp e3)
  end.

(* *********************************************************************** *)
(** * Degree *)

(** These define only an upper bound, not a strict upper bound. *)

Inductive degree_nexp_wrt_nexp : nat -> nexp -> Prop :=
  | degree_wrt_nexp_ne_var_f : forall n1 x1,
    degree_nexp_wrt_nexp n1 (ne_var_f x1)
  | degree_wrt_nexp_ne_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_nexp_wrt_nexp n1 (ne_var_b n2)
  | degree_wrt_nexp_ne_lit : forall n1 i ,
    degree_nexp_wrt_nexp n1 (ne_lit i )
  | degree_wrt_nexp_ne_abs : forall n1 e1,
    degree_nexp_wrt_nexp (S n1) e1 ->
    degree_nexp_wrt_nexp n1 (ne_abs e1)
  | degree_wrt_nexp_ne_app : forall n1 e1 e2,
    degree_nexp_wrt_nexp n1 e1 ->
    degree_nexp_wrt_nexp n1 e2 ->
    degree_nexp_wrt_nexp n1 (ne_app e1 e2).

Scheme degree_nexp_wrt_nexp_ind' := Induction for degree_nexp_wrt_nexp Sort Prop.

Definition degree_nexp_wrt_nexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 =>
  degree_nexp_wrt_nexp_ind' H1 H2 H3 H4 H5 H6.

Hint Constructors degree_nexp_wrt_nexp : core lngen.

(* *********************************************************************** *)
(** * Local closure (version in [Set], induction principles) *)

Inductive lc_set_nexp : nexp -> Set :=
  | lc_set_ne_var_f : forall x1,
    lc_set_nexp (ne_var_f x1)
  | lc_set_ne_lit : forall i,
    lc_set_nexp (ne_lit i)
  | lc_set_ne_abs : forall e1,
    (forall x1 : var, lc_set_nexp (open_nexp_wrt_nexp e1 (ne_var_f x1))) ->
    lc_set_nexp (ne_abs e1)
  | lc_set_ne_app : forall e1 e2,
    lc_set_nexp e1 ->
    lc_set_nexp e2 ->
    lc_set_nexp (ne_app e1 e2).

Scheme lc_nexp_ind' := Induction for lc_nexp Sort Prop.

Definition lc_nexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 =>
  lc_nexp_ind' H1 H2 H3 H4 H5 H6.

Scheme lc_set_nexp_ind' := Induction for lc_set_nexp Sort Prop.

Definition lc_set_nexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 =>
  lc_set_nexp_ind' H1 H2 H3 H4 H5 H6.

Scheme lc_set_nexp_rec' := Induction for lc_set_nexp Sort Set.

Definition lc_set_nexp_mutrec :=
  fun H1 H2 H3 H4 H5 H6 =>
  lc_set_nexp_rec' H1 H2 H3 H4 H5 H6.

Hint Constructors lc_nexp : core lngen.

Hint Constructors lc_set_nexp : core lngen.

(* *********************************************************************** *)
(** * Body *)

Definition body_nexp_wrt_nexp e1 := forall x1, lc_nexp (open_nexp_wrt_nexp e1 (ne_var_f x1)).

Hint Unfold body_nexp_wrt_nexp : core.

(* *********************************************************************** *)
(** * Tactic support *)

(** Additional hint declarations. *)

Hint Resolve @plus_le_compat : lngen.

(** Redefine some tactics. *)

Ltac default_case_split ::=
  first
    [ progress destruct_notin
    | progress destruct_sum
    | progress safe_f_equal
    ].

(* *********************************************************************** *)
(** * Theorems about [size] *)

Ltac default_auto ::= auto with arith lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma size_nexp_min_mutual :
(forall e1, 1 <= size_nexp e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_nexp_min :
forall e1, 1 <= size_nexp e1.
Proof.
pose proof size_nexp_min_mutual as H; intuition eauto.
Qed.

Hint Resolve size_nexp_min : lngen.

(* begin hide *)

Lemma size_nexp_close_nexp_wrt_nexp_rec_mutual :
(forall e1 x1 n1,
  size_nexp (close_nexp_wrt_nexp_rec n1 x1 e1) = size_nexp e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_nexp_close_nexp_wrt_nexp_rec :
forall e1 x1 n1,
  size_nexp (close_nexp_wrt_nexp_rec n1 x1 e1) = size_nexp e1.
Proof.
pose proof size_nexp_close_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_nexp_close_nexp_wrt_nexp_rec : lngen.
Hint Rewrite size_nexp_close_nexp_wrt_nexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma size_nexp_close_nexp_wrt_nexp :
forall e1 x1,
  size_nexp (close_nexp_wrt_nexp x1 e1) = size_nexp e1.
Proof.
unfold close_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve size_nexp_close_nexp_wrt_nexp : lngen.
Hint Rewrite size_nexp_close_nexp_wrt_nexp using solve [auto] : lngen.

(* begin hide *)

Lemma size_nexp_open_nexp_wrt_nexp_rec_mutual :
(forall e1 e2 n1,
  size_nexp e1 <= size_nexp (open_nexp_wrt_nexp_rec n1 e2 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_nexp_open_nexp_wrt_nexp_rec :
forall e1 e2 n1,
  size_nexp e1 <= size_nexp (open_nexp_wrt_nexp_rec n1 e2 e1).
Proof.
pose proof size_nexp_open_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_nexp_open_nexp_wrt_nexp_rec : lngen.

(* end hide *)

Lemma size_nexp_open_nexp_wrt_nexp :
forall e1 e2,
  size_nexp e1 <= size_nexp (open_nexp_wrt_nexp e1 e2).
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve size_nexp_open_nexp_wrt_nexp : lngen.

(* begin hide *)

Lemma size_nexp_open_nexp_wrt_nexp_rec_var_mutual :
(forall e1 x1 n1,
  size_nexp (open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1) = size_nexp e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_nexp_open_nexp_wrt_nexp_rec_var :
forall e1 x1 n1,
  size_nexp (open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1) = size_nexp e1.
Proof.
pose proof size_nexp_open_nexp_wrt_nexp_rec_var_mutual as H; intuition eauto.
Qed.

Hint Resolve size_nexp_open_nexp_wrt_nexp_rec_var : lngen.
Hint Rewrite size_nexp_open_nexp_wrt_nexp_rec_var using solve [auto] : lngen.

(* end hide *)

Lemma size_nexp_open_nexp_wrt_nexp_var :
forall e1 x1,
  size_nexp (open_nexp_wrt_nexp e1 (ne_var_f x1)) = size_nexp e1.
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve size_nexp_open_nexp_wrt_nexp_var : lngen.
Hint Rewrite size_nexp_open_nexp_wrt_nexp_var using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [degree] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma degree_nexp_wrt_nexp_S_mutual :
(forall n1 e1,
  degree_nexp_wrt_nexp n1 e1 ->
  degree_nexp_wrt_nexp (S n1) e1).
Proof.
apply_mutual_ind degree_nexp_wrt_nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma degree_nexp_wrt_nexp_S :
forall n1 e1,
  degree_nexp_wrt_nexp n1 e1 ->
  degree_nexp_wrt_nexp (S n1) e1.
Proof.
pose proof degree_nexp_wrt_nexp_S_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_nexp_wrt_nexp_S : lngen.

Lemma degree_nexp_wrt_nexp_O :
forall n1 e1,
  degree_nexp_wrt_nexp O e1 ->
  degree_nexp_wrt_nexp n1 e1.
Proof.
induction n1; default_simp.
Qed.

Hint Resolve degree_nexp_wrt_nexp_O : lngen.

(* begin hide *)

Lemma degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec_mutual :
(forall e1 x1 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  degree_nexp_wrt_nexp (S n1) (close_nexp_wrt_nexp_rec n1 x1 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec :
forall e1 x1 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  degree_nexp_wrt_nexp (S n1) (close_nexp_wrt_nexp_rec n1 x1 e1).
Proof.
pose proof degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec : lngen.

(* end hide *)

Lemma degree_nexp_wrt_nexp_close_nexp_wrt_nexp :
forall e1 x1,
  degree_nexp_wrt_nexp 0 e1 ->
  degree_nexp_wrt_nexp 1 (close_nexp_wrt_nexp x1 e1).
Proof.
unfold close_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve degree_nexp_wrt_nexp_close_nexp_wrt_nexp : lngen.

(* begin hide *)

Lemma degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec_inv_mutual :
(forall e1 x1 n1,
  degree_nexp_wrt_nexp (S n1) (close_nexp_wrt_nexp_rec n1 x1 e1) ->
  degree_nexp_wrt_nexp n1 e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec_inv :
forall e1 x1 n1,
  degree_nexp_wrt_nexp (S n1) (close_nexp_wrt_nexp_rec n1 x1 e1) ->
  degree_nexp_wrt_nexp n1 e1.
Proof.
pose proof degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_nexp_wrt_nexp_close_nexp_wrt_nexp_rec_inv : lngen.

(* end hide *)

Lemma degree_nexp_wrt_nexp_close_nexp_wrt_nexp_inv :
forall e1 x1,
  degree_nexp_wrt_nexp 1 (close_nexp_wrt_nexp x1 e1) ->
  degree_nexp_wrt_nexp 0 e1.
Proof.
unfold close_nexp_wrt_nexp; eauto with lngen.
Qed.

Hint Immediate degree_nexp_wrt_nexp_close_nexp_wrt_nexp_inv : lngen.

(* begin hide *)

Lemma degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec_mutual :
(forall e1 e2 n1,
  degree_nexp_wrt_nexp (S n1) e1 ->
  degree_nexp_wrt_nexp n1 e2 ->
  degree_nexp_wrt_nexp n1 (open_nexp_wrt_nexp_rec n1 e2 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec :
forall e1 e2 n1,
  degree_nexp_wrt_nexp (S n1) e1 ->
  degree_nexp_wrt_nexp n1 e2 ->
  degree_nexp_wrt_nexp n1 (open_nexp_wrt_nexp_rec n1 e2 e1).
Proof.
pose proof degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec : lngen.

(* end hide *)

Lemma degree_nexp_wrt_nexp_open_nexp_wrt_nexp :
forall e1 e2,
  degree_nexp_wrt_nexp 1 e1 ->
  degree_nexp_wrt_nexp 0 e2 ->
  degree_nexp_wrt_nexp 0 (open_nexp_wrt_nexp e1 e2).
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve degree_nexp_wrt_nexp_open_nexp_wrt_nexp : lngen.

(* begin hide *)

Lemma degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec_inv_mutual :
(forall e1 e2 n1,
  degree_nexp_wrt_nexp n1 (open_nexp_wrt_nexp_rec n1 e2 e1) ->
  degree_nexp_wrt_nexp (S n1) e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec_inv :
forall e1 e2 n1,
  degree_nexp_wrt_nexp n1 (open_nexp_wrt_nexp_rec n1 e2 e1) ->
  degree_nexp_wrt_nexp (S n1) e1.
Proof.
pose proof degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_nexp_wrt_nexp_open_nexp_wrt_nexp_rec_inv : lngen.

(* end hide *)

Lemma degree_nexp_wrt_nexp_open_nexp_wrt_nexp_inv :
forall e1 e2,
  degree_nexp_wrt_nexp 0 (open_nexp_wrt_nexp e1 e2) ->
  degree_nexp_wrt_nexp 1 e1.
Proof.
unfold open_nexp_wrt_nexp; eauto with lngen.
Qed.

Hint Immediate degree_nexp_wrt_nexp_open_nexp_wrt_nexp_inv : lngen.

(* *********************************************************************** *)
(** * Theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_nexp_wrt_nexp_rec_inj_mutual :
(forall e1 e2 x1 n1,
  close_nexp_wrt_nexp_rec n1 x1 e1 = close_nexp_wrt_nexp_rec n1 x1 e2 ->
  e1 = e2).
Proof.
apply_mutual_ind nexp_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_nexp_wrt_nexp_rec_inj :
forall e1 e2 x1 n1,
  close_nexp_wrt_nexp_rec n1 x1 e1 = close_nexp_wrt_nexp_rec n1 x1 e2 ->
  e1 = e2.
Proof.
pose proof close_nexp_wrt_nexp_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate close_nexp_wrt_nexp_rec_inj : lngen.

(* end hide *)

Lemma close_nexp_wrt_nexp_inj :
forall e1 e2 x1,
  close_nexp_wrt_nexp x1 e1 = close_nexp_wrt_nexp x1 e2 ->
  e1 = e2.
Proof.
unfold close_nexp_wrt_nexp; eauto with lngen.
Qed.

Hint Immediate close_nexp_wrt_nexp_inj : lngen.

(* begin hide *)

Lemma close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec_mutual :
(forall e1 x1 n1,
  x1 `notin` fv_nexp e1 ->
  close_nexp_wrt_nexp_rec n1 x1 (open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1) = e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec :
forall e1 x1 n1,
  x1 `notin` fv_nexp e1 ->
  close_nexp_wrt_nexp_rec n1 x1 (open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1) = e1.
Proof.
pose proof close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec : lngen.
Hint Rewrite close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma close_nexp_wrt_nexp_open_nexp_wrt_nexp :
forall e1 x1,
  x1 `notin` fv_nexp e1 ->
  close_nexp_wrt_nexp x1 (open_nexp_wrt_nexp e1 (ne_var_f x1)) = e1.
Proof.
unfold close_nexp_wrt_nexp; unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve close_nexp_wrt_nexp_open_nexp_wrt_nexp : lngen.
Hint Rewrite close_nexp_wrt_nexp_open_nexp_wrt_nexp using solve [auto] : lngen.

(* begin hide *)

Lemma open_nexp_wrt_nexp_rec_close_nexp_wrt_nexp_rec_mutual :
(forall e1 x1 n1,
  open_nexp_wrt_nexp_rec n1 (ne_var_f x1) (close_nexp_wrt_nexp_rec n1 x1 e1) = e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_nexp_wrt_nexp_rec_close_nexp_wrt_nexp_rec :
forall e1 x1 n1,
  open_nexp_wrt_nexp_rec n1 (ne_var_f x1) (close_nexp_wrt_nexp_rec n1 x1 e1) = e1.
Proof.
pose proof open_nexp_wrt_nexp_rec_close_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve open_nexp_wrt_nexp_rec_close_nexp_wrt_nexp_rec : lngen.
Hint Rewrite open_nexp_wrt_nexp_rec_close_nexp_wrt_nexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma open_nexp_wrt_nexp_close_nexp_wrt_nexp :
forall e1 x1,
  open_nexp_wrt_nexp (close_nexp_wrt_nexp x1 e1) (ne_var_f x1) = e1.
Proof.
unfold close_nexp_wrt_nexp; unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve open_nexp_wrt_nexp_close_nexp_wrt_nexp : lngen.
Hint Rewrite open_nexp_wrt_nexp_close_nexp_wrt_nexp using solve [auto] : lngen.

(* begin hide *)

Lemma open_nexp_wrt_nexp_rec_inj_mutual :
(forall e2 e1 x1 n1,
  x1 `notin` fv_nexp e2 ->
  x1 `notin` fv_nexp e1 ->
  open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e2 = open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1 ->
  e2 = e1).
Proof.
apply_mutual_ind nexp_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_nexp_wrt_nexp_rec_inj :
forall e2 e1 x1 n1,
  x1 `notin` fv_nexp e2 ->
  x1 `notin` fv_nexp e1 ->
  open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e2 = open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1 ->
  e2 = e1.
Proof.
pose proof open_nexp_wrt_nexp_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate open_nexp_wrt_nexp_rec_inj : lngen.

(* end hide *)

Lemma open_nexp_wrt_nexp_inj :
forall e2 e1 x1,
  x1 `notin` fv_nexp e2 ->
  x1 `notin` fv_nexp e1 ->
  open_nexp_wrt_nexp e2 (ne_var_f x1) = open_nexp_wrt_nexp e1 (ne_var_f x1) ->
  e2 = e1.
Proof.
unfold open_nexp_wrt_nexp; eauto with lngen.
Qed.

Hint Immediate open_nexp_wrt_nexp_inj : lngen.

(* *********************************************************************** *)
(** * Theorems about [lc] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma degree_nexp_wrt_nexp_of_lc_nexp_mutual :
(forall e1,
  lc_nexp e1 ->
  degree_nexp_wrt_nexp 0 e1).
Proof.
apply_mutual_ind lc_nexp_mutind;
intros;
let x1 := fresh "x1" in pick_fresh x1;
repeat (match goal with
          | H1 : _, H2 : _ |- _ => specialize H1 with H2
        end);
default_simp; eauto with lngen.
Qed.

(* end hide *)

Lemma degree_nexp_wrt_nexp_of_lc_nexp :
forall e1,
  lc_nexp e1 ->
  degree_nexp_wrt_nexp 0 e1.
Proof.
pose proof degree_nexp_wrt_nexp_of_lc_nexp_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_nexp_wrt_nexp_of_lc_nexp : lngen.

(* begin hide *)

Lemma lc_nexp_of_degree_size_mutual :
forall i1,
(forall e1,
  size_nexp e1 = i1 ->
  degree_nexp_wrt_nexp 0 e1 ->
  lc_nexp e1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind nexp_mutind;
default_simp;
(* non-trivial cases *)
constructor; default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_nexp_of_degree :
forall e1,
  degree_nexp_wrt_nexp 0 e1 ->
  lc_nexp e1.
Proof.
intros e1; intros;
pose proof (lc_nexp_of_degree_size_mutual (size_nexp e1));
intuition eauto.
Qed.

Hint Resolve lc_nexp_of_degree : lngen.

Ltac nexp_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              let J1 := fresh in pose proof H as J1; apply degree_nexp_wrt_nexp_of_lc_nexp in J1; clear H
          end).

Lemma lc_ne_abs_exists :
forall x1 e1,
  lc_nexp (open_nexp_wrt_nexp e1 (ne_var_f x1)) ->
  lc_nexp (ne_abs e1).
Proof.
intros; nexp_lc_exists_tac; eauto with lngen.
Qed.

Hint Extern 1 (lc_nexp (ne_abs _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_ne_abs_exists x1) : core.

Lemma lc_body_nexp_wrt_nexp :
forall e1 e2,
  body_nexp_wrt_nexp e1 ->
  lc_nexp e2 ->
  lc_nexp (open_nexp_wrt_nexp e1 e2).
Proof.
unfold body_nexp_wrt_nexp;
default_simp;
let x1 := fresh "x" in
pick_fresh x1;
specialize_all x1;
nexp_lc_exists_tac;
eauto with lngen.
Qed.

Hint Resolve lc_body_nexp_wrt_nexp : lngen.

Lemma lc_body_ne_abs_1 :
forall e1,
  lc_nexp (ne_abs e1) ->
  body_nexp_wrt_nexp e1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_ne_abs_1 : lngen.

(* begin hide *)

Lemma lc_nexp_unique_mutual :
(forall e1 (proof2 proof3 : lc_nexp e1), proof2 = proof3).
Proof.
apply_mutual_ind lc_nexp_mutind;
intros;
let proof1 := fresh "proof1" in
rename_last_into proof1; dependent destruction proof1;
f_equal; default_simp; auto using @functional_extensionality_dep with lngen.
Qed.

(* end hide *)

Lemma lc_nexp_unique :
forall e1 (proof2 proof3 : lc_nexp e1), proof2 = proof3.
Proof.
pose proof lc_nexp_unique_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_nexp_unique : lngen.

(* begin hide *)

Lemma lc_nexp_of_lc_set_nexp_mutual :
(forall e1, lc_set_nexp e1 -> lc_nexp e1).
Proof.
apply_mutual_ind lc_set_nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma lc_nexp_of_lc_set_nexp :
forall e1, lc_set_nexp e1 -> lc_nexp e1.
Proof.
pose proof lc_nexp_of_lc_set_nexp_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_nexp_of_lc_set_nexp : lngen.

(* begin hide *)

Lemma lc_set_nexp_of_lc_nexp_size_mutual :
forall i1,
(forall e1,
  size_nexp e1 = i1 ->
  lc_nexp e1 ->
  lc_set_nexp e1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind nexp_mutrec;
default_simp;
try solve [assert False by default_simp; tauto];
(* non-trivial cases *)
constructor; default_simp;
try first [apply lc_set_nexp_of_lc_nexp];
default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_set_nexp_of_lc_nexp :
forall e1,
  lc_nexp e1 ->
  lc_set_nexp e1.
Proof.
intros e1; intros;
pose proof (lc_set_nexp_of_lc_nexp_size_mutual (size_nexp e1));
intuition eauto.
Qed.

Hint Resolve lc_set_nexp_of_lc_nexp : lngen.

(* *********************************************************************** *)
(** * More theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp_mutual :
(forall e1 x1 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  x1 `notin` fv_nexp e1 ->
  close_nexp_wrt_nexp_rec n1 x1 e1 = e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp :
forall e1 x1 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  x1 `notin` fv_nexp e1 ->
  close_nexp_wrt_nexp_rec n1 x1 e1 = e1.
Proof.
pose proof close_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp_mutual as H; intuition eauto.
Qed.

Hint Resolve close_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp : lngen.
Hint Rewrite close_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp using solve [auto] : lngen.

(* end hide *)

Lemma close_nexp_wrt_nexp_lc_nexp :
forall e1 x1,
  lc_nexp e1 ->
  x1 `notin` fv_nexp e1 ->
  close_nexp_wrt_nexp x1 e1 = e1.
Proof.
unfold close_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve close_nexp_wrt_nexp_lc_nexp : lngen.
Hint Rewrite close_nexp_wrt_nexp_lc_nexp using solve [auto] : lngen.

(* begin hide *)

Lemma open_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp_mutual :
(forall e2 e1 n1,
  degree_nexp_wrt_nexp n1 e2 ->
  open_nexp_wrt_nexp_rec n1 e1 e2 = e2).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp :
forall e2 e1 n1,
  degree_nexp_wrt_nexp n1 e2 ->
  open_nexp_wrt_nexp_rec n1 e1 e2 = e2.
Proof.
pose proof open_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp_mutual as H; intuition eauto.
Qed.

Hint Resolve open_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp : lngen.
Hint Rewrite open_nexp_wrt_nexp_rec_degree_nexp_wrt_nexp using solve [auto] : lngen.

(* end hide *)

Lemma open_nexp_wrt_nexp_lc_nexp :
forall e2 e1,
  lc_nexp e2 ->
  open_nexp_wrt_nexp e2 e1 = e2.
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve open_nexp_wrt_nexp_lc_nexp : lngen.
Hint Rewrite open_nexp_wrt_nexp_lc_nexp using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [fv] *)

Ltac default_auto ::= auto with set lngen; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma fv_nexp_close_nexp_wrt_nexp_rec_mutual :
(forall e1 x1 n1,
  fv_nexp (close_nexp_wrt_nexp_rec n1 x1 e1) [=] remove x1 (fv_nexp e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_nexp_close_nexp_wrt_nexp_rec :
forall e1 x1 n1,
  fv_nexp (close_nexp_wrt_nexp_rec n1 x1 e1) [=] remove x1 (fv_nexp e1).
Proof.
pose proof fv_nexp_close_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_close_nexp_wrt_nexp_rec : lngen.
Hint Rewrite fv_nexp_close_nexp_wrt_nexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma fv_nexp_close_nexp_wrt_nexp :
forall e1 x1,
  fv_nexp (close_nexp_wrt_nexp x1 e1) [=] remove x1 (fv_nexp e1).
Proof.
unfold close_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve fv_nexp_close_nexp_wrt_nexp : lngen.
Hint Rewrite fv_nexp_close_nexp_wrt_nexp using solve [auto] : lngen.

(* begin hide *)

Lemma fv_nexp_open_nexp_wrt_nexp_rec_lower_mutual :
(forall e1 e2 n1,
  fv_nexp e1 [<=] fv_nexp (open_nexp_wrt_nexp_rec n1 e2 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_nexp_open_nexp_wrt_nexp_rec_lower :
forall e1 e2 n1,
  fv_nexp e1 [<=] fv_nexp (open_nexp_wrt_nexp_rec n1 e2 e1).
Proof.
pose proof fv_nexp_open_nexp_wrt_nexp_rec_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_open_nexp_wrt_nexp_rec_lower : lngen.

(* end hide *)

Lemma fv_nexp_open_nexp_wrt_nexp_lower :
forall e1 e2,
  fv_nexp e1 [<=] fv_nexp (open_nexp_wrt_nexp e1 e2).
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve fv_nexp_open_nexp_wrt_nexp_lower : lngen.

(* begin hide *)

Lemma fv_nexp_open_nexp_wrt_nexp_rec_upper_mutual :
(forall e1 e2 n1,
  fv_nexp (open_nexp_wrt_nexp_rec n1 e2 e1) [<=] fv_nexp e2 `union` fv_nexp e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_nexp_open_nexp_wrt_nexp_rec_upper :
forall e1 e2 n1,
  fv_nexp (open_nexp_wrt_nexp_rec n1 e2 e1) [<=] fv_nexp e2 `union` fv_nexp e1.
Proof.
pose proof fv_nexp_open_nexp_wrt_nexp_rec_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_open_nexp_wrt_nexp_rec_upper : lngen.

(* end hide *)

Lemma fv_nexp_open_nexp_wrt_nexp_upper :
forall e1 e2,
  fv_nexp (open_nexp_wrt_nexp e1 e2) [<=] fv_nexp e2 `union` fv_nexp e1.
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve fv_nexp_open_nexp_wrt_nexp_upper : lngen.

(* begin hide *)

Lemma fv_nexp_subst_nexp_fresh_mutual :
(forall e1 e2 x1,
  x1 `notin` fv_nexp e1 ->
  fv_nexp (subst_nexp e2 x1 e1) [=] fv_nexp e1).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_nexp_subst_nexp_fresh :
forall e1 e2 x1,
  x1 `notin` fv_nexp e1 ->
  fv_nexp (subst_nexp e2 x1 e1) [=] fv_nexp e1.
Proof.
pose proof fv_nexp_subst_nexp_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_subst_nexp_fresh : lngen.
Hint Rewrite fv_nexp_subst_nexp_fresh using solve [auto] : lngen.

(* begin hide *)

Lemma fv_nexp_subst_nexp_lower_mutual :
(forall e1 e2 x1,
  remove x1 (fv_nexp e1) [<=] fv_nexp (subst_nexp e2 x1 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_nexp_subst_nexp_lower :
forall e1 e2 x1,
  remove x1 (fv_nexp e1) [<=] fv_nexp (subst_nexp e2 x1 e1).
Proof.
pose proof fv_nexp_subst_nexp_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_subst_nexp_lower : lngen.

(* begin hide *)

Lemma fv_nexp_subst_nexp_notin_mutual :
(forall e1 e2 x1 x2,
  x2 `notin` fv_nexp e1 ->
  x2 `notin` fv_nexp e2 ->
  x2 `notin` fv_nexp (subst_nexp e2 x1 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_nexp_subst_nexp_notin :
forall e1 e2 x1 x2,
  x2 `notin` fv_nexp e1 ->
  x2 `notin` fv_nexp e2 ->
  x2 `notin` fv_nexp (subst_nexp e2 x1 e1).
Proof.
pose proof fv_nexp_subst_nexp_notin_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_subst_nexp_notin : lngen.

(* begin hide *)

Lemma fv_nexp_subst_nexp_upper_mutual :
(forall e1 e2 x1,
  fv_nexp (subst_nexp e2 x1 e1) [<=] fv_nexp e2 `union` remove x1 (fv_nexp e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_nexp_subst_nexp_upper :
forall e1 e2 x1,
  fv_nexp (subst_nexp e2 x1 e1) [<=] fv_nexp e2 `union` remove x1 (fv_nexp e1).
Proof.
pose proof fv_nexp_subst_nexp_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_nexp_subst_nexp_upper : lngen.

(* *********************************************************************** *)
(** * Theorems about [subst] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma subst_nexp_close_nexp_wrt_nexp_rec_mutual :
(forall e2 e1 x1 x2 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  x1 <> x2 ->
  x2 `notin` fv_nexp e1 ->
  subst_nexp e1 x1 (close_nexp_wrt_nexp_rec n1 x2 e2) = close_nexp_wrt_nexp_rec n1 x2 (subst_nexp e1 x1 e2)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_close_nexp_wrt_nexp_rec :
forall e2 e1 x1 x2 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  x1 <> x2 ->
  x2 `notin` fv_nexp e1 ->
  subst_nexp e1 x1 (close_nexp_wrt_nexp_rec n1 x2 e2) = close_nexp_wrt_nexp_rec n1 x2 (subst_nexp e1 x1 e2).
Proof.
pose proof subst_nexp_close_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_close_nexp_wrt_nexp_rec : lngen.

Lemma subst_nexp_close_nexp_wrt_nexp :
forall e2 e1 x1 x2,
  lc_nexp e1 ->  x1 <> x2 ->
  x2 `notin` fv_nexp e1 ->
  subst_nexp e1 x1 (close_nexp_wrt_nexp x2 e2) = close_nexp_wrt_nexp x2 (subst_nexp e1 x1 e2).
Proof.
unfold close_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve subst_nexp_close_nexp_wrt_nexp : lngen.

(* begin hide *)

Lemma subst_nexp_degree_nexp_wrt_nexp_mutual :
(forall e1 e2 x1 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  degree_nexp_wrt_nexp n1 e2 ->
  degree_nexp_wrt_nexp n1 (subst_nexp e2 x1 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_degree_nexp_wrt_nexp :
forall e1 e2 x1 n1,
  degree_nexp_wrt_nexp n1 e1 ->
  degree_nexp_wrt_nexp n1 e2 ->
  degree_nexp_wrt_nexp n1 (subst_nexp e2 x1 e1).
Proof.
pose proof subst_nexp_degree_nexp_wrt_nexp_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_degree_nexp_wrt_nexp : lngen.

(* begin hide *)

Lemma subst_nexp_fresh_eq_mutual :
(forall e2 e1 x1,
  x1 `notin` fv_nexp e2 ->
  subst_nexp e1 x1 e2 = e2).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_fresh_eq :
forall e2 e1 x1,
  x1 `notin` fv_nexp e2 ->
  subst_nexp e1 x1 e2 = e2.
Proof.
pose proof subst_nexp_fresh_eq_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_fresh_eq : lngen.
Hint Rewrite subst_nexp_fresh_eq using solve [auto] : lngen.

(* begin hide *)

Lemma subst_nexp_fresh_same_mutual :
(forall e2 e1 x1,
  x1 `notin` fv_nexp e1 ->
  x1 `notin` fv_nexp (subst_nexp e1 x1 e2)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_fresh_same :
forall e2 e1 x1,
  x1 `notin` fv_nexp e1 ->
  x1 `notin` fv_nexp (subst_nexp e1 x1 e2).
Proof.
pose proof subst_nexp_fresh_same_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_fresh_same : lngen.

(* begin hide *)

Lemma subst_nexp_fresh_mutual :
(forall e2 e1 x1 x2,
  x1 `notin` fv_nexp e2 ->
  x1 `notin` fv_nexp e1 ->
  x1 `notin` fv_nexp (subst_nexp e1 x2 e2)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_fresh :
forall e2 e1 x1 x2,
  x1 `notin` fv_nexp e2 ->
  x1 `notin` fv_nexp e1 ->
  x1 `notin` fv_nexp (subst_nexp e1 x2 e2).
Proof.
pose proof subst_nexp_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_fresh : lngen.

Lemma subst_nexp_lc_nexp :
forall e1 e2 x1,
  lc_nexp e1 ->
  lc_nexp e2 ->
  lc_nexp (subst_nexp e2 x1 e1).
Proof.
default_simp.
Qed.

Hint Resolve subst_nexp_lc_nexp : lngen.

(* begin hide *)

Lemma subst_nexp_open_nexp_wrt_nexp_rec_mutual :
(forall e3 e1 e2 x1 n1,
  lc_nexp e1 ->
  subst_nexp e1 x1 (open_nexp_wrt_nexp_rec n1 e2 e3) = open_nexp_wrt_nexp_rec n1 (subst_nexp e1 x1 e2) (subst_nexp e1 x1 e3)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_nexp_open_nexp_wrt_nexp_rec :
forall e3 e1 e2 x1 n1,
  lc_nexp e1 ->
  subst_nexp e1 x1 (open_nexp_wrt_nexp_rec n1 e2 e3) = open_nexp_wrt_nexp_rec n1 (subst_nexp e1 x1 e2) (subst_nexp e1 x1 e3).
Proof.
pose proof subst_nexp_open_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_open_nexp_wrt_nexp_rec : lngen.

(* end hide *)

Lemma subst_nexp_open_nexp_wrt_nexp :
forall e3 e1 e2 x1,
  lc_nexp e1 ->
  subst_nexp e1 x1 (open_nexp_wrt_nexp e3 e2) = open_nexp_wrt_nexp (subst_nexp e1 x1 e3) (subst_nexp e1 x1 e2).
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve subst_nexp_open_nexp_wrt_nexp : lngen.

Lemma subst_nexp_open_nexp_wrt_nexp_var :
forall e2 e1 x1 x2,
  x1 <> x2 ->
  lc_nexp e1 ->
  open_nexp_wrt_nexp (subst_nexp e1 x1 e2) (ne_var_f x2) = subst_nexp e1 x1 (open_nexp_wrt_nexp e2 (ne_var_f x2)).
Proof.
intros; rewrite subst_nexp_open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve subst_nexp_open_nexp_wrt_nexp_var : lngen.

(* begin hide *)

Lemma subst_nexp_spec_rec_mutual :
(forall e1 e2 x1 n1,
  subst_nexp e2 x1 e1 = open_nexp_wrt_nexp_rec n1 e2 (close_nexp_wrt_nexp_rec n1 x1 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_nexp_spec_rec :
forall e1 e2 x1 n1,
  subst_nexp e2 x1 e1 = open_nexp_wrt_nexp_rec n1 e2 (close_nexp_wrt_nexp_rec n1 x1 e1).
Proof.
pose proof subst_nexp_spec_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_spec_rec : lngen.

(* end hide *)

Lemma subst_nexp_spec :
forall e1 e2 x1,
  subst_nexp e2 x1 e1 = open_nexp_wrt_nexp (close_nexp_wrt_nexp x1 e1) e2.
Proof.
unfold close_nexp_wrt_nexp; unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve subst_nexp_spec : lngen.

(* begin hide *)

Lemma subst_nexp_subst_nexp_mutual :
(forall e1 e2 e3 x2 x1,
  x2 `notin` fv_nexp e2 ->
  x2 <> x1 ->
  subst_nexp e2 x1 (subst_nexp e3 x2 e1) = subst_nexp (subst_nexp e2 x1 e3) x2 (subst_nexp e2 x1 e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_subst_nexp :
forall e1 e2 e3 x2 x1,
  x2 `notin` fv_nexp e2 ->
  x2 <> x1 ->
  subst_nexp e2 x1 (subst_nexp e3 x2 e1) = subst_nexp (subst_nexp e2 x1 e3) x2 (subst_nexp e2 x1 e1).
Proof.
pose proof subst_nexp_subst_nexp_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_subst_nexp : lngen.

(* begin hide *)

Lemma subst_nexp_close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec_mutual :
(forall e2 e1 x1 x2 n1,
  x2 `notin` fv_nexp e2 ->
  x2 `notin` fv_nexp e1 ->
  x2 <> x1 ->
  degree_nexp_wrt_nexp n1 e1 ->
  subst_nexp e1 x1 e2 = close_nexp_wrt_nexp_rec n1 x2 (subst_nexp e1 x1 (open_nexp_wrt_nexp_rec n1 (ne_var_f x2) e2))).
Proof.
apply_mutual_ind nexp_mutrec;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_nexp_close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec :
forall e2 e1 x1 x2 n1,
  x2 `notin` fv_nexp e2 ->
  x2 `notin` fv_nexp e1 ->
  x2 <> x1 ->
  degree_nexp_wrt_nexp n1 e1 ->
  subst_nexp e1 x1 e2 = close_nexp_wrt_nexp_rec n1 x2 (subst_nexp e1 x1 (open_nexp_wrt_nexp_rec n1 (ne_var_f x2) e2)).
Proof.
pose proof subst_nexp_close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_close_nexp_wrt_nexp_rec_open_nexp_wrt_nexp_rec : lngen.

(* end hide *)

Lemma subst_nexp_close_nexp_wrt_nexp_open_nexp_wrt_nexp :
forall e2 e1 x1 x2,
  x2 `notin` fv_nexp e2 ->
  x2 `notin` fv_nexp e1 ->
  x2 <> x1 ->
  lc_nexp e1 ->
  subst_nexp e1 x1 e2 = close_nexp_wrt_nexp x2 (subst_nexp e1 x1 (open_nexp_wrt_nexp e2 (ne_var_f x2))).
Proof.
unfold close_nexp_wrt_nexp; unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve subst_nexp_close_nexp_wrt_nexp_open_nexp_wrt_nexp : lngen.

Lemma subst_nexp_ne_abs :
forall x2 e2 e1 x1,
  lc_nexp e1 ->
  x2 `notin` fv_nexp e1 `union` fv_nexp e2 `union` singleton x1 ->
  subst_nexp e1 x1 (ne_abs e2) = ne_abs (close_nexp_wrt_nexp x2 (subst_nexp e1 x1 (open_nexp_wrt_nexp e2 (ne_var_f x2)))).
Proof.
default_simp.
Qed.

Hint Resolve subst_nexp_ne_abs : lngen.

(* begin hide *)

Lemma subst_nexp_intro_rec_mutual :
(forall e1 x1 e2 n1,
  x1 `notin` fv_nexp e1 ->
  open_nexp_wrt_nexp_rec n1 e2 e1 = subst_nexp e2 x1 (open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1)).
Proof.
apply_mutual_ind nexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_nexp_intro_rec :
forall e1 x1 e2 n1,
  x1 `notin` fv_nexp e1 ->
  open_nexp_wrt_nexp_rec n1 e2 e1 = subst_nexp e2 x1 (open_nexp_wrt_nexp_rec n1 (ne_var_f x1) e1).
Proof.
pose proof subst_nexp_intro_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_nexp_intro_rec : lngen.
Hint Rewrite subst_nexp_intro_rec using solve [auto] : lngen.

Lemma subst_nexp_intro :
forall x1 e1 e2,
  x1 `notin` fv_nexp e1 ->
  open_nexp_wrt_nexp e1 e2 = subst_nexp e2 x1 (open_nexp_wrt_nexp e1 (ne_var_f x1)).
Proof.
unfold open_nexp_wrt_nexp; default_simp.
Qed.

Hint Resolve subst_nexp_intro : lngen.

(* *********************************************************************** *)
(** * "Restore" tactics *)

Ltac default_auto ::= auto; tauto.
Ltac default_autorewrite ::= fail.


(** * Completeness of [LJT] w.r.t. Kripke Semantics *)

Set Implicit Arguments.

Require Import associations.
Require Import associations_extra.
Require Import sublist.
Require Import language_syntax.
Require Import variable_sets.
Require Import substitution_wellformedness.
Require Import fresh_name.
Require Import renaming.
Require Import soundness.

(** The completeness of [LJT] w.r.t. Kripke semantics follows
   from the Universal Completeness.

   The universal Kripke model consists of contexts as worlds,
   the sub-context relation, and the provability for atomic
   sentences, and term as the constant domain. *)

(** ** The Universal Model *)

(* projections related with well-formedness  *)

Notation wf_trm := (@sig trm wf_t).

Definition wf_Cst (n:name) : wf_trm :=
  exist wf_t (Cst n)(wCst n).

Definition wf_Par (n:name) : wf_trm :=
  exist wf_t (Par n)(wPar n).

Definition wf_App (f:function)(t u: wf_trm) : wf_trm :=
  exist wf_t
        (App f (proj1_sig t) (proj1_sig u))
        (wApp f (proj2_sig t) (proj2_sig u)).

Definition wf_atoms Ga (P : predicate * wf_trm) :=
  (Ga |- Atom (fst P, proj1_sig (snd P))).

(** Monotonicity of forcing relation *)

Lemma weakening_gen' : forall Ga De A eta,
    sub_ctx Ga De ->
    Ga |- A ->
    rename_c eta De |- rename eta A

with weakening_stoup_gen' : forall Ga De A C eta,
    sub_ctx Ga De ->
    Ga ;; A |- C ->
    rename_c eta De ;; rename eta A |- rename eta C.
Proof.
 - intros; apply weakening_gen with Ga; auto.
   + apply indeed_sub_ctx_is; assumption.
   + destruct H as [Heq | Hsub Hwf];
     [ rewrite <- Heq; apply (@wf_prove Ga A H0); auto
     | apply Hsub].

 - intros; apply weakening_stoup_gen with Ga; auto.
   + apply indeed_sub_ctx_is; assumption.
   + destruct H as [Heq | Hsub Hwf];
     [ rewrite <- Heq; apply (@wf_prove_stoup Ga A C H0); auto
     | apply Hsub].
Defined.

Lemma weakening_atom : forall (Ga Ga': context),
    sub_ctx Ga Ga' ->
    forall (P : predicate * wf_trm),
    wf_atoms Ga P ->
    wf_atoms Ga' P.
Proof.
  intros; apply weakening with Ga;
  [ apply indeed_sub_ctx_is
  | destruct H as [Heq | Hsub ?];
    [ rewrite <- Heq; unfold wf_atoms in H0;
      apply (@wf_prove Ga (Atom (fst P, proj1_sig (snd P))))
     |apply Hsub]
    | ]; auto.
Defined.

(** Reflexivity of sub-context relation. *)

Lemma sub_ctx_refl : forall Ga, sub_ctx Ga Ga.
Proof.
  unfold sub_ctx; intuition.
Qed.

(** Transitivity of sub-context relation. *)

Lemma sub_ctx_trans : forall Ga Ga0 Ga1,
  sub_ctx Ga Ga0 -> sub_ctx Ga0 Ga1 -> sub_ctx Ga Ga1.
Proof.
  unfold sub_ctx; intros Ga Ga0 Ga1 H H0.
  destruct H as [Heq | Hneq]; destruct H0 as [H0eq | H0neq];
  subst; intuition.
Qed.

(** Universal model's domain is the set of well-formed terms. *)

Canonical Structure Universal := @Build_Kripke
  context
  sub_ctx
  sub_ctx_refl
  sub_ctx_trans
  wf_trm
  (wf_Cst)
  (wf_App)
  (fun Ga Pt => Ga |- Atom (fst Pt, proj1_sig (snd Pt)))
  weakening_atom.

(** In the universal model, substitution plays the role of
   semantic interpretation. *)

Lemma sub_ctx_wf_c : forall Ga Ga0,
    sub_ctx Ga Ga0 -> wf_c Ga -> wf_c Ga0.
Proof.
  intros; unfold sub_ctx in H.
  destruct H as [Heq | Hneq]; subst; intuition.
Defined.

Notation ">>" := (proj1_sig).
Notation "<<" := (exist wf_t).

Fixpoint fn_pro (eta : assoc wf_trm) :=
  match eta with
    nil => nil
  | (n, t) :: eta' => (n, >> t) :: (fn_pro eta')
  end.

Notation ">>>" := (fn_pro).

(* fun_assoc is preserved under fn_pro *)

Lemma fn_pro_eq_val : forall eta n t u,
eta ^^ n = Some t ->
(>>> eta) ^^ n = Some u ->
>> t = u.
Proof.
  unfold fn_pro; induction eta, t; auto; simpl; intros; auto.
  - inversion H; auto.
  - destruct a as [m t]; simpl in H0.
    case_var.
    + inversion H0; inversion H; simpl; auto.
    + set (x0 := (<< x w)); assert (x= >> x0) as H1; auto;
      rewrite H1; apply IHeta with n; auto.
Defined.

Lemma fn_pro_dom_eq : forall eta,
  dom eta = dom (>>> eta).
Proof.
  induction eta as [ | nw eta0]; auto;
  destruct nw as [n w]; simpl; rewrite IHeta0; auto.
Defined.

Lemma wf_t_sub_ol : forall t rho eta,
    sub_name (ol_t t) (dom eta) ->
    wf_t (t [[>>> rho, >>> eta]]).
Proof.
  induction t; auto; simpl; intros.
  - apply IN_sublist in H. generalize H; intro H1.
    rewrite fn_pro_dom_eq in H.
    apply IN_dom_sig in H; apply IN_dom_sig in H1.
    destruct H as [ u H ]; destruct H1 as [ wt H1]; destruct wt as [t H2].
    rewrite H; auto.
    rewrite <- fn_pro_eq_val with (eta := eta) (n:=n) (t:=(<< t H2)); auto.
  - destruct (decIN eqdec n (dom (>>> rho))) as [H1 | H1].
    + generalize H1; intro H2;
       rewrite <- fn_pro_dom_eq in H2.
      apply IN_dom_sig in H1; apply IN_dom_sig in H2.
      destruct H1 as [ u H1 ]; destruct H2 as [ wt H2]; destruct wt as [t H3].
      rewrite H1; auto;
      rewrite <- fn_pro_eq_val with (eta := rho) (n:=n) (t:=(<< t H3)); auto.
    + generalize (notIN_dom_None n (>>> rho) H1);
      intro H2; rewrite H2; apply wPar.
  - apply wCst.
  - apply wApp; [apply IHt1 | apply IHt2]; auto with datatypes.
Defined.

Lemma fn_pro_nil :
  >>> nil = nil.
Proof.
  auto.
Defined.

Lemma fn_pro_rm_comm : forall eta n,
  ((>>> eta) ^- n) = (>>> (eta ^- n)).
Proof.
  induction eta as [| a eta]; auto; simpl; intros;
  destruct a as (m, wft); destruct wft as (t, wf); auto.
  simpl; case_var; rewrite IHeta; auto.
Defined.

Lemma psem_tsubst : forall (t:trm) (rho eta:assoc wf_trm),
  sub_name (ol_t t) (dom eta) -> sub_name (op_t t) (dom rho) ->
  >> (psem Universal t rho eta) = (t [[>>> rho , >>> eta]]).
Proof.
  induction t; try tauto; intros.
  - simpl in *. apply IN_sublist in H.
    generalize H; intro H1; rewrite fn_pro_dom_eq in H1.

    destruct (IN_dom_sig n  eta H) as [wft H2];
    destruct (IN_dom_sig n (>>> eta) H1) as [wfu H3].
    rewrite H2, H3; auto. apply fn_pro_eq_val with (eta:=eta) (n:=n); auto.
  - simpl in *. apply IN_sublist in H0.
    generalize H0; intro H1; rewrite fn_pro_dom_eq in H1.
    destruct (IN_dom_sig n rho H0) as [wft H2];
    destruct (IN_dom_sig n (>>> rho) H1) as [wfu H3].
    rewrite H2, H3; auto. apply fn_pro_eq_val with (eta:=rho) (n:=n); auto.
  - simpl in *; f_equal; auto; [apply IHt1| apply IHt2]; auto with datatypes.
Defined.

Lemma open_eq_subst_t : forall t n u,
    wf_t t ->
    (t [[nil, (n, u) :: nil]]) = t.
Proof.
  induction t; simpl; intros; auto; try inversion H; try f_equal; auto.
Defined.

Lemma open_eq_subst_t_rm : forall t eta a n,
    ((t [[nil, >>>eta ^- n]]) [[nil, (n, Par a) :: nil]]) = (t [[nil, (n, Par a) ::(>>> eta)]]).
Proof.
  induction t; simpl; intros; auto.
  - case_var.
    + rewrite assoc_rm_self; simpl; case_var; try tauto; auto.
    + rewrite <- assoc_rm_neq; auto.
      induction eta; simpl.
      * case_var; tauto.
      * destruct a0 as [n2 t]; destruct t; simpl; case_var; auto.
        rewrite open_eq_subst_t; auto.
  - f_equal; auto.
Defined.

Hint Resolve open_eq_subst_t.
Hint Rewrite open_eq_subst_t.

Lemma fn_pro_cons : forall n a eta,
    (>>>((n, wf_Par a) :: eta)) = ((n, Par a) :: >>> eta).
Proof.
  auto.
Defined.

Lemma fn_pro_IN_dom : forall eta n u,
    >>> eta ^^ n = Some u ->
    wf_t u.
Proof.
  induction eta; simpl; intros; try discriminate.
  destruct a; destruct s; simpl in *.
  case_var.
  - inversion H.
    rewrite <- H1; auto.
  - eapply IHeta; eauto.
Defined.

(*------------ subst rel w/ wft associations ------------------*)

Lemma fn_pro_wf_t_sig :
  forall u,
    wf_t u ->
    (exists c, (u = Cst c) \/ (u = Par c))
    \/ (exists f u1 u2, ((u = App f u1 u2) /\ (wf_t u1) /\ (wf_t u2))).
Proof.
  induction 1; auto; intros; [ left | left | right]; try exists x; auto.
  destruct IHwf_t1, IHwf_t2; eauto; do 2 destruct H1, H2;
  try do 2 destruct H1, H2; try destruct H3; try exists f, t1, t2; subst; auto.
Defined.

Lemma open_wf_trm_subst_t :
  forall u (eta: assoc wf_trm) n t,
    open_t (u [[nil , >>> eta ^- n]]) n t
    = (u [[ nil , (n, t) :: >>> eta]]).
Proof.
  unfold open_t; induction u as [ m | m | m | ]; simpl; intros; auto.
  - case_var.
    + rewrite assoc_rm_self; simpl; case_var; intuition.
    + rewrite <- assoc_rm_neq; auto.
      pose proof (fn_pro_IN_dom eta m) as H;
      pose proof fn_pro_wf_t_sig as H0.
      destruct (>>> eta ^^ m).
      * specialize H with t0; specialize H0 with t0; destruct H0;
         try apply H; auto.
      * simpl; case_var; auto; try contradict H; intuition.
  -  f_equal; auto.
Defined.

Lemma open_wf_trm_subst :
  forall A eta n t,
    open (A [nil,  >>> eta ^- n]) n t = ( A [nil , (n, t) :: >>> eta]).
Proof.
  unfold open; induction A as [ [P u]| | m ]; simpl; intros.
  - do 2 f_equal.
    apply open_wf_trm_subst_t; auto.
  - f_equal; auto.
  - f_equal; case_var.
    * rewrite <- nil_subst; rewrite <- rm_rm; auto.
    * rewrite rm_neq_rm; auto; rewrite fn_pro_rm_comm; auto.
Defined.

Lemma ol_t_ind_rho :
  forall t (rho eta : assoc wf_trm),
    ol_t (t [[ >>> rho, >>> eta]]) = ol_t (t [[>>> nil, >>> eta]]).
Proof.
  induction t, rho; auto; intros.
  - destruct p as [m w]; destruct w as [t wt]; simpl.
    case_var; auto; pose proof (fn_pro_IN_dom rho n);
    case_assoc; auto.
  - destruct p as [n w].
    case w; intros; unfold subst; simpl;
    rewrite IHt1 with (rho := ((n, << x w0) :: rho));
    rewrite IHt2 with (rho := ((n, << x w0) :: rho)).
    rewrite fn_pro_nil; auto.
Defined.

Lemma ol_ind_rho :
  forall A (rho eta : assoc wf_trm),
    ol (A [ >>> rho, >>> eta]) = ol (A [>>> nil, >>> eta]).
Proof.
  induction A as [ [p  t] | | ]; induction rho as [ | [ m w ] rho ]; auto; intros
  ; simpl;
    replace ((m, >> w) :: >>> rho) with (>>> ((m , w ) :: rho)); auto.
  - rewrite ol_t_ind_rho; auto using fn_pro_nil.
  - rewrite IHA1, IHA2; auto using fn_pro_nil.
  - rewrite fn_pro_rm_comm;
    rewrite IHA with (eta:= eta ^-n); auto using fn_pro_nil.
Defined.

Lemma open_eq_subst_wf_t : forall t u eta rho n,
    wf_t u ->
    ((t [[>>>rho, >>>eta ^- n]]) [[>>> nil, (n, u) :: nil]])
    = (t [[>>>rho, (n, u) ::(>>> eta)]]).
Proof.
  induction t; auto; intros.
  - rewrite <- fn_pro_nil; simpl; case_var.
    + rewrite assoc_rm_self; simpl; case_var; intuition.
    + rewrite <- assoc_rm_neq; auto.

       destruct (decIN eqdec n (dom (>>> eta))) as [H1 | H1].
      * generalize H1; intro H2. rewrite <- fn_pro_dom_eq in H2.
        apply IN_dom_sig in H1; destruct H1 as [t St];
        apply IN_dom_sig in H2; destruct H2 as [tt Stt];
        rewrite St.
        assert (H0 := fn_pro_eq_val eta n Stt St).
        destruct tt as [tt wt]; simpl in H0; subst.
        case wt; intros; auto; simpl.
        rewrite! open_eq_subst_t; auto.
      * pose proof (notIN_dom_None n (>>> eta) H1) as H0;
        rewrite H0; simpl. case_var; intuition.
  - rewrite! open_eq_subst_t; auto.
    apply empty_ol_wf_t; rewrite fn_pro_rm_comm, ol_t_ind_rho; auto.
  -  simpl; rewrite IHt1, IHt2; auto.
Defined.

Lemma open_eq_subst : forall A eta rho t n,
    wf_t t ->
    ((A [>>>rho, >>>eta ^- n]) [>>> nil, (n, t) :: nil])
    = (A [>>>rho, (n, t) ::(>>> eta)]).
Proof.
  induction A as [ [p t] | |]; auto; intros; simpl.
  - do 2 f_equal; apply open_eq_subst_wf_t; auto.
  - rewrite IHA1, IHA2; auto.
  - f_equal. case_var; auto.
    + rewrite <- rm_rm, nil_subst; auto.
    + rewrite <- rm_neq_rm; auto; rewrite fn_pro_rm_comm;
      rewrite IHA with (eta := eta ^- n); auto.
Defined.

Lemma wf_trm_subst_wf_t :
  forall t (rho eta : assoc wf_trm),
    sub_name (ol_t t) (dom eta)
    -> ol_t (t[[ >>> rho, >>> eta]])= nil.
Proof.
  induction t; intros.
  - simpl in H; pose proof (fn_pro_IN_dom eta n); apply IN_sublist in H;
    rewrite fn_pro_dom_eq in H.
    pose proof (IN_dom_sig n (>>> eta) H).
    simpl; destruct H1 as [t St]; rewrite St.
    apply wf_t_ol_empty; apply H0; auto.
  - rewrite ol_t_ind_rho, fn_pro_nil; auto.
  - rewrite ol_t_ind_rho, fn_pro_nil; auto.
  - simpl; rewrite IHt1, IHt2; simpl in H; auto with datatypes.
Defined.

Lemma ol_wf_trm_subst : forall A (eta : assoc wf_trm),
    sub_name (ol A) (dom eta) ->
    wf (A [nil, >>> eta]).
Proof.
  induction A as [ [p t] | |]; simpl; intros eta Hsub.
  - apply wAtom;  auto with datatypes.
    rewrite <- fn_pro_nil. apply empty_ol_wf_t, wf_trm_subst_wf_t; auto.
  - apply wImply; auto with datatypes.
  - set (a := new (op (A [nil,>>> eta ^- n]))).
    apply wForall with (c := a);
      [ apply new_fresh
      | rewrite (open_wf_trm_subst); rewrite <- fn_pro_cons; apply IHA;
        simpl; auto with datatypes].
Defined.

Lemma wf_trm_subst_wf:
  forall A (rho eta : assoc wf_trm),
     sub_name (ol A) (dom eta)
    -> ol ( A [ >>> rho, >>> eta])= nil.
Proof.
  intros; rewrite ol_ind_rho; apply wf_ol_empty, ol_wf_trm_subst; auto.
Defined.

  (** ** Universal Completeness *)

Theorem univ_cpltness : forall (A:fml) (Ga:context) (rho eta:assoc wf_trm),
    sub_name (ol A) (dom eta) ->
    sub_name (op A) (dom rho)->
    wf_c Ga ->
    Ga ||- A {[rho, eta]} ->
    Ga |- (A [>>> rho, >>> eta])

    with univ_cpltness_stoup : forall (A:fml) (Ga:context) (rho eta:assoc wf_trm),
    sub_name (ol A) (dom eta) ->
    sub_name (op A) (dom rho) ->
    wf_c Ga ->
    (forall C Ga', sub_ctx Ga Ga' ->
                   (Ga' ;; (A [>>> rho, >>> eta]) |- C )-> (Ga' |- C )) ->
    Ga ||- A {[rho, eta]}.
Proof.
  - {destruct A as [ [p t] | | ]; simpl; intros.
     - rewrite <- psem_tsubst; assumption.
     - generalize (sub_appL _ _ H); intro.
       generalize (sub_appR _ _ H); intro; clear H.
       apply ProofImplyR.
       apply univ_cpltness; auto with datatypes.

       + apply wCons; auto.
         apply empty_ol_wf, wf_trm_subst_wf; auto with datatypes.
       + apply X; auto.
         * unfold sub_ctx; right. split;
                                  [ idtac
                                  | apply wCons; auto;
                                    apply empty_ol_wf, wf_trm_subst_wf];
           auto with datatypes.
         * apply univ_cpltness_stoup; auto with datatypes;
            [apply wCons; auto;
             apply empty_ol_wf, wf_trm_subst_wf; auto
            | intros; apply ProofCont with  (A1 [>>> rho, >>> eta]);
              unfold sub_ctx in H]; auto.
             destruct H; [rewrite <- H | apply H]; auto with datatypes.

     - set (a:= new (op_c ((Forall n (A [>>> rho, >>> eta ^- n])) :: Ga))).
              apply ProofForallR with a; intros.
              apply new_fresh.  unfold open; rewrite open_eq_subst.
       + rewrite <- fn_pro_cons;
         apply univ_cpltness; auto.
         * simpl; auto with datatypes.
         * apply X; apply sub_ctx_refl.
       + apply wPar.
          }
  - { destruct A as [ [p t] | |]; simpl; intros.
      - apply H2; auto using sub_ctx_refl.
        rewrite psem_tsubst; auto.
        apply ProofAxiom; auto; apply wAtom; apply wf_t_sub_ol; auto.
      - apply univ_cpltness_stoup; auto with datatypes.
        + apply sub_ctx_wf_c with Ga; auto.
        + intros; apply H2; auto.
          * apply wle_trans with w'; auto.
          * { apply ProofImplyL ; auto.
               apply univ_cpltness; auto with datatypes.
              - apply sub_ctx_wf_c with Ga; auto. apply sub_ctx_trans with w'; auto.
              - apply mono_force with w'; auto.
}
      - apply univ_cpltness_stoup; auto. apply sub_rm_2; auto.
       * apply sub_ctx_wf_c with Ga; auto.
       * intros; apply H2; auto.
        + apply wle_trans with w'; auto.
        + destruct d as [m wf]; apply ProofForallL with m; auto.
          unfold open; rewrite open_eq_subst; auto.
}
Defined.

Notation cl_a := (fun (A: fml) => sub_name (op A) nil).

Notation cl_c :=
  (fun (Ga:context) => forall A, IN_ctx A Ga -> sub_name (op A) nil).

Theorem univ_cpltness' :
  forall A (Ga: context),
    cl_a A ->
    wf A -> wf_c Ga ->
    Ga ||- A {[nil, nil]} ->
    Ga |- A.
Proof.
  intros; rewrite nil_subst.
  rewrite <- fn_pro_nil; apply univ_cpltness; auto;
  rewrite wf_ol_empty; auto with datatypes.
Defined.

Theorem univ_cpltness_stoup' : forall A (Ga: context),
    cl_a A ->
    wf A -> wf_c Ga ->
    (forall C Ga', sub_ctx Ga Ga' -> Ga' ;; A |- C -> Ga' |- C) ->
    Ga ||- A {[nil, nil]}.
Proof.
  intros.
  apply univ_cpltness_stoup; auto;
  [ rewrite wf_ol_empty; auto with datatypes
  | intros; apply H2; auto; rewrite nil_subst with A; rewrite <- fn_pro_nil; auto].
Defined.

Lemma univ_cpltness_axiom : forall A (Ga : context),
    cl_a A -> wf A -> wf_c Ga ->
    IN_ctx A Ga ->
    Ga ||- A {[nil, nil]}.
Proof.
  induction Ga as [ | B Ga]; try contradiction; simpl; intros.
  apply univ_cpltness_stoup; auto.
  - rewrite wf_ol_empty; auto.
  - intros. apply ProofCont with (A [>>> nil, >>> nil]) ; auto.
    rewrite fn_pro_nil; rewrite <- nil_subst. destruct H3; subst; intuition.
Defined.

Lemma universal_force_context : forall (Ga: worlds Universal) De,
    cl_c De -> wf_c De ->
    sub_ctx De Ga ->
    list_forall (fun B => Ga ||- B {[nil, nil]}) De.
Proof.
  induction De as [|A]; intros; constructor.
  - apply univ_cpltness_axiom; auto using IN_eq; auto.
    + inversion H0; subst; auto.
    + unfold sub_ctx in H1; intuition; subst; auto.
    + unfold sub_ctx in H1; destruct H1; subst.
      * apply IN_eq.
      * apply H1; auto with datatypes.
  - apply IHDe; auto with datatypes.
    * inversion H0; auto.
    * unfold sub_ctx; destruct H1; subst; auto with datatypes.
      right; destruct H1; eauto using sub_cons_1.
Defined.

Theorem completeness : forall (Ga: context) A,
    cl_a A ->
    cl_c Ga ->
    wf A -> wf_c Ga ->
    (forall K (w: worlds K),
        (list_forall (fun B => w ||- B {[nil, nil]}) Ga) -> w ||- A {[nil, nil]}) ->
    Ga |- A.
Proof.
  intros; apply univ_cpltness'; auto.
  apply X. apply (universal_force_context H0 H2 (sub_ctx_refl Ga)).
Defined.

(** ** Cut-admissibility *)

Lemma cut_ad :
  forall Ga A B,
    cl_c Ga -> cl_a B->
    Ga ;; A |- B -> Ga |- A -> Ga |- B.
Proof.
  intros.
  apply completeness; auto.
  - destruct (wf_prove_stoup H1) as [H3 H4]; destruct H4; auto.
  - apply (wf_prove H2).
  - intros. apply soundness_stoup with (Ga:=Ga) (A:=A) (C:=B); auto.
    apply soundness with Ga; auto.
Defined.


From Typonomikon Require Import D5 BetterFinite.

Import ExactlyFinite.

Require Import Equality.

#[refine]
#[export]
Instance ExactlyFinite_bool : ExactlyFinite bool :=
{|
  elems := [false; true];
|}.
Proof.
  destruct x; repeat constructor.
  intros. dependent destruction e1; dependent destruction e2.
    reflexivity.
    exfalso. inv e2. inv H0.
    exfalso. inv e1. inv H0.
    f_equal. dependent destruction e1; dependent destruction e2.
      reflexivity.
      exfalso. inv e2.
      exfalso. inv e1.
      f_equal. inv e1.
Defined.

Lemma Elem_map :
  forall {A B : Type} (f : A -> B) (x : A) (l : list A),
    Elem x l -> Elem (f x) (map f l).
Proof.
  induction l as [| h t]; cbn; intros.
    dependent destruction X.
    dependent destruction X; constructor. apply IHt. assumption.
Defined.

Lemma Elem_map_inv :
  forall {A B : Type} (f : A -> B) (b : B) (l : list A),
    Elem b (map f l) -> {a : A | f a = b}.
Proof.
  induction l as [| h t]; cbn; intros.
    inv X.
    inv X.
      exists h. reflexivity.
      apply IHt. assumption.
Qed.

Lemma Elem_map_Some :
  forall {A : Type} (a : A) (l : list A),
    Elem (Some a) (map Some l) -> Elem a l.
Proof.
  induction l as [| h t]; cbn; intros.
    dependent destruction X.
    dependent destruction X; constructor. apply IHt. assumption.
Defined.

Lemma Elem_map__Elem_map_Some :
  forall {A : Type} (a : A) (l : list A) (H : Elem a l),
    Elem_map_Some a l (Elem_map Some a l H) = H.
Proof.
  dependent induction H.
Admitted.

Lemma Elem_map_Some__Elem_map :
  forall {A : Type} (a : A) (l : list A) (H : Elem (Some a) (map Some l)),
    Elem_map Some a l (Elem_map_Some a l H) = H.
Proof.
  induction l as [| h t]; cbn; intros.
    inv H.
    dependent destruction H.
Admitted.

#[refine]
#[export]
Instance Finite_option
  {A : Type} (FA : ExactlyFinite A) : ExactlyFinite (option A) :=
{|
  elems := None :: map Some (@elems _ FA);
|}.
Proof.
  all: destruct FA as [els H1 H2]; cbn.
    destruct x as [a |].
      constructor. apply Elem_map. apply H1.
      constructor.
    destruct x as [a |]; intros.
      2: {
        dependent destruction e1; dependent destruction e2.
          reflexivity.
          exfalso. apply Elem_map_inv in e2. destruct e2. congruence.
          exfalso. apply Elem_map_inv in e1. destruct e1. congruence.
          exfalso. apply Elem_map_inv in e2. destruct e2. congruence.
      }
      {
        dependent destruction e1; dependent destruction e2. f_equal.
        rewrite <- (Elem_map_Some__Elem_map _ _ e1), <- (Elem_map_Some__Elem_map _ _ e2).
        f_equal. apply H2.
      }
Defined.

Fixpoint sum (l : list nat) : nat :=
match l with
| [] => 0
| h :: t => h + sum t
end.

Lemma elem_sum :
  forall {n : nat} {l : list nat},
    Elem n l -> n <= sum l.
Proof.
  induction 1; cbn; lia.
Qed.

Lemma nat_not_Finite :
  ExactlyFinite nat -> False.
Proof.
  intros [els H1 H2].
  specialize (H1 (S (sum els))).
  apply elem_sum in H1.
  lia.
Qed.

Lemma join_elem_length :
  forall {A : Type} {l : list A} {ll : list (list A)},
    Elem l ll -> length l <= length (join ll).
Proof.
  induction 1; cbn;
  rewrite length_app;
  lia.
Qed.

Lemma list_not_Finite :
  forall A : Type,
    ExactlyFinite (list A) -> A -> False.
Proof.
  intros A [els H1 H2] x.
  specialize (H1 (x :: join els)).
  apply join_elem_length in H1; cbn in H1.
  lia.
Qed.


Require Export StlcFix.SpecSyntax.
Require Export StlcFix.SpecEvaluation.
Require Export StlcFix.SpecTyping.
Require Export StlcFix.SpecAnnot.
Require Export StlcFix.LemmasTyping.
Require Export StlcFix.LemmasEvaluation.

Definition stlcOmega (ty : Ty) : Tm :=
  app (fixt tunit ty (abs (tunit ⇒ ty) (var 0))) unit.

Lemma stlcOmegaT {Γ ty} : ⟪ Γ ⊢ stlcOmega ty : ty ⟫.
Proof.
  unfold stlcOmega. crushTyping.
Qed.

Definition stlcOmegaA (τ : Ty) : TmA :=
  a_app tunit τ (a_fixt tunit τ (a_abs (tunit ⇒ τ) (tunit ⇒ τ) (a_var 0))) a_unit.

Lemma stlcOmegaAT {Γ ty} : ⟪ Γ a⊢ stlcOmegaA ty : ty ⟫.
Proof.
  unfold stlcOmegaA.
  repeat constructor.
Qed.

Lemma eraseAnnot_stlcOmegaA {τ} :
  eraseAnnot (stlcOmegaA τ) = stlcOmega τ.
Proof.
  unfold stlcOmegaA, stlcOmega.
  now cbn.
Qed.

#[export]
Hint Resolve stlcOmegaT : typing.
#[export]
Hint Resolve stlcOmegaAT : typing.

Definition stlcOmegaHelp (ty : Ty) : Tm :=
  app (abs tunit (app (fixt tunit ty (abs (tunit ⇒ ty) (var 0))) (var 0))) unit.

Lemma stlcOmega_cycles {ty} : stlcOmega ty -->+ stlcOmega ty.
Proof.
  cut (stlcOmega ty --> stlcOmegaHelp ty ∧ stlcOmegaHelp ty --> stlcOmega ty).
  - destruct 1. eauto with eval.
  - unfold stlcOmega, stlcOmegaHelp; split.
    + apply (eval_ctx₀ (papp₁ phole unit)); constructor.
    + apply (eval_ctx₀ phole); repeat constructor.
Qed.

Lemma stlcOmega_div {ty} : (stlcOmega ty)⇑.
Proof.
  apply cycles_dont_terminate.
  apply stlcOmega_cycles.
Qed.

Lemma stlcOmega_sub {ty γ} : (stlcOmega ty)[γ] = stlcOmega ty.
Proof.
  unfold stlcOmega.
  simpl; trivial.
Qed.

Arguments stlcOmega : simpl never.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import List Max ZArith EqNat.
From mathcomp Require Import ssreflect ssrbool eqtype.
Require Import bipl.
Require Import seplog.
Require Import expr_b_dp.
Require Import frag_list_triple.
Require Import frag_list_entail.

Import seplog_Z_m.
Import seplog_Z_m.assert_m.expr_m.
Import seplog_Z_m.assert_m.

Local Open Scope heap_scope.
Local Open Scope seplog_cmd_scope.
Local Open Scope seplog_hoare_scope.

(** swap the value of two cells *)
Local Close Scope Z_scope.

Definition i : var.v := 1.
Definition j : var.v := 2.
Definition x : var.v := 4.
Definition y : var.v := 3.
Definition vx : var.v := 5.
Definition vy : var.v := 6.

Definition swap (x y:var.v) : @while.cmd cmd0 expr_b :=
  i <-* var_e x;
  j <-* var_e y;
  var_e x *<- var_e j;
  var_e y *<- var_e i.

Definition swap_precond (x y:var.v) (vx vy : nat) : assrt :=
  (true_b, star (singl (var_e x) (var_e vx)) (singl (var_e y) (var_e vy))).

Definition swap_postcond (x y:var.v) (vx vy : nat) : assrt :=
  (true_b, star (singl (var_e x) (var_e vy)) (singl (var_e y) (var_e vx))).

(** with bigtoe *)

Lemma swap_verif :
  {{ assrt_interp (swap_precond x y vx vy) }}
  swap x y
  {{ Assrt_interp ((swap_postcond x y vx vy) :: nil) }}.
Proof.
rewrite /swap_precond /swap_postcond.
eapply tritra_use.
by simpl; intuition.
rewrite /x /y /i /j /vx /vy.
by Tritra.
Qed.

(*
intros.
unfold swap_precond.
unfold swap_postcond.
eapply tritra_use.
simpl; intuition.
unfold x; unfold y; unfold i; unfold j; unfold vx; unfold vy.
Tritra.
*)

Local Open Scope seplog_assert_scope.

Lemma tmp : forall (P Q:assert), P ===> Q ->
  P ===> (fun s h => Q s h \/ False).
Proof.
rewrite /while.entails; intros.
auto.
Qed.

Lemma swap_verif_step_by_step :
  {{ assrt_interp (swap_precond x y vx vy) }}
  swap x y
  {{ Assrt_interp ((swap_postcond x y vx vy) :: nil) }}.
Proof.
rewrite /swap_precond /swap_postcond.
eapply tritra_use.
by simpl; intuition.
rewrite /x /y /i /j /vx /vy.

Rotate_tritra_sig_lhs.
apply tritra_lookup.
by intros; omegab.

Rotate_tritra_sig_lhs.
eapply tritra_subst_lookup2.
by intros; omegab.
by simpl; intuition.

apply tritra_subst_mutation.
simpl.
Rotate_tritra_sig_lhs.
apply tritra_mutation.
by do 2 intro; omegab.

apply tritra_subst_mutation.
simpl.
Rotate_tritra_sig_lhs.
eapply tritra_mutation.
by do 2 intro; omegab.

apply tritra_subst_elt.
simpl.
apply tritra_entail.
rewrite /Assrt_interp.
apply tmp.
apply entail_soundness.
by Entail.
Qed.

(*intros.
unfold swap_precond.
unfold swap_postcond.
eapply tritra_use.
simpl; intuition.
unfold x; unfold y; unfold i; unfold j; unfold vx; unfold vy.
Rotate_tritra_sig_lhs.
eapply tritra_lookup.
intros; omegab.
Rotate_tritra_sig_lhs.
eapply tritra_subst_lookup2.
intros; omegab.
simpl; intuition.
Rotate_tritra_sig_lhs.
eapply tritra_subst_mutation.
simpl.
eapply tritra_mutation.
intros; omegab.
eapply tritra_subst_mutation.
simpl.
Rotate_tritra_sig_lhs.
eapply tritra_mutation.
intros; omegab.
eapply tritra_subst_elt.
simpl.
eapply tritra_entail.
eapply Decompose_Assrt_interp; left.
eapply entail_soundness; Entail.
*)

Require Import frag_list_vcg.

Lemma swap_verif' :
  {{ Assrt_interp ((swap_precond x y vx vy) :: nil) }}
  swap x y
  {{ Assrt_interp ((swap_postcond x y vx vy) :: nil) }}.
Proof.
rewrite /swap_precond /swap_postcond /swap /x /y /i /j /vx /vy.

Local Open Scope frag_list_vc_scope.

match goal with
|- {{ _ }} ?C {{ _ }} =>
  replace C with (frag_list_vcg.proj_cmd
    (1 <-* var_e 4 ;
    (2 <-* var_e 3 ;
    (var_e 4 *<- var_e 2 ;
    (var_e 3 *<- var_e 1)))))
end.

Local Close Scope frag_list_vc_scope.

apply bigtoe_fun_correct.
compute; reflexivity.
reflexivity.
Qed.