Set Implicit Arguments.

Require Import List Lia Arith Init.Wf Morphisms Program.Program.
From Undecidability.HOU Require Import concon.conservativity calculus.calculus.
Import ListNotations.
From Undecidability.HOU.unification Require Import systemunification nth_order_unification.

Tactic Notation "simplify" := Undecidability.HOU.std.tactics.simplify.

#[local] Notation "[ s | p ∈ A ]" := (map (fun p => s) A) (p pattern).

(* * First-Order Unification *)

(* ** Singlepoint Substitution *)
Section Update.

  Context {X: Const}.

  Definition update x v (sigma: fin -> exp X) :=
    fun y => if x == y then v else sigma y.

  Lemma singlepoint_subst_vars x s t: vars (update x s var • t) ⊆ vars s ++ vars t.
  Proof.
    intros ? (y & H1 & H2) % vars_varof % varof_subst.
    unfold update in *; destruct eq_dec; subst.
    eapply varof_vars in H2; simplify; eauto.
    inv H2. eapply varof_vars in H1; simplify; eauto.
  Qed.

  Lemma singlepoint_subst_vars_variable x s t:
    x ∈ vars (update x s var • t) -> x ∈ vars s /\ x ∈ vars t.
  Proof.
    intros (y & ? & ?) % vars_varof % varof_subst.
    unfold update in *; destruct eq_dec; subst; split; eauto using varof_vars.
    all: now exfalso; inv H0.
  Qed.

  Lemma singlepoint_subst_Vars' x s E: Vars' (update x s var •₊₊ E) ⊆ vars s ++ Vars' E.
  Proof.
    induction E as [|[u v]]; [cbn; easy|]; simplify.
    cbn; rewrite !singlepoint_subst_vars, IHE, <-!app_assoc.
    repeat eapply incl_app_build. all:eauto using incl_refl,incl_appr,incl_appl.
  Qed.

  Lemma singlepoint_subst_Vars'_variable x s E:
    x ∈ Vars' (update x s var •₊₊ E) -> x ∈ vars s /\ x ∈ Vars' E.
  Proof.
    induction E as [|[u v]]; [easy|]; simplify.
    cbn; simplify;
      intros [[H % singlepoint_subst_vars_variable | H % singlepoint_subst_vars_variable] | H].
    all:tauto.
  Qed.

  Lemma update_irrelevant x s t sigma:
    ~ x ∈ vars t -> update x s sigma • t = sigma • t.
  Proof.
    intros H; eapply subst_extensional; intros y.
    unfold update; destruct eq_dec; now subst.
  Qed.

  Lemma update_typing n Delta Gamma sigma (s: exp X) x A:
    Delta ⊩(n) sigma : Gamma -> Delta ⊢(n) s : A -> nth Gamma x = Some A -> Delta ⊩(n) update x s sigma : Gamma.
  Proof.
    intros ??????; unfold update; destruct eq_dec; subst; eauto; congruence.
  Qed.

End Update.

(* ** Lambda-Freeness *)
Section LambdaFreeness.

  Context {X: Const}.

  Inductive lambda_free : exp X -> Prop :=
  | lambda_free_var x: lambda_free (var x)
  | lambda_free_const c: lambda_free (const c)
  | lambda_free_app s t: lambda_free s -> lambda_free t -> lambda_free (s t).

  Lemma lambda_free_AppR s T:
    lambda_free s -> (forall t, t ∈ T -> lambda_free t) -> lambda_free (AppR s T).
  Proof.
    induction T; cbn; intuition (econstructor; eauto).
  Qed.

  Lemma ordertyping_one_atom Gamma (s: exp X) A:
    Gamma ⊢ s : A -> nf s -> ord A <= 1 -> isAtom (head s).
  Proof.
    destruct 2; subst; intros.
    destruct k; cbn; simplify; [eauto|].
    inv H. now eapply ord_arr_one in H0.
  Qed.

  Lemma order_one_lambda_free Gamma s A:
    normal s ->
    (Gamma ⊢(1) s : A) ->
    isAtom (head s) -> lambda_free s.
  Proof.
    intros N % normal_nf. induction N in Gamma, A |-*; subst.
    destruct k; cbn;[intros|easy].
    simplify in H1. eapply lambda_free_AppR.
    - destruct s; cbn in i; intuition econstructor.
    - eapply AppR_ordertyping_inv in H0 as H4; destruct H4 as [L H4].
      intuition idtac. assert (ord' L <= 1).
      + destruct s; cbn in i. 3-4:easy.
        * inv H3. simplify in H6. lia.
        * inv H3. rewrite H6 in H7.
          simplify in H7. lia.
      + eapply orderlisttyping_element in H2 as [B []]. 2:now eauto.
        eapply H; [eauto..|].
        eapply ordertyping_one_atom; [eauto..|].
        eapply ord'_elements; eauto.
  Qed.

  Lemma lambda_free_subst Delta (sigma: fin -> exp X) x A:
    (Delta ⊢(1) sigma x : A) -> ord A <= 1 ->
    normal (sigma x) -> lambda_free (sigma x).
  Proof.
    intros H1  H3 H4; eapply order_one_lambda_free; [eauto..|].
    eapply head_atom; eauto.
    destruct sigma; cbn; intuition idtac.
    inv H1. eapply ord_arr_one; eauto.
  Qed.

  Lemma lambda_free_not_lam s:
    lambda_free s -> ~ isLam s.
  Proof.
    now destruct 1.
  Qed.

  Lemma lambda_free_substitution sigma s:
    lambda_free s -> (forall x, x ∈ vars s -> lambda_free (sigma x)) -> lambda_free (sigma • s).
  Proof.
    induction 1; cbn; eauto using lambda_free.
    intros; econstructor; eauto;
      [eapply IHlambda_free1 | eapply IHlambda_free2]; intuition (auto with datatypes).
  Qed.

  Lemma lambda_free_subst_eqs sigma E:
    (forall x, x ∈ Vars' E -> lambda_free (sigma x)) -> all_terms lambda_free E -> all_terms lambda_free (sigma •₊₊ E).
  Proof.
    intros H; induction E as [| [s t]]; cbn; eauto; simplify; cbn in *.
    intros (H1 & H2 & H3). split; [|split].
    1 - 2: eapply lambda_free_substitution; eauto; intros; eapply H; intuition (auto with datatypes).
    eapply IHE; eauto; intuition (auto with datatypes); now eapply H.
  Qed.

  Lemma lambda_free_normal s:
    lambda_free s -> normal s.
  Proof.
    induction 1; [ eauto.. |].
    eapply normal_app_intro; eauto.
    now inv H.
  Qed.

End LambdaFreeness.

(* ** Simplified First-Order Unification *)
Local Hint Constructors lambda_free : core.
Section Unification.

  Variable (X: Const).
  Implicit Types (Gamma: ctx) (n: nat) (sigma tau: fin -> exp X) (s t: exp X)
           (E: list (exp X * exp X)).

  Variable (free: fin -> Prop) (isFree: Dec1 free).
  Definition bound x := ~ free x.

  Definition free' sigma :=
    (forall x, bound x -> sigma x = var x) /\
    (forall x, free x -> forall y, y ∈ vars (sigma x) -> free y).

  (* *** Term Decompositon *)
  Section Decomposition.

    Fixpoint decomp s t: option (eqs X) :=
      if s == t then Some nil
      else match s, t with
           | var x, t => Some [(var x, t)]
           | s, var x => Some [(var x, s)]
           | app s1 s2, app t1 t2 =>
             match decomp s1 t1, decomp s2 t2 with
             | Some E1, Some E2 => Some (E1 ++ E2)
             |  _, _ => None
             end
           | _, _ => None
           end.

    Fixpoint decomp' E :=
      match E with
      | nil => Some nil
      | e :: E => match decomp (fst e) (snd e),  decomp' E with
                 | Some E1, Some E2 => Some (E1 ++ E2)
                 | _, _ => None
                 end
      end.

    Lemma decomp_some_ind (P: exp X -> exp X -> eqs X -> Type):
      (forall s, P s s nil) ->
      (forall x s, var x <> s -> P (var x) s [(var x, s)]) ->
      (forall x s, var x <> s -> P s (var x) [(var x, s)]) ->
      (forall s1 s2 t1 t2 E1 E2, s1 s2 <> t1 t2 ->
                            decomp s1 t1 = Some E1 -> P s1 t1 E1 ->
                            decomp s2 t2 = Some E2 -> P s2 t2 E2 ->
                            P (s1 s2) (t1 t2) (E1 ++ E2)) ->
      forall s t E, decomp s t = Some E -> P s t E.
    Proof.
      intros H1 H2 H3; induction s; intros [] E; cbn.
      all: destruct eq_dec as [EQ|NEQ]; try discriminate.
      1 - 11: injection 1 as ?; subst E; eauto.
      1 - 4: injection EQ; intros; subst; eauto.
      destruct (decomp s1 e) eqn: EQ1; try discriminate.
      destruct (decomp s2 e0) eqn: EQ2; try discriminate.
      injection 1 as ?; subst.
      eapply X0; eauto.
    Qed.

    Lemma decomp_none_ind (P: exp X -> exp X -> Type):
      (forall x t, const x <> t -> ~ isVar t -> P (const x) t) ->
      (forall x t, const x <> t -> ~ isVar t -> P t (const x)) ->
      (forall s t, lambda s <> t -> P (lambda s) t) ->
      (forall s t, s <> lambda t -> P s (lambda t)) ->
      (forall s1 s2 t1 t2, s1 s2 <> t1 t2 -> P s1 t1 -> P (s1 s2) (t1 t2)) ->
      (forall s1 s2 t1 t2, s1 s2 <> t1 t2 -> P s2 t2 -> P (s1 s2) (t1 t2)) ->
      forall s t, decomp s t = None -> P s t.
    Proof.
      intros H1 H2 H3 H4 IH1 IH2 s t; induction s in t |-*; cbn.
      all: destruct eq_dec; try discriminate.
      all: destruct t; try discriminate; eauto.
      destruct decomp eqn: D1; [destruct (decomp s2 t2) eqn: D2|];
        try discriminate.
      all: intros _; eauto.
    Qed.

    Lemma decomp'_some_ind (P: eqs X -> eqs X -> Prop):
      P nil nil ->
      (forall s t E E1 E2, decomp s t = Some E1 ->
                      decomp' E = Some E2 -> P E E2 -> P ((s, t) :: E) (E1 ++ E2)) ->
      forall E E', decomp' E = Some E' -> P E E'.
    Proof.
      intros H IH; induction E as [| [s t]]; cbn.
      - now injection 1 as <-.
      - intros E'; destruct decomp eqn: H1;
          destruct decomp' eqn: H2; try discriminate.
        intros [= <-]; eauto.
    Qed.

    Lemma decomp'_none_ind (P: eqs X -> Type):
      (forall E s t, decomp s t = None -> P ((s, t) :: E)) ->
      (forall E s t, P E -> P ((s, t) :: E)) ->
      forall E, decomp' E = None -> P E.
    Proof.
      intros H IH; induction E as [| [s t]]; cbn; try discriminate.
      destruct decomp eqn: EQ1; [destruct decomp' eqn: EQ2 |]; try discriminate.
      all: intros _.  eapply IH; intuition easy. now eapply H.
    Qed.

    Ltac decomp_ind :=
      match goal with
      | [|- decomp ?s ?t = Some ?E -> _] =>
        intros H; pattern s, t, E; eapply decomp_some_ind; [idtac..|eapply H]; clear s t E H
      | [|- decomp ?s ?t = None -> _] =>
        intros H; pattern s, t; eapply decomp_none_ind; [idtac..|eapply H]; clear s t H
      | [|- decomp' ?E = Some ?E' -> _] =>
        intros H; pattern E, E'; eapply decomp'_some_ind; [idtac..|eapply H]; clear E E' H
      | [|- decomp' ?E = None -> _] =>
        intros H; pattern E; eapply decomp'_none_ind; [idtac..|eapply H]; clear E H
      end.

    Lemma decomp_some_head_consts s t E x y:
      decomp s t = Some E -> head s = const x -> head t = const y -> x = y.
    Proof.
      decomp_ind; eauto.
      all: cbn in *; congruence.
    Qed.

    Lemma decomp_typing s t E Gamma:
      decomp s t = Some E ->
      forall A, lambda_free s -> lambda_free t ->
           (Gamma ⊢(1) s : A) -> (Gamma ⊢(1) t : A) ->
           exists L, Gamma ⊢₊₊(1) E : L.
    Proof.
      decomp_ind; intros.
      - exists nil; econstructor.
      - exists [A]; eauto using eqs_ordertyping.
      - exists [A]; eauto using eqs_ordertyping.
      - inv H4. inv H5. inv H6. inv H7.
        enough (A0 → A = A1 → A) as H4. injection H4 as ->.
        edestruct H1 as [L1]; eauto. edestruct H3 as [L2]; eauto.
        exists (L1 ++ L2). eapply ordertyping_combine; unfold left_side, right_side; simplify.
        1 - 2: eapply orderlisttyping_app; try eapply left_ordertyping;
          try eapply right_ordertyping; eauto.
        eapply lambda_free_normal in H10 as H10'; eapply lambda_free_not_lam in H10 as H10''.
        eapply lambda_free_normal in H9 as H9'; eapply lambda_free_not_lam in H9 as H9''.
        eapply head_atom in H10' as H10'''; eauto. eapply head_atom in H9' as H9'''; eauto.
        destruct (head_decompose s1) as [S1].  destruct (head_decompose t1) as [T1].
        destruct (head s1); cbn in *;[  | | easy..];[| destruct (head t1)]; cbn in *. 4,5: easy.
        1: subst s1; eapply AppR_ordertyping_inv in H8 as (L & ? & V); inv V.
        2: subst t1; eapply AppR_ordertyping_inv in H6 as (L & ? & V); inv V.
        1: rewrite ord_Arr in H8; eapply Nat.max_lub_r, ord_arr_one in H8 as [].
        1: rewrite ord_Arr in H7; eapply Nat.max_lub_r, ord_arr_one in H7 as [].
        eapply decomp_some_head_consts in H0; subst; simplify; cbn; eauto. subst.
        eapply AppR_ordertyping_inv in H8 as (L1 & ? & ?).
        eapply AppR_ordertyping_inv in H6 as (L2 & ? & ?).
        inv H4. inv H6. rewrite H7 in H8.
        change (A0 → A) with (Arr [A0] A) in H8. change (A1 → A) with (Arr [A1] A) in H8.
        rewrite <-!Arr_app in H8. eapply Arr_left_injective in H8.
        eapply app_injective_right in H8. 2: easy. intuition congruence.
    Qed.

    Lemma decomp_lambda_free s t E:
      decomp s t = Some E ->  lambda_free s -> lambda_free t -> all_terms (@lambda_free X) E.
    Proof.
      decomp_ind; intros; eauto; simplify; cbn; eauto using all_terms_nil.
      inv H4; inv H5; intuition easy.
    Qed.

    Lemma decomp'_typing Gamma E E':
      decomp' E = Some E' ->
      forall L, all_terms (@lambda_free X) E ->
           Gamma ⊢₊₊(1) E : L -> exists L,  Gamma ⊢₊₊(1) E' : L.
    Proof.
      decomp_ind; eauto.
      intros s t E E1 E2 H H' IH L LF T. inv T. simplify in LF; intuition idtac.
      eapply decomp_typing in H as [L1]; eauto.
      edestruct IH as [L2]; eauto.
      exists (L1 ++ L2). eapply ordertyping_combine; unfold left_side, right_side; simplify.
      1 - 2: eapply orderlisttyping_app; try eapply left_ordertyping; try eapply right_ordertyping.
      all: eauto.
    Qed.

    Lemma decomp'_lambda_free E E':
      decomp' E = Some E' ->  all_terms (@lambda_free X) E -> all_terms (@lambda_free X) E'.
    Proof.
      decomp_ind; intros; eauto; simplify in *; intuition idtac.
      eapply decomp_lambda_free in H; firstorder.
    Qed.

    Lemma vars_decomp s t E:
      decomp s t = Some E -> Vars' E ⊆ vars s ++ vars t.
    Proof.
      decomp_ind; cbn; intros; simplify. 1-2:easy. now intros ? [->|];eauto using in_or_app,in_eq.
      rewrite H1, H3. (repeat eapply incl_app_build); intros ?; simplify. all:tauto.
    Qed.

    Lemma Vars_decomp' E E':
      decomp' E = Some E' -> Vars' E' ⊆ Vars' E.
    Proof.
      decomp_ind. easy. intros. simplify.
      now rewrite H1, vars_decomp; eauto.
    Qed.

  End Decomposition.

  Ltac decomp_ind :=
    match goal with
    | [|- decomp ?s ?t = Some ?E -> _] =>
      intros H; pattern s, t, E; eapply decomp_some_ind; [idtac..|eapply H]; clear s t E H
    | [|- decomp ?s ?t = None -> _] =>
      intros H; pattern s, t; eapply decomp_none_ind; [idtac..|eapply H]; clear s t H
    | [|- decomp' ?E = Some ?E' -> _] =>
      intros H; pattern E, E'; eapply decomp'_some_ind; [idtac..|eapply H]; clear E E' H
    | [|- decomp' ?E = None -> _] =>
      intros H; pattern E; eapply decomp'_none_ind; [idtac..|eapply H]; clear E H
    end.

  (* *** Unification Relation *)
  Reserved Notation "E ↦ sigma" (at level 80).

  Inductive unify E: (fin -> exp X) -> Prop :=
  | unifyId: decomp' E = Some nil -> E ↦ var
  | unifyStep x s E' sigma:
      decomp' E = Some ((var x, s) :: E') ->
      free x -> (forall y, y ∈ vars s -> free y) ->
      update x s var •₊₊ E' ↦ sigma ->
      ~ x ∈ vars s ->
      E ↦ update x (sigma • s) sigma
  where "E ↦ sigma" := (unify E sigma).

  (* *** Computability *)
  Section Computability.

    Definition subvars := MR strict_incl (@Vars' X).

    Lemma wf_subvars : well_founded subvars.
    Proof. eapply measure_wf, wf_strict_incl, eq_dec. Qed.

    Notation "( a ; b )" := (exist _ a b).

    Definition remember Y (x : Y) : {y | x = y}.
    Proof.
      exists x. reflexivity.
    Qed.

    Lemma unif (E: list (exp X * exp X)) : { sigma | E ↦ sigma } + ({ sigma | E ↦ sigma } -> False).
    Proof using isFree.
      pattern E. revert E. apply (well_founded_induction_type wf_subvars).
      intros E unif. destruct (decomp' E) as [[|[[x| | |] s] E']|] eqn:H.
      1: left; exists var; now econstructor.
      2-5: right; intros [σ H']; inv H'; congruence.
      destruct (x el vars s) as [?|?].
      { right; intros [σ H']; inv H'; congruence. }
      destruct (isFree x) as [?|?].
      2: { right; intros [σ H']; inv H'; congruence. }
      destruct (dec_all isFree (vars s)) as [?|?].
      2: { right. intros [σ H']; inv H'; [congruence|].
           rewrite H in H0. inv H0; eauto. }
      (* case ~ x ∈ vars s, free x, forall x : fin, x ∈ vars s -> free x *)
      destruct (unif [subst_eq (update x s var) p | p ∈ E']) as [[sigma IH]|IH].
      { unfold subvars, MR. eapply Vars_decomp' in H.
        split.
        + rewrite singlepoint_subst_Vars'. cbn in H. lauto.
        + exists x. split. cbn in H; lauto. intros ? % singlepoint_subst_Vars'_variable.
          easy. }
      - left. exists (update x (sigma • s) sigma).
        econstructor; eauto.
      - right; intros [σ H']; inv H'; [congruence|].
        rewrite H in H0. inv H0. eauto.
    Qed.

  End Computability.

  Section Unifiability.

    Definition unifies sigma s t := sigma • s = sigma • t.
    Definition Unifies sigma E := forall e, e ∈ E -> unifies sigma (fst e) (snd e).

    #[export] Instance unifies_equiv sigma: Equivalence (unifies sigma).
    Proof.
      constructor; unfold unifies; congruence.
    Qed.

    Lemma Unifies_cons sigma e E:
      Unifies sigma (e :: E) <-> unifies sigma (fst e) (snd e) /\ Unifies sigma E.
    Proof.
      unfold Unifies; cbn in *; intuition (subst; auto).
    Qed.

    Lemma Unifies_nil sigma: Unifies sigma nil.
    Proof. intros ? []. Qed.

    Hint Rewrite Unifies_cons : simplify.
    Hint Resolve Unifies_nil : core.

    Lemma Unifies_app sigma E1 E2:
      Unifies sigma (E1 ++ E2) <-> Unifies sigma E1 /\ Unifies sigma E2.
    Proof.
      induction E1; cbn; simplify; intuition easy.
    Qed.

    Hint Rewrite Unifies_app : simplify.

    Definition equi_unifiable (E1 E2: eqs X) :=
      forall sigma, Unifies sigma E1 <-> Unifies sigma E2.

    Notation "E1 ≈ E2" := (equi_unifiable E1 E2) (at level 80).

    #[export] Instance equi_unifiable_equivalence: Equivalence equi_unifiable.
    Proof.
      econstructor; [firstorder.. |].
      intros E1 E2 E3 H1 H2 sigma; unfold equi_unifiable in *.
      now rewrite H1, H2.
    Qed.

    Instance equi_unifiable_app:
      Proper (equi_unifiable ++> equi_unifiable ++> equi_unifiable)
             (@List.app (eq X)).
    Proof.
      intros ?????? sigma; simplify; firstorder.
    Qed.

    Lemma equi_unifiable_refl s: [(s, s)] ≈ nil.
    Proof.
      intros ?; simplify; cbn; intuition (auto with relations).
    Qed.

    Lemma equi_unifiable_comm s t: [(s, t)] ≈ [(t, s)].
    Proof.
      intros ?; simplify; cbn; intuition (auto with relations).
    Qed.

    Lemma equi_unifiable_decompose_app s1 s2 t1 t2:
      [(s1 s2, t1 t2)] ≈ [(s1, t1); (s2, t2)].
    Proof.
      intros ?;simplify; cbn; intuition (unfold unifies in *; cbn in *; congruence).
    Qed.

    Lemma equi_unifiable_cons x s E:
      (var x, s) :: E ≈ (var x, s) :: (update x s var •₊₊ E).
    Proof.
      intros ?; simplify; intuition idtac; cbn in *.
      - intros [u v] ?; mapinj; cbn; destruct x0 as [u' v'].
        injection H2 as <- <-. eapply H1 in H3; cbn in H3.
        unfold unifies in *; cbn in *.
        asimpl. etransitivity; [ etransitivity; [| eapply H3] |].
        all: eapply ext_exp;
          intros y; unfold funcomp, update; destruct eq_dec; subst; eauto.
      - intros [u v] ?; cbn. unfold unifies in H0; cbn in H0.
        eapply in_map with (f := subst_eq (update x s var)) in H.
        eapply H1 in H; cbn in H; unfold unifies in H.
        unfold unifies in *; cbn in *.
        asimpl in H. etransitivity; [ etransitivity; [| eapply H] |].
        all: eapply ext_exp; intros y; unfold funcomp, update;
          destruct eq_dec; subst; eauto.
    Qed.

    Hint Resolve equi_unifiable_refl equi_unifiable_app equi_unifiable_comm
         equi_unifiable_cons equi_unifiable_decompose_app
      : equi_unifiable.

    Lemma equi_unifiable_decomp s t E:
      decomp s t = Some E -> [(s,t)] ≈ E.
    Proof.
      decomp_ind.
      - eauto with equi_unifiable.
      - easy.
      - eauto with equi_unifiable.
      - intros. now rewrite <-H1, <-H3, equi_unifiable_decompose_app.
    Qed.

    Lemma equi_unifiable_decomp' E E':
      decomp' E = Some E' -> E ≈ E'.
    Proof.
      decomp_ind; intuition (auto with relations).
      now rewrite <-H1, <-equi_unifiable_decomp with (E := E1); eauto.
    Qed.

  End Unifiability.

  Hint Rewrite Unifies_cons Unifies_app: simplify.
  Hint Resolve Unifies_nil : core.

  (* *** Soundness *)
  Section Soundness.
    Lemma unify_lambda_free E sigma:
      E ↦ sigma -> all_terms (@lambda_free X) E -> forall x, lambda_free (sigma x).
    Proof.
      induction 1.
      - intros; eauto using @lambda_free.
      - intros H'; eapply decomp'_lambda_free in H; eauto. simplify in H.
        intros y; unfold update; destruct eq_dec; subst;intuition idtac.
        eapply lambda_free_substitution; eauto; intros x; intros.
        all: eapply IHunify; eapply lambda_free_subst_eqs; eauto.
        all: intros z; unfold update; destruct eq_dec; intuition econstructor.
    Qed.

    Lemma unify_unifiable E sigma:
      E ↦ sigma -> Unifies sigma E.
    Proof.
      induction 1.
      - eapply equi_unifiable_decomp' in H. eapply H; easy.
      - eapply equi_unifiable_decomp' in H. eapply H.
        eapply equi_unifiable_cons.
        eapply Unifies_cons; cbn; intuition idtac.
        + unfold unifies; cbn.
          unfold update at 1; destruct eq_dec. 2:easy.
          symmetry; erewrite subst_extensional; eauto.
          intros y ?. unfold update.
          destruct eq_dec; eauto; subst; easy.
        + intros [s' t'] ?; eapply IHunify in H4 as H4';
            unfold unifies in *; cbn in *.
          mapinj; destruct x0 as [u v]; injection H5 as <- <-.
          rewrite update_irrelevant. symmetry. rewrite update_irrelevant. symmetry.
          now rewrite H4'.
          all: intros ? % singlepoint_subst_vars_variable; easy.
    Qed.

    Lemma unify_free' E sigma:
      E ↦ sigma -> free' sigma.
    Proof.
      induction 1.
      - split; intuition trivial. now destruct H1 as [[= ->]|[]].
      - destruct IHunify; split; intros y; intros.
        + unfold update, bound in *; destruct eq_dec; subst; intuition auto.
        + unfold update in H7; destruct eq_dec; subst; eauto.
          eapply vars_subst in H7 as [y'].
          destruct H7; eauto.
    Qed.

    Variable (Gamma: ctx).
    Hypothesis (HO: ord' Gamma <= 1).

    Lemma unify_typing E L sigma:
      E ↦ sigma -> all_terms (@lambda_free X) E ->
      Gamma ⊢₊₊(1) E : L -> Gamma ⊩(1) sigma : Gamma.
    Proof using HO.
      induction 1 in L |-*.
      - intros; now eapply var_typing.
      - intros LF T. eapply decomp'_typing in T as T'; eauto.
        eauto; destruct T' as [L' T']; inv T'; inv H7.
        specialize (IHunify L0); mp IHunify; [| mp IHunify].
        + eapply decomp'_lambda_free in H; eauto. simplify in H; cbn in H. intuition idtac.
          eapply lambda_free_subst_eqs; eauto.
          intros y; unfold update; destruct eq_dec; subst; intros; eauto.
        + eapply eqs_ordertyping_preservation_subst; eauto.
          eapply update_typing; eauto; eapply var_typing; eauto.
        + eapply update_typing; [eauto| | eauto].
          eapply ordertyping_weak_preservation_under_substitution; eauto.
    Qed.

  End Soundness.

  (* *** Completeness *)
  Section Completeness.

    Lemma decomp_none_not_unifiable sigma s t:
      decomp s t = None -> lambda_free s -> lambda_free t -> ~ unifies sigma s t.
    Proof.
      decomp_ind.
      1 - 2: intros; destruct t; unfold unifies; cbn; solve [congruence | eauto].
      1 - 2: intros ?? _ H1 H2; inv H1; inv H2.
      1 - 2: intros ???? _ H H1 H2 U; inv H1; inv H2;
        eapply H; eauto; unfold unifies in *; cbn in *; congruence.
    Qed.

    Lemma decomp'_none_not_unifiable sigma E:
      decomp' E = None -> all_terms (@lambda_free X) E -> ~ Unifies sigma E.
    Proof.
      decomp_ind; intros; simplify in *; intuition idtac.
      eapply decomp_none_not_unifiable in H; intuition eauto.
    Qed.

    Lemma decomp_some_var s t e E:
      decomp s t = Some (e :: E) -> exists x, fst e = var x.
    Proof.
      remember (e :: E) as E'. intros H; revert H e E HeqE'; decomp_ind; intros.
      - discriminate.
      - injection HeqE' as ? ?; subst; eexists; cbn; eauto.
      - injection HeqE' as ? ?; subst; eexists; cbn; eauto.
      - destruct E1; eauto; injection HeqE' as ? ?; subst; eauto.
    Qed.

    Lemma decomp'_some_var e E E':
      decomp' E = Some (e :: E') -> exists x, fst e = var x .
    Proof.
      remember (e :: E') as E''. intros H; revert H e E' HeqE''; decomp_ind; intros.
      - discriminate.
      - destruct E1; eauto; injection HeqE'' as ? ?; subst; eauto.
        eapply decomp_some_var in H; eauto.
    Qed.

    Fixpoint size (s: exp X) :=
      match s with
      | var x => 0
      | const x => 0
      | lambda s => S (size s)
      | app s1 s2 => S(size s1 + size s2)
      end.

    Lemma size_ren delta s:
      size (ren delta s) = size s.
    Proof.
      induction  s in delta |-*; cbn; congruence.
    Qed.

    Lemma size_subst tau s:
      size (tau • s) = size s + Sum (map (tau >> size) (vars s)).
    Proof.
      induction s in tau |-*; cbn; simplify; trivial.
      - rewrite IHs. f_equal. f_equal. clear IHs.  generalize (vars s) as A.
        induction A as [|[] ?]; cbn; eauto.
        + destruct eq_dec; rewrite IHA; easy.
        + destruct eq_dec; rewrite IHA. lia. cbn.
          unfold funcomp at 1; now rewrite size_ren.
      - rewrite IHs1, IHs2; lia.
    Qed.

    Lemma unifies_not_var x s tau:
      var x <> s -> unifies tau (var x) s -> ~ x ∈ vars s.
    Proof.
      intros H1; unfold unifies; cbn; intros S % (f_equal size).
      rewrite size_subst in S.
      intros H; eapply H1; eapply in_map with (f := tau >> size) in H as H'.
      eapply Sum_in in H'.
      eapply vars_varof in H; inv H; cbn in *; eauto.
      all: unfold funcomp in *; lia.
    Qed.

    Lemma unifies_free sigma x s:
      ~ x ∈ vars s -> free' sigma -> unifies sigma (var x) s -> free x.
    Proof using isFree.
      intros H1 F H2; unfold unifies in *; cbn in *.
      destruct F as [F1 F2]. destruct (isFree x) as [H|H]; eauto.
      eapply F1 in H as H'. rewrite H' in H2.
      destruct s; try discriminate; cbn in H2.
      destruct (isFree f) as [L|L]; eauto.
      - eapply F2 with (y := x) in L; eauto; rewrite <-H2; cbn; auto.
      - exfalso; eapply H1; left; eapply F1 in L; congruence.
    Qed.

    Lemma unifies_free_all sigma x s:
      ~ x ∈ vars s -> free' sigma -> free x ->
      unifies sigma (var x) s -> (forall y, y ∈ vars s -> free y) .
    Proof using isFree.
      intros H1 F H2 H3 y H4; unfold unifies in *; cbn in *.
      destruct F as [F1 F2]. destruct (isFree y) as [H|H]; eauto.
      specialize (F2 _ H2) as H5. rewrite H3 in H5. eapply H5.
      eapply subst_vars. eauto. rewrite F1. cbn; eauto. now unfold bound.
    Qed.

    Lemma decomp_irrefl s t E:
      decomp s t = Some E -> forall u v, (u,v) ∈ E -> u <> v.
    Proof.
      decomp_ind; cbn. all: intuition idtac; simplify in *; try congruence.
      subst; destruct H4; eauto.
    Qed.

    Lemma decomp'_irrefl E E':
      decomp' E = Some E' -> forall u v, (u,v) ∈ E' -> u <> v.
    Proof.
      decomp_ind. all: intuition idtac; simplify in *.
      subst; destruct H2; [|eauto].
      eapply decomp_irrefl; eauto.
    Qed.

    Lemma eqs_size_induction P:
      (forall E, (forall E' x, Vars' E' ⊆ Vars' E -> x ∈ Vars' E -> ~ x ∈ Vars' E' -> P E') -> P E) ->
      forall E, P E.
    Proof.
      intros IH E. eapply well_founded_induction_type.
      eapply measure_wf, wf_strict_incl with (X := nat); typeclasses eauto.
      intros x H; eapply IH; intros; eapply H. split; eauto.
    Qed.

    Lemma unify_complete sigma E:
      free' sigma -> Unifies sigma E -> all_terms (@lambda_free X) E -> exists tau, E ↦ tau.
    Proof using isFree.
      intros F;
        induction E as [E IH] using eqs_size_induction; intros U LF.
      destruct (decomp' E) as [[| [t s] E']|] eqn: DE.
      - exists var. now econstructor.
      - eapply decomp'_some_var in DE as H'; cbn in H'; destruct H' as [x ->].
        eapply equi_unifiable_decomp' in DE as U'.
        eapply U' in U as H4; simplify in H4; destruct H4 as [H4 H5]; cbn in H4.
        eapply unifies_not_var in H4 as H6;
          [| eapply decomp'_irrefl; eauto; firstorder].
        eapply unifies_free in H6 as H7; eauto.
        specialize (unifies_free_all H6 F H7 H4) as H8.
        eapply Vars_decomp' in DE as H9; simplify in H9; cbn in H9.
        assert (Vars' (update x s var •₊₊ E') ⊆ Vars' E) by
            (rewrite singlepoint_subst_Vars'; eapply incl_cons_project_r; eauto).
        destruct (IH (update x s var •₊₊ E') x) as [tau]; trivial.
        + eapply H9; firstorder.
        + intros ? % singlepoint_subst_Vars'_variable; easy.
        + rewrite equi_unifiable_cons in U'.
          eapply U' in U; simplify in U; easy.
        + eapply decomp'_lambda_free in DE; eauto; simplify in DE; eauto.
          eapply lambda_free_subst_eqs; intuition idtac; eauto.
          unfold update; destruct eq_dec; (intuition auto); eauto using lambda_free.
        + exists (update x (tau • s) tau); econstructor; eauto.
      - eapply decomp'_none_not_unifiable in DE; intuition eauto.
        exfalso; eauto.
    Qed.
  End Completeness.

End Unification.

(* ** Retyping *)
Section Retyping.

  Variable (X: Const).
  Arguments s₀ {_} {_} _.
  Arguments t₀ {_} {_} _.
  Arguments Gamma₀ {_} {_} _.
  Arguments A₀ {_} {_} _.

  Definition retype_ctx (n: nat) (Gamma : ctx) :=
    map (fun A => if dec2 le (ord A) n then A else alpha) Gamma.

  Lemma retype_ctx_ord n Gamma: 1 <= n -> ord' (retype_ctx n Gamma) <= n.
  Proof.
    intros H; induction Gamma; cbn; eauto; unfold retype_ctx in *.
    rewrite IHGamma; destruct dec2; eauto.
  Qed.

  Fixpoint retype_type (n: nat) (A : type) :=
    match A with
    | typevar beta => typevar beta
    | A → B => (if dec2 le (ord A) n then A else alpha) → retype_type n B
    end.

  Lemma retype_type_ord n A: 1 <= n -> ord (retype_type n A) <= S n.
  Proof.
    intros H; induction A; cbn [retype_type].
    - cbn; lia.
    - destruct dec2; simplify; intuition (auto with arith).
  Qed.

  Lemma retype_type_id n A: ord A <= S n -> retype_type n A = A.
  Proof.
    induction A; cbn [retype_type]; simplify; intuition idtac.
    destruct dec2; [congruence | lia].
  Qed.

  Lemma retype_Arr n L A:
    retype_type n (Arr L A) = Arr (retype_ctx n L) (retype_type n A).
  Proof.
    induction L; cbn; eauto; now rewrite IHL.
  Qed.

  Lemma normal_retyping n Gamma (s: exp X) A:
    normal s -> Gamma ⊢(n) s : A -> retype_ctx n Gamma ⊢(n) s : retype_type n A.
  Proof.
    intros H % normal_nf; induction H in Gamma, A |-*; subst.
    intros (L & B & ? & -> & ?) % Lambda_ordertyping_inv.
    rewrite retype_Arr. eapply Lambda_ordertyping; [unfold retype_ctx; now simplify|].
    unfold retype_ctx; rewrite <-map_rev, <-map_app; fold (retype_ctx n (rev L ++ Gamma)).
    eapply AppR_ordertyping_inv in H0 as (L' & ? &  ?).
    assert (ord' L' <= n).
    - destruct s; destruct i; inv H2; simplify in H4. now intuition auto.
      rewrite H4 in H5; simplify in H5; intuition (auto with arith).
    - eapply AppR_ordertyping with (L := retype_ctx n L').
      + clear H2.
        induction H0; eauto.
        econstructor. all: cbn in H3; simplify in H3. 2:intuition (auto with datatypes).
        destruct dec2; intuition trivial.
        erewrite <-retype_type_id; [| transitivity n; eauto].
        eapply H; cbn; auto.
      + unfold retype_ctx at 2;
          rewrite <-map_rev; fold (retype_ctx n (rev L')).
        rewrite <-retype_Arr. destruct s; destruct i.
        all: inv H2; rewrite retype_type_id. 2-4:eauto.
        econstructor; eauto.
        unfold retype_ctx; erewrite map_nth_error; eauto.
        destruct dec2; easy.
  Qed.

  Instance retype n (I: orduni n X) : orduni n X.
  Proof.
    refine {|
      Gamma₀ := retype_ctx n (Gamma₀ I);
      s₀ := eta₀ (s₀ I) H1₀;
      t₀ := eta₀ (t₀ I) H2₀;
      A₀ := retype_type n (A₀ I) |}.
    - abstract (eapply normal_retyping; [apply eta₀_normal | apply eta₀_typing]).
    - abstract (eapply normal_retyping; [apply eta₀_normal | apply eta₀_typing]).
  Defined.

  Lemma retype_iff n (I: orduni n X):
    1 <= n -> OU n X I <-> OU n X (@retype n I).
  Proof.
    intros Leq. rewrite orduni_normalise_correct.
    destruct I as [Gamma s t A ? ?]; unfold orduni_normalise, retype, OU; cbn.
    split; intros (Delta & sigma & ? & ?); eapply conservativity.ordertyping_weak_ordertyping. 1,3,4,6:now eauto.
    all: intros ??; simplify; intros ? [H'|H']; eapply H.
    all: rewrite nth_error_map_option in *.
    all: destruct (nth Gamma x) eqn: N; try discriminate; cbn in *.
    all: destruct dec2 as [|L]; eauto.
    all: exfalso; eapply L.
    all: eauto using vars_ordertyping_nth, eta₀_typing.
  Qed.

End Retyping.

(* ** Full First-Order Unification  *)
Section FirstOrderDecidable.

  Variable (X: Const).
  Implicit Types (Gamma: ctx) (n: nat) (sigma tau: fin -> exp X) (s t: exp X)
           (E: list (exp X * exp X)).

  Let free (k: nat) (x: nat) := x >= k.

  Instance dec_free k: Dec1 (free k).
  Proof. unfold free; typeclasses eauto. Qed.

  Definition decr (k: nat) (sigma: fin -> exp X) (x: nat) := ren (fun y => y - k) (sigma (x + k)).

  Lemma decr_lambda_free k sigma:
    (forall x, lambda_free (sigma x)) -> (forall x, lambda_free (decr k sigma x)).
  Proof.
    intros H x; unfold decr; asimpl.
    eapply lambda_free_substitution; intros; cbn; eauto; econstructor.
  Qed.

  Lemma FO_subst_equiv_eq Delta sigma Gamma (s t: exp X) A:
    (Delta ⊩(1) sigma : Gamma) -> (forall x, normal (sigma x)) ->
    normal s -> normal t -> (Gamma ⊢(1) s : A) -> (Gamma ⊢(1) t : A) ->
    sigma • s ≡ sigma • t -> sigma • s = sigma • t.
  Proof.
    intros. rewrite !subst_extensional
              with (sigma := sigma)
                   (tau := fun x => if x el (vars s ++ vars t) then sigma x else var x).
    2 - 3: intros; edestruct dec_in as [D|D]; simplify in D; intuition easy.
    eapply equiv_unique_normal_forms. easy.
    1: rewrite !subst_extensional
      with (tau := sigma)
           (sigma := fun x => if x el (vars s ++ vars t) then sigma x else var x); eauto.
    1 - 2: intros; edestruct dec_in as [D|D]; simplify in D; intuition easy.
    all: eapply normal_subst; eauto 2; intros x; destruct dec_in; eauto 2.
    all: simplify in i; destruct i as [V|V]; eapply vars_ordertyping in V as V'; eauto 2.
    all: destruct V' as (B & V1 & V2).
    all: eapply lambda_free_not_lam, lambda_free_subst; eauto 2.
  Qed.

  Lemma decr_typing L Gamma n sigma:
    free' (free (length L)) sigma -> L ++ Gamma ⊩(n) sigma : L ++ Gamma -> Gamma ⊩(n) decr (length L) sigma : Gamma.
  Proof.
    intros ? ? x A ?; unfold decr. destruct H as [F1 F2].
    eapply ordertyping_weak_preservation_under_renaming with (Gamma := L ++ Gamma).
    - eapply H0. rewrite nth_error_app2; simplify; eauto.
    - intros y B H ?. eapply F2 in H2; unfold free in *; eauto.
      rewrite nth_error_app2 in H; simplify in *; eauto.
  Qed.

  Lemma decr_unifies sigma (s t: exp X) k:
    unifies sigma s t -> free' (free k) sigma -> unifies (decr k sigma) (Lambda k s) (Lambda k t).
  Proof.
    intros H1 [H2 H3]; unfold unifies in *; asimpl; f_equal.
    erewrite subst_extensional. symmetry. erewrite subst_extensional; eauto.
    all: intros x V; destruct (le_lt_dec k x).
    1, 3:  rewrite it_up_ge; eauto; unfold decr; asimpl.
    1 - 2: rewrite Nat.sub_add;
      eauto; asimpl; rewrite subst_extensional with (tau := var); [now asimpl|].
    1 - 2: intros y ? % H3; unfold free in *; eauto; unfold funcomp; f_equal; lia.
    1 - 2: rewrite it_up_lt; eauto; symmetry; eapply H2; unfold bound, free; lia.
  Qed.

  Lemma it_up_free' k (sigma: fin -> exp X): free' (free k) (it k up sigma).
  Proof.
    unfold free; split; intros x; unfold bound.
    - intros ?; rewrite it_up_lt; intuition idtac. lia.
    - intros ? y. rewrite it_up_ge; eauto.
      intros [z [->]] % vars_varof % varof_ren; eauto.
  Qed.

  Lemma firstorder_decidable' (I: orduni 1 X):
    ord' Gamma₀ <= 1 -> ord A₀ <= 2 ->
    normal s₀ -> normal t₀ -> Dec (NOU 1 I).
  Proof.
    intros O1 O2 N1 N2; eapply iff_dec with (P := exists Delta sigma, Delta ⊩(1) sigma : Gamma₀  /\ sigma • s₀ = sigma • t₀ /\ (forall x : fin, normal (sigma x))).
    split; intros (Delta & sigma & ?); exists Delta; exists sigma; intuition idtac; eauto 2 using FO_subst_equiv_eq, eq_equiv.
    destruct I as [Gamma s t A H1 H2]; cbn in *; subst. unfold NOU; cbn in *.
    eapply normal_nf in N1 as N1'; destruct N1' as [k1 s ? ? ? ? ->].
    eapply normal_nf in N2 as N2'; destruct N2' as [k2 t ? ? ? ? ->].
    eapply normal_Lambda in N1. eapply normal_Lambda in N2.
    destruct (k1 == k2) as [H4|H4];
      [subst; destruct (@unif _ (fun x => x >= k2) _ [(AppR s T, AppR t T0)]) as [[sigma H']|H']|].
    1: left. 2: right. 3: right.
    all: eapply Lambda_ordertyping_inv in H1 as (L & B & ? & ? & ?).
    all: eapply Lambda_ordertyping_inv in H2 as (L' & B' & ? & ? & ?); subst.
    1, 2: assert (L = L' /\ B = B') as []; [|subst L' B'; clear H3 H4].
    1, 3: try (clear H'); eapply Arr_inversion in H3 as [? []]; try lia; rewrite ?H4;
      eauto 2; destruct x; cbn in *; simplify in H0; eauto 2;
        subst; simplify in H4; cbn in H4; lia.
    all: simplify in O2; cbn in O2; destruct O2 as [O2 _]; eapply le_S_n in O2.
    all: assert (ord' (rev L ++ Gamma) <= 1) by now simplify.
    all: eapply order_one_lambda_free in N1 as L1; simplify; eauto 2.
    all: eapply order_one_lambda_free in N2 as L2; simplify; eauto 2.
    + eapply unify_free' in H' as P.
      eapply unify_typing with (Gamma := rev L ++ Gamma) (L := [B]) in H' as T2;
        [| eauto|simplify; cbn; intuition idtac; eauto using all_terms_nil|eauto using eqs_ordertyping].
      specialize (unify_lambda_free H') as LF; mp LF; simplify; intuition idtac;
        eauto using all_terms_nil.
      exists Gamma. exists (decr (length L) sigma). intuition idtac.
      * specialize decr_typing with (L := rev L) as H9; simplify in H9; eauto.
      * eapply decr_unifies; eauto.
        specialize (unify_unifiable H' (AppR s T, AppR t T0)); cbn; auto.
      * eapply lambda_free_normal. pose proof (free := fun (k: nat) (x: nat) => x >= k).
        eapply decr_lambda_free; intros; eapply LF.
    + intros (Delta & sigma & E1 & E2 & E3).  asimpl in E2.
      eapply Lambda_injective in E2.
      edestruct unify_complete with (sigma := it (|L|) up sigma)
                                    (E := [(AppR s T,AppR t T0)])
                                    (free := free (|L|)); eauto.
      * typeclasses eauto.
      * eapply it_up_free'.
      * rewrite Unifies_cons. cbn; unfold unifies; asimpl; asimpl in E2; intuition eauto using Unifies_nil.
      * simplify; eauto using all_terms_nil.
    + intros (Delta & sigma & ? & ? & ?).
      assert (|L| < |L'| \/ |L'| < |L|) as [LT|LT] by lia.
      2: symmetry in H3.
      all: eapply Arr_inversion in H3 as [L'']. 2,4:intuition auto. all:intuition idtac;subst.
      all: simplify in H5; asimpl in H5; rewrite <-Lambda_plus in H5.
      all: eapply Lambda_injective in H5; destruct L''; [ simplify in LT; try lia; cbn in H5 | ].
      1: destruct T; destruct s; cbn in H5; try discriminate; [| destruct i].
      2: destruct T0; destruct t; cbn in H5; try discriminate; [| destruct i0].
      all: try destruct (le_lt_dec (length L') f); try destruct (le_lt_dec (length L) f).
      2, 4: rewrite it_up_lt in H5; try discriminate;eauto 2.
      1: inv H. 2: inv H2.
      all: cbn [Arr] in H7; now eapply ord_arr_one in H7.
  Qed.

  Lemma firstorder_decidable: Dec1 (OU 1 X).
  Proof.
    intros I. eapply iff_dec. eapply retype_iff; eauto.
    eapply iff_dec. eapply OU_NOU; eauto.
    eapply firstorder_decidable'; cbn; eauto 2 using retype_ctx_ord, retype_type_ord, eta₀_normal.
  Qed.

End FirstOrderDecidable.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep Bedrock.Platform.Bootstrap.

Hint Rewrite roundTrip_0 : N.

Lemma zero_le : forall w : W, natToW 0 <= w.
  intros; nomega.
Qed.

Hint Immediate zero_le.

Lemma length_upd' : forall v bs p,
  length (Array8.updN bs p v) = length bs.
  induction bs; simpl; intuition.
  destruct p; simpl; intuition.
Qed.

Lemma length_upd : forall p v bs,
  length (Array8.upd bs p v) = length bs.
  intros; apply length_upd'.
Qed.

Hint Rewrite length_upd : sepFormula.

Lemma next' : forall (i : W),
  (exists len' : W, (wordToNat i < wordToNat len')%nat)
  -> wordToNat (i ^+ $ (1)) = wordToNat i + 1.
  destruct 1; erewrite next; eauto.
  instantiate (1 := x); nomega.
Qed.

Hint Rewrite next' using (eexists; eassumption) : N.

Lemma next : forall (i : W),
  (exists len' : W, i < len')
  -> wordToNat (i ^+ $ (1)) = wordToNat i + 1.
  destruct 1; eapply next'; eauto.
  pre_nomega; eauto.
Qed.

Hint Rewrite next using (eexists; eassumption) : sepFormula.

Lemma increment : forall (i len len' : W),
  i < len
  -> len = len'
  -> i ^+ $1 <= len'.
  intros; subst; pre_nomega; nomega.
Qed.

Hint Immediate increment.

Lemma wordToNat_eq : forall sz (u v : word sz),
  wordToNat u = wordToNat v
  -> u = v.
  intros; apply (f_equal (@natToWord sz)) in H;
    repeat rewrite natToWord_wordToNat in H; auto.
Qed.

Lemma squeeze : forall (len i len' : W),
  len <= i
  -> len = len'
  -> i <= len'
  -> len' = i.
  intros; subst; apply wordToNat_eq; nomega.
Qed.

Hint Rewrite wordToNat_natToWord_idempotent using assumption : sepFormula.

Lemma selN_updN_eq : forall v ls p,
  (p < length ls)%nat
  -> Array8.selN (Array8.updN ls p v) p = v.
  induction ls; simpl; intuition.
  destruct p; simpl; intuition.
Qed.

Lemma selN_updN_ne : forall v ls p p',
  (p < length ls)%nat
  -> p <> p'
  -> Array8.selN (Array8.updN ls p v) p' = Array8.selN ls p'.
  induction ls; simpl; intuition.
  destruct p, p'; simpl; intuition.
Qed.

Lemma selN_upd_eq : forall v ls p,
  goodSize (length ls)
  -> p < natToW (length ls)
  -> Array8.selN (Array8.upd ls p v) (wordToNat p) = v.
  unfold Array8.upd; intros; apply selN_updN_eq; nomega.
Qed.

Lemma selN_upd_ne : forall v ls p p',
  goodSize (length ls)
  -> p < natToW (length ls)
  -> wordToNat p <> p'
  -> Array8.selN (Array8.upd ls p v) p' = Array8.selN ls p'.
  unfold Array8.upd; intros; apply selN_updN_ne; auto; nomega.
Qed.

Hint Resolve selN_upd_ne selN_upd_eq.

Lemma selN_oob : forall ls i,
  (i >= length ls)%nat
  -> Array8.selN ls i = wzero _.
  induction ls; simpl; intuition.
  destruct i; simpl; intuition.
Qed.

Require Import Bedrock.Platform.Bootstrap.
Local Hint Resolve get_put_eq get_put_ne get_emp.

Lemma materialize_array8'' : forall p v,
  p =*> v ===> Ex b1, p =8> b1 * Ex b2, (p ^+ $1) =8> b2 * Ex b3, (p ^+ $2) =8> b3 * Ex b4, (p ^+ $3) =8> b4.
  intros; hnf; unfold himp; intros.
  unfold ptsto32, ptsto8, hptsto.
  apply injL; intuition.
  propxFo.
  unfold smem_get_word, H.footprint_w in *.

  repeat match type of H0 with
           | match ?E with None => _ | _ => _ end = _ => case_eq E; intros;
             match goal with
               | [ H : _ = _ |- _ ] => rewrite H in *
             end; try discriminate
         end.
  do 4 esplit.
  apply split_put_clear; [ apply split_a_semp_a | apply H ].
  intuition eauto.
  rewrite get_put_ne; auto.
  do 4 esplit.
  apply split_put_clear; [ apply split_a_semp_a | ].
  rewrite get_clear_ne; apply H2 || W_neq.
  intuition eauto.
  rewrite get_put_ne; auto.
  do 4 esplit.
  apply split_put_clear; [ apply split_a_semp_a | ].
  rewrite get_clear_ne.
  rewrite get_clear_ne; try apply H3.
  W_neq.
  W_neq.
  intuition eauto.
  rewrite get_put_ne; auto.
  do 2 esplit.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  rewrite get_clear_ne; try apply H4.
  W_neq.
  W_neq.
  W_neq.
  intros.
  destruct (weq p' (p ^+ $2)); subst.
  apply get_clear_eq.
  rewrite get_clear_ne by auto.
  destruct (weq p' (p ^+ $1)); subst.
  apply get_clear_eq.
  rewrite get_clear_ne by auto.
  destruct (weq p' p); subst.
  apply get_clear_eq.
  rewrite get_clear_ne; eauto.
Qed.

Lemma materialize_array8' : forall p sz offset,
  allocated p offset sz ===> Ex bs, array8 bs (p ^+ $ (offset)) * [| (length bs = sz * 4)%nat |].
  induction sz; simpl; intuition.

  sepLemma.
  instantiate (1 := nil); auto.
  sepLemma.

  sepLemmaLhsOnly.
  destruct offset.
  etransitivity; [ eapply himp_star_frame; [ apply IHsz | apply materialize_array8'' ] | ].
  sepLemmaLhsOnly.
  fold (@length B) in *.
  apply himp_ex_c; exists (x3 :: x2 :: x1 :: x0 :: x4).
  sepLemma.
  etransitivity; [ eapply himp_star_frame; [ apply IHsz | apply materialize_array8'' ] | ].
  sepLemmaLhsOnly.
  fold (@length B) in *.
  apply himp_ex_c; exists (x3 :: x2 :: x1 :: x0 :: x4).
  sepLemma.
  match goal with
    | [ |- himp _ (array8 _ ?X) (array8 _ ?Y) ] => replace Y with X; try reflexivity
  end.
  rewrite (natToW_S (S (S (S (S offset))))).
  rewrite (natToW_S (S (S (S offset)))).
  rewrite (natToW_S (S (S offset))).
  rewrite (natToW_S (S offset)).
  rewrite (natToW_S offset).
  words.
Qed.

Theorem materialize_array8 : forall p sz,
  p =?> sz ===> Ex bs, array8 bs p * [| (length bs = sz * 4)%nat |].
  intros; eapply Himp_trans; [ apply materialize_array8' | ].
  replace (p ^+ $0) with p by words.
  apply Himp_refl.
Qed.

Lemma decomission_array8'' : forall p b1 b2 b3 b4,
  (p =8> b1 * (p ^+ $1) =8> b2 * (p ^+ $2) =8> b3 * (p ^+ $3) =8> b4) ===> Ex w, p =*> w.
  intros; hnf; unfold himp; intros.
  unfold ptsto32, ptsto8, hptsto.
  repeat ((apply existsL; intro) || (apply andL; (apply injL; intro) || (apply swap; apply injL; intro))).
  apply injL; intuition.
  propxFo.
  do 2 esplit.
  unfold smem_get_word, H.footprint_w.
  repeat (erewrite split_smem_get; [ | | eauto ]).
  eauto.
  eauto.
  eapply split_assoc.
  apply split_comm; eauto.
  eauto.
  eapply split_assoc.
  apply split_comm; eauto.
  eapply split_assoc.
  apply split_comm; eauto.
  eauto.
  eapply split_assoc.
  apply split_comm; eauto.
  eapply split_assoc.
  apply split_comm; eauto.
  apply split_comm; eauto.
  intuition idtac.
  unfold split in *; intuition subst.
  repeat rewrite join_None; eauto.
Qed.

Lemma pull_out : forall P Q R S T,
  P * (Q * (R * (S * T))) ===> (P * Q * R * S) * T.
  sepLemma.
Qed.

Lemma decomission_array8' : forall p sz bs offset sz',
  length bs = sz' * 4
  -> (sz' < sz)%nat
  -> array8 bs (p ^+ $ (offset)) ===> allocated p offset sz'.
  induction sz; simpl; intuition.

  destruct bs; simpl in *.
  destruct sz'; simpl in *; try discriminate.
  sepLemma.

  destruct sz'; simpl in *; try discriminate.
  do 3 (destruct bs; simpl in *; try discriminate).
  replace (p ^+ $ (offset) ^+ $1 ^+ $1 ^+ $1) with (p ^+ $ (offset) ^+ $3) by words.
  replace (p ^+ $ (offset) ^+ $1 ^+ $1) with (p ^+ $ (offset) ^+ $2) by words.

  eapply Himp_trans; [ apply pull_out | ].
  apply Himp_star_frame.
  eapply Himp_trans; [ apply decomission_array8'' | ].
  destruct offset; sepLemma.
  eapply Himp_trans; [ | apply IHsz ]; auto.
  match goal with
    | [ |- array8 _ ?X ===> array8 _ ?Y ] => replace Y with X; try apply Himp_refl
  end.
  change ($ (S (S (S (S offset))))) with (natToW (S (S (S (S offset))))).
  rewrite (natToW_S (S (S (S offset)))).
  rewrite (natToW_S (S (S offset))).
  rewrite (natToW_S (S offset)).
  rewrite (natToW_S offset).
  unfold natToW.
  W_eq.
  congruence.
Qed.

Lemma decomission_array8 : forall p bs sz,
  length bs = sz * 4
  -> array8 bs p ===> p =?> sz.
  intros; eapply Himp_trans; [ | eapply decomission_array8' ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
  auto.
  constructor.
Qed.

Lemma firstn_nil : forall A n,
  firstn n (nil (A := A)) = nil.
  destruct n; auto.
Qed.

Lemma skipn_nil : forall A n,
  skipn n (nil (A := A)) = nil.
  destruct n; auto.
Qed.

Theorem array8_split : forall bs p n,
  (n <= length bs)%nat
  -> array8 bs p ===> array8 (firstn n bs) p * array8 (skipn n bs) (p ^+ $ (n)).
  induction bs; simpl; intuition.

  rewrite firstn_nil; rewrite skipn_nil; simpl.
  apply Himp_star_Emp'.

  destruct n; simpl in *.
  replace (p ^+ $0) with p by W_eq.
  sepLemma.

  sepLemma; fold (@skipn B); fold (@firstn B).
  etransitivity; [ apply (IHbs _ n) | ]; auto.
  replace (p ^+ natToW (S n)) with (p ^+ natToW 1 ^+ $ (n))
    by (rewrite (natToW_S n); unfold natToW; words).
  sepLemma.
Qed.

Theorem array8_join : forall bs p n,
  (n <= length bs)%nat
  -> array8 (firstn n bs) p * array8 (skipn n bs) (p ^+ $ (n)) ===> array8 bs p.
  induction bs; simpl; intuition.

  rewrite firstn_nil; rewrite skipn_nil; simpl.
  apply Himp_star_Emp.

  destruct n; simpl in *.
  replace (p ^+ $0) with p by W_eq.
  sepLemma.

  sepLemma; fold (@skipn B); fold (@firstn B).
  etransitivity; [ | apply (IHbs _ n) ]; auto.
  replace (p ^+ natToW (S n)) with (p ^+ natToW 1 ^+ $ (n))
    by (rewrite (natToW_S n); unfold natToW; words).
  sepLemma.
Qed.

Lemma firstn_length : forall A (ls : list A) n,
  (n <= length ls)%nat
  -> length (firstn n ls) = n.
  induction ls; destruct n; simpl; intuition.
Qed.

Lemma skipn_length : forall A (ls : list A) n,
  (n <= length ls)%nat
  -> length (skipn n ls) = length ls - n.
  induction ls; destruct n; simpl; intuition.
Qed.

Theorem buffer_split : forall len p n,
  (n <= len)%nat
  -> buffer p len ===> buffer p n * buffer (p ^+ $ (n)) (len - n).
  unfold buffer; sepLemmaLhsOnly; fold (@length B) in *.
  etransitivity; [ apply array8_split | ]; eauto.
  sepLemma; fold (@length B); fold (@firstn B); fold (@skipn B);
    auto using firstn_length, skipn_length.
Qed.

Lemma firstn_app : forall A (ls2 ls1 : list A),
  firstn (length ls1) (ls1 ++ ls2) = ls1.
  induction ls1; simpl; intuition.
Qed.

Lemma skipn_app : forall A (ls2 ls1 : list A),
  skipn (length ls1) (ls1 ++ ls2) = ls2.
  induction ls1; simpl; intuition.
Qed.

Theorem buffer_join : forall len p n,
  (n <= len)%nat
  -> buffer p n * buffer (p ^+ $ (n)) (len - n) ===> buffer p len.
  unfold buffer; sepLemmaLhsOnly; fold (@length B) in *.
  apply himp_ex_c; exists (x0 ++ x).
  rewrite app_length.
  etransitivity; [ | apply himp_star_comm ].
  apply himp_star_pure_cc; [ omega | ].
  etransitivity; [ | apply array8_join ].
  2: instantiate (1 := length x0); rewrite app_length; omega.
  rewrite firstn_app; rewrite skipn_app.
  sepLemma.
Qed.

(** * Convenient restatements to use as Bedrock [sep] hints *)

Inductive please_materialize (sz : nat) : Prop := PleaseMaterialize.
Hint Constructors please_materialize.

Theorem materialize_array8_tagged : forall p sz,
  please_materialize sz
  -> p =?> sz ===> Ex bs, array8 bs p * [| (length bs = sz * 4)%nat |].
  intros; apply materialize_array8.
Qed.

Inductive please_materialize_buffer (sz : nat) : Prop := PleaseMaterializeBuffer.
Hint Constructors please_materialize_buffer.

Theorem materialize_buffer : forall p sz,
  please_materialize_buffer sz
  -> p =?> sz ===> p =?>8 (sz * 4).
  intros; apply materialize_array8.
Qed.

Definition array8_decomission (sz : nat) := array8.

Definition decomission_ok (sz : nat) (bs : list B) :=
  length bs = sz * 4.

Lemma decomission_array8_tagged : forall p bs sz,
  decomission_ok sz bs
  -> array8_decomission sz bs p ===> p =?> sz.
  intros; apply decomission_array8; auto.
Qed.

Definition array8_splitAt (n : nat) := array8.

Theorem array8_split_tagged : forall bs p n,
  (n <= length bs)%nat
  -> array8_splitAt n bs p ===> array8 (firstn n bs) p * array8 (skipn n bs) (p ^+ $ (n)).
  intros; apply array8_split; auto.
Qed.

Definition array8_joinAt (n : nat) := array8.

Theorem array8_join_tagged : forall bs p n,
  (n <= length bs)%nat
  -> array8 (firstn n bs) p * array8 (skipn n bs) (p ^+ $ (n)) ===> array8_joinAt n bs p.
  intros; apply array8_join; auto.
Qed.

Definition buffer_splitAt (n : nat) := buffer.

Theorem buffer_split_tagged : forall len p n,
  (n <= len)%nat
  -> buffer_splitAt n p len ===> buffer p n * buffer (p ^+ $ (n)) (len - n).
  intros; apply buffer_split; auto.
Qed.

Definition buffer_joinAt (n : nat) := buffer.

Theorem buffer_join_tagged : forall len p n,
  (n <= len)%nat
  -> buffer p n * buffer (p ^+ $ (n)) (len - n) ===> buffer_joinAt n p len.
  intros; apply buffer_join; auto.
Qed.


Require Export Classical.

(* Require Import SecOrder. *)
Require Export P_occurs_in_alpha.
Require Export ST_setup.
Require Export Correctness_ST.
Require Export Coq.Arith.EqNat my_bool.
Require Export List_machinery_impl My_List_Map.
Require Export Unary_Predless nList_egs Rep_Pred_FOv Indicies Identify.
Require Export pos_SO2 Num_Occ Bool my_bool Is_Pos_Rep_Pred P_occ_rep_pred.
Require Export Uniform_Defns Monotonicity_SO Pre_Sahlqvist_Uniform_Pos P_occ_rep_pred.
Require Export Unary_Predless_l Num_Occ_l2 my_arith__my_leb_nat.

Notation "'existsT' x .. y , p" := (sig (fun x => .. (sig (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'existsT'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Notation "'existsT2' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'existsT2'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Lemma is_un_predless_rep_pred_l_pre : forall
                          (l : list predicate)
                          (alpha : SecOrder)
                          (l1: nlist (length l))
                          (l2 : nlist (length l)),
is_unary_predless_l (nlist_list _ l2) = true ->
length (preds_in (replace_pred_l alpha l
                (nlist_list _ l1)
                (nlist_list _ l2))) =  length (preds_in alpha) - num_occ_l2 alpha l.
Proof.
  intros l. induction l; intros alpha l1 l2 Hun.
    simpl in *.
    rewrite num_occ_l2_0.
    rewrite arith_minus_zero.
    reflexivity.

    simpl in *.
    destruct (nlist_cons2 _ l1) as [x [l1' H1]].
    destruct (nlist_cons2 _ l2) as [beta [l2' H2]].
    rewrite H1 in *; rewrite H2 in *.
    simpl in *.
    case_eq (is_unary_predless beta); intros Hun2; rewrite Hun2 in *.
    rewrite preds_in_rep_pred; try assumption.
    rewrite num_occ_l2_cons.
    case_eq (occ_in_l l a); intros Hocc.
      rewrite IHl; try assumption.
      rewrite num_occ__in_l_t; try assumption.
      rewrite arith_minus_zero.
      reflexivity.

      rewrite IHl; try assumption.
      rewrite num_occ__in_l_f; try assumption.
      rewrite arith_plus_comm.
      rewrite arith_minus_exp.
      reflexivity.

    discriminate.
Qed.

Lemma is_un_predless_rep_pred_l : forall (alpha : SecOrder)
                          (l1: nlist (length (preds_in alpha)))
                          (l2 : nlist (length (preds_in alpha))),
is_unary_predless_l (nlist_list _ l2) = true ->
is_unary_predless (replace_pred_l alpha (preds_in alpha)
                (nlist_list _ l1)
                (nlist_list _ l2)) = true.
Proof.
  pose proof is_un_predless_rep_pred_l_pre as H2.
  intros alpha l1 l2 H.
  specialize (H2 (preds_in alpha) alpha l1 l2 H).
  rewrite num_occ_l2_preds_in in H2.
  rewrite arith_minus_refl in H2.
  apply un_predless_preds_in2 in H2.
  assumption.
Qed.

Lemma Ip_ext_pa_f : forall (W : Set)
                    (Ip : predicate -> W -> Prop)
                    (P : predicate)
                    (pa : W -> Prop),
  Ip_extends W (alt_Ip Ip pa_f P) (alt_Ip Ip pa P) P.
Proof.
  intros W Ip P pa.
  unfold Ip_extends.
  apply conj.
    intros w H.
    unfold pa_f in *.
    destruct P.
    simpl in *.
    rewrite <- beq_nat_refl in *.
    contradiction.

    intros Q.
    destruct P as [Pn]; destruct Q as [Qm].
    intros H.
    unfold not in *.
    unfold pa_f.
    simpl.
    case_eq (beq_nat Pn Qm); intros Hbeq.
      specialize (H (beq_nat_true _ _ Hbeq)).
      contradiction.

      reflexivity.
Qed.

Lemma mono1 : forall (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder) (P : predicate)
                    (pa : W -> Prop),
  P_is_pos_SO alpha P ->
  SOturnst W Iv (alt_Ip Ip pa_f P) Ir alpha ->
  SOturnst W Iv (alt_Ip Ip pa P) Ir alpha.
Proof.
  intros W Iv Ip Ir alpha P pa Hpos Hf.
  pose proof monotonicity_SO as H.
  unfold alpha_upward_monotone_P in H.
  pose proof (P_is_pos_occ _ _ Hpos) as H2.
  specialize (H alpha P H2).
  destruct H as [Ha Hb].
  apply Ha with (Ip := (alt_Ip Ip pa_f P));
  try assumption.
  apply Ip_ext_pa_f.
Qed.

Lemma step1_empty : forall (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder) (P : predicate),
  SOQFree alpha = true ->
  P_is_pos_SO alpha P ->
  SOturnst W Iv Ip Ir (replace_pred alpha P (Var 1)
                          (negSO (eqFO (Var 1) (Var 1)))) ->
    forall pa : W -> Prop,
      SOturnst W Iv (alt_Ip Ip pa P) Ir alpha.
Proof.
  intros W Iv Ip Ir alpha P SOQFree Hpos SOt pa.
  apply rep_pred_false_pa_f in SOt; try assumption.
  apply mono1; assumption.
Qed.

Lemma step2_empty : forall (l : list predicate)
                    (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder),
  SOQFree alpha = true ->
  uniform_pos_SO alpha ->
    (SOturnst W Iv Ip Ir (replace_pred_l alpha l
          (nlist_list _ (nlist_Var1 (length l)))
          (nlist_list _ (nlist_empty (length l))))) ->
  forall pa_l : nlist_pa W (length l),
    SOturnst W Iv (alt_Ip_list Ip
     (nlist_list_pa W (length l) pa_l) l) Ir alpha.
Proof.
  induction l;
    intros W Iv Ip Ir alpha Hno Huni SOt pa_l.
    simpl in *.
    rewrite alt_Ip_list_nil.
    apply SOt.

    simpl in pa_l.
    destruct (nlist_cons W (length l) pa_l) as [pa [pa_l' Heq]].
    rewrite Heq in *.
    simpl nlist_list_pa in *.
    simpl alt_Ip_list in *.
    simpl nlist_list in *.
    simpl replace_pred_l in *.
    case_eq (P_occurs_in_alpha alpha a); intros HPocc.
      apply step1_empty; try assumption.
        unfold uniform_pos_SO in Huni.
        apply Huni.
        assumption.

        apply IHl.
          apply SOQFree_rep_pred_empty.
          assumption. (* reflexivity.*)
        apply uni_pos_rep_pred.
          simpl; reflexivity.
          assumption.

        rewrite rep_pred__l_switch_empty.
        apply SOt.

      apply P_not_occ_alt.
        assumption.

        apply IHl; try assumption.

          rewrite P_occ_rep_pred_f in SOt.
            assumption.

            apply P_occ_rep_pred_l_empty;
            assumption.
Qed.

Lemma step3_empty : forall (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder),
  SOQFree alpha = true ->
  uniform_pos_SO alpha ->
    (SOturnst W Iv Ip Ir (replace_pred_l alpha (preds_in alpha)
          (nlist_list _ (nlist_Var1 (length (preds_in alpha))))
          (nlist_list _ (nlist_empty (length (preds_in alpha)))))) ->
  SOturnst W Iv Ip Ir (uni_closed_SO alpha).
Proof.
  intros.
  unfold uni_closed_SO.
  apply nlist_list_closed_SO.
  apply step2_empty; assumption.
Qed.

Lemma Sahlqvist_uniform_pos_pre : forall (phi : Modal) (x : FOvariable),
  uniform_pos phi ->
    exists (alpha : SecOrder),
      (forall (D : Set) (Iv:FOvariable -> D) (Ip: predicate -> D -> Prop)
             (Ir: D -> D -> Prop),
      SOturnst D Iv Ip Ir (uni_closed_SO (allFO x (ST phi x))) <->
        SOturnst D Iv Ip Ir alpha) /\
      is_unary_predless alpha = true.
Proof.
  intros phi x Hun.
  exists (replace_pred_l (allFO x (ST phi x))
          (preds_in (allFO x (ST phi x)))
          (nlist_list _ (nlist_Var1 (length (preds_in (ST phi x)))))
          (nlist_list _ (nlist_empty (length (preds_in (ST phi x)))) )).
  apply conj.
    intros D Iv Ip Ir.
    apply conj.
      apply instant_uni_closed; assumption.

    simpl; intros H.
    apply step3_empty.
      destruct x; simpl.
      apply SOQFree_ST.

      apply uni_pos_SO_allFO.
      apply uni_pos__SO ; assumption.

      apply H.

      rewrite rep_pred_l_allFO.
      destruct x.       simpl.
      apply is_un_predless_rep_pred_l.
      apply un_predless_l_empty.
Defined.

Lemma Sahlqvist_uniform_pos : forall (phi : Modal),
  uniform_pos phi ->
    exists (alpha : SecOrder),
    ((forall (W : Set) (R : W -> W -> Prop) (Iv : FOvariable -> W)
           (Ip : predicate -> W -> Prop),
    mturnst_frame W R phi <-> SOturnst W Iv Ip R alpha) /\
    is_unary_predless alpha = true).
Proof.
  intros phi Hpos.
  apply Sahlqvist_uniform_pos_pre with (x := (Var 1)) in Hpos.
  destruct Hpos as [alpha H].
  exists alpha.
  apply conj.
    intros W R Iv Ip.
    split; intros H2.
      apply H.
      apply correctness_ST; assumption.

      destruct (correctness_ST W R (Var 1) Iv Ip phi) as [fwd rev].
      apply rev.
      apply H.
      assumption.

      apply H.
Defined.

(*
Extraction Language Haskell.
Extraction "Testing_Sahlq_un_pos" Sahlqvist_uniform_pos.
*)

(*
Print Assumptions Sahlqvist_uniform_pos.

Extraction Language Haskell.
Extraction "Test_Sahlq_Uniform2" Sahlqvist_uniform_pos.
Extraction Library Modal.
*)


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinv1rel6 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel6
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 inv1
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold rel6 in |- *.
intros Inv0 Inv1 and1.
elim and1; intros t1 and2; elim and2; intros t2 and3; elim and3;
 intros t3 and4; elim and4; intros eq_l0 t4.
elim eq_l0; assumption.
Qed.


Add LoadPath "..".
Require Import L_Substitution.
Require Import PermutLib.
Require Import LibTactics.
Require Import L_OkLib.
Require Import Relations.

Open Scope is5_scope.
Open Scope labeled_is5_scope.
Open Scope permut_scope.

Global Reserved Notation " Omega ';' Gamma '|-' M ':::' A '@' w " (at level 70).

Inductive types_L: worlds_L -> ctx_L -> te_L -> ty -> var -> Prop :=

| t_hyp_L: forall Omega Gamma v A w
  (Ok: ok_L Omega Gamma)
  (World: Mem w Omega)
  (HT: Mem (w, (v, A)) Gamma),
  Omega; Gamma |- hyp_L (fte v) ::: A @ w

| t_lam_L: forall L Omega Gamma w A B M
  (Ok: ok_L Omega Gamma)
  (HT: forall x, x \notin L ->
    Omega; (w, (x,A))::Gamma |- (M ^t^ (hyp_L (fte x))) ::: B @ w),
  Omega; Gamma |- lam_L A M ::: A ---> B @ w

| t_appl_L: forall Omega Gamma w A B M N
  (Ok: ok_L Omega Gamma)
  (HT1: Omega; Gamma |- M ::: A ---> B @ w)
  (HT2: Omega; Gamma |- N ::: A @ w),
  Omega; Gamma |- appl_L M N ::: B @ w

| t_box_L: forall L Omega Gamma w M A
  (Ok: ok_L Omega Gamma)
  (World: Mem w Omega)
  (HT: forall x, x \notin L ->
    (x :: Omega); Gamma |- (M ^w^ (fwo x)) ::: A @ x),
  Omega; Gamma |- box_L M ::: [*]A @ w

| t_unbox_L: forall Omega Gamma w M A
  (Ok: ok_L Omega Gamma)
  (HT: Omega; Gamma |- M ::: [*]A @ w),
  Omega; Gamma |- unbox_L M ::: A @ w

| t_fetch_L: forall Omega Gamma w w' M A
  (Ok: ok_L Omega Gamma)
  (HT: Omega; Gamma |- M ::: [*]A @ w)
  (Hin: Mem w' Omega),
  Omega; Gamma |- fetch_L (fwo w) M ::: [*]A @ w'

| t_here_L: forall Omega Gamma w M A
  (Ok: ok_L Omega Gamma)
  (HT: Omega; Gamma |- M ::: A @ w),
  Omega; Gamma |- here_L M ::: <*> A @ w

| t_get_L: forall Omega Gamma w w' M A
  (Ok: ok_L Omega Gamma)
  (HT: Omega; Gamma |- M ::: <*>A @ w)
  (Hin: Mem w' Omega),
  Omega; Gamma |- get_L (fwo w) M ::: <*>A @ w'

| t_letd_L: forall Lw Lt Omega Gamma w M N A B
  (Ok: ok_L Omega Gamma)
  (HT1: Omega; Gamma |- M ::: <*>A @ w)
  (HT2: forall t, t \notin Lt -> forall w', w' \notin Lw ->
    w' :: Omega; (w', (t, A)) :: Gamma |-
      ((N ^w^ (fwo w')) ^t^ (hyp_L (fte t)))  ::: B @ w),
  Omega; Gamma |-letd_L M N ::: B @ w

where " Omega ';' Gamma '|-' M ':::' A '@' w " := (types_L Omega Gamma M A w):
  labeled_is5_scope.

Inductive value_L: te_L -> Prop :=
| val_lam_L: forall A M, value_L (lam_L A M)
| val_box_L: forall M, value_L (box_L M)
| val_get_here_L: forall M w (HT: value_L M), value_L (get_L w (here_L M))
.

Global Reserved Notation " M |-> N " (at level 70).

Inductive step_L: te_L * vwo -> te_L * vwo -> Prop :=
| red_appl_lam_L: forall A M N w,
   lc_w_L M -> lc_t_L (M ^t^ N) ->
   lc_w_L N -> lc_t_L N ->
   (appl_L (lam_L A M) N, w) |-> (M ^t^ N, w)
| red_unbox_box_L: forall M w,
   lc_t_L M -> lc_w_L (M ^w^ w) ->
   (unbox_L (box_L M), w) |-> (M ^w^ w, w)
| red_letd_get_here_L: forall M N w w',
   lc_t_L M -> lc_w_L M ->
   lc_t_L (N ^t^ M) -> lc_w_L (N ^w^ w') -> value_L M ->
   (letd_L (get_L w' (here_L M)) N, w) |-> ((N ^w^ w') ^t^ M, w)
| red_appl_L: forall M N M' w (HRed: (M, w) |-> (M', w)),
   lc_t_L M -> lc_w_L M ->
   lc_t_L N -> lc_w_L N ->
   (appl_L M N, w) |-> (appl_L M' N, w)
| red_unbox_L: forall M M' w (HRed: (M, w) |-> (M', w)),
   lc_t_L M -> lc_w_L M ->
   (unbox_L M, w) |-> (unbox_L M', w)
| red_fetch_L: forall M M' w w'  (HRed: (M, w) |-> (M', w)),
   lc_t_L M -> lc_w_L M ->
   (fetch_L w M, w') |-> (fetch_L w M', w')
| red_fetch_val_L: forall w M w' (HVal: value_L M),
   lc_t_L M -> lc_w_L M ->
   (fetch_L w M, w') |-> (M, w')
| red_here_L: forall N N' w (HRed: (N, w) |-> (N',w)),
   lc_t_L N -> lc_w_L N ->
   (here_L N, w) |-> (here_L N', w)
| red_here_val_L: forall M w (HVal: value_L M),
   (here_L M, w) |-> (get_L w (here_L M), w)
| red_letd_L: forall M M' N w (HRed: (M, w) |-> (M', w)),
   lc_t_L M -> lc_w_L M ->
   lc_t_L (N ^t^ M) -> lc_w_L (N ^w^ w) ->
   (letd_L M N, w) |-> (letd_L M' N, w)
| red_get_L: forall w M M' w' (HRed: (M, w) |-> (M', w)),
   lc_t_L M -> lc_w_L M ->
   (get_L w M, w') |-> (get_L w M', w')
| red_get_val_L: forall w M w' w'', value_L (get_L w' M) ->
   (get_L w (get_L w' M), w'') |-> (get_L w' M, w'')
where " M |-> N " := (step_L M N ) : labeled_is5_scope.

Inductive steps_L : te_L -> te_L -> vwo -> Prop :=
| step1_L: forall M N w, step_L (M, w) (N, w) -> steps_L M N w
| stepm_L: forall M M' N w,
             step_L (M, w) (M', w) -> steps_L M' N w ->
             steps_L M N w
.

Lemma WeakeningGamma_L:
forall Omega Gamma M A w Gamma'
  (H: Omega; Gamma |- M ::: A @ w)
  (Ok: ok_L Omega (Gamma ++ Gamma')),
  forall Delta,
    Delta *=* Gamma ++ Gamma' ->
    Omega; Delta |- M ::: A @ w.
intros; generalize dependent Gamma'; generalize dependent Delta;
induction H; intros.
(* hyp *)
constructor;
[ eapply ok_L_permut; [ | symmetry | ] | |
  eapply Mem_permut; [ symmetry | rewrite Mem_app_or_eq; left ]]; eauto.
(* lam *)
apply t_lam_L with (L:=L \u used_vars_context_L (Gamma++Gamma')).
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  intros; apply H with (Gamma':=Gamma'); auto; rew_app;
  [ apply ok_L_extend_fresh | permut_simpl]; auto.
(* appl *)
apply t_appl_L with (A:=A).
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  apply IHtypes_L1 with (Gamma':=Gamma'); auto.
  apply IHtypes_L2 with (Gamma':=Gamma'); auto.
(* box *)
apply t_box_L with (L:=L \u from_list Omega).
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  auto.
  intros; apply H with (Gamma':=Gamma'); auto.
  destruct Ok0; split; auto; simpl; split; [apply notin_Mem | ]; auto.
(* unbox *)
constructor; auto.
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  apply IHtypes_L with (Gamma' := Gamma'); auto.
(* fetch *)
constructor; auto.
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  apply IHtypes_L with (Gamma' := Gamma'); auto.
(* here *)
constructor; auto.
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  apply IHtypes_L with (Gamma' := Gamma'); auto.
(* get *)
constructor; auto.
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  apply IHtypes_L with (Gamma' := Gamma'); auto.
(* letdia *)
apply t_letd_L with (Lt := Lt \u used_vars_context_L (Gamma++Gamma'))
  (Lw := Lw \u from_list Omega) (A := A); auto.
  eapply ok_L_permut; [ | symmetry | ]; eauto.
  apply IHtypes_L with (Gamma' := Gamma'); auto.
  intros; apply H0 with (Gamma' := Gamma'); auto.
  rew_app; apply ok_L_extend_fresh; destruct Ok0.
    split; auto. simpl; split; [apply notin_Mem | ]; auto.
    auto.
  rew_app; permut_simpl; assumption.
Qed.

Lemma WeakeningOmega_L:
forall Omega Gamma M A w w'
  (H: Omega; Gamma |- M ::: A @ w)
  (Ok: ok_L (w'::Omega) Gamma),
  forall Omega',
    Omega' *=* w'::Omega ->
    Omega'; Gamma |- M ::: A @ w.
intros Omega Gamma M A w w' H; generalize dependent w'; induction H; intros.
(* hyp *)
constructor; auto.
eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
eapply Mem_permut; [ symmetry | ]; eauto; rewrite Mem_cons_eq; right; auto.
(* lam *)
apply t_lam_L with (L:=L \u used_vars_context_L Gamma).
eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
intros; eapply H; eauto.
apply ok_L_extend_fresh; destruct Ok0; auto; split; auto.
(* appl *)
apply t_appl_L with (A:=A); eauto.
eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
(* box *)
apply t_box_L with (L:=L \u from_list (w'::Omega)).
eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
eapply Mem_permut; [ symmetry | ]; eauto; rewrite Mem_cons_eq; right; auto.
intros; apply H with (w':=w'); auto.
eapply ok_L_permut with (O:=(x::w'::Omega)); eauto.
permut_simpl.
destruct Ok0; split; auto; simpl. split; auto.
apply notin_Mem; eauto.
permut_simpl; auto.
(* unbox *)
constructor; eauto.
eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
(* fetch *)
constructor; eauto.
eapply ok_L_permut with (O:=w'0::Omega); [symmetry | | ]; eauto.
apply Mem_permut with (l:=w'0::Omega); rew_app;
[ symmetry | rewrite Mem_cons_eq; right]; auto.
(* here *)
constructor; eauto.
eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
(* get *)
constructor; eauto.
eapply ok_L_permut with (O:=w'0::Omega); [symmetry | | ]; eauto.
apply Mem_permut with (l:=w'0::Omega); rew_app;
[ symmetry | rewrite Mem_cons_eq; right]; auto.
(* letd *)
apply t_letd_L with (Lt := Lt \u used_vars_context_L Gamma)
  (Lw := Lw \u from_list (w'::Omega)) (A := A).
  eapply ok_L_permut with (O:=w'::Omega); [symmetry | | ]; eauto.
  apply IHtypes_L with (w' := w'); auto.
  intros; apply H0 with (w' := w'0) (w'0 := w'); auto.
  eapply ok_L_permut with (O:=w'0::w'::Omega).
  permut_simpl. eauto.
  apply ok_L_extend_fresh; destruct Ok0.
    split; auto. simpl; split; [apply notin_Mem | ]; auto.
    auto.
  permut_simpl; assumption.
Qed.

Lemma PermutOmega_L:
forall Omega Gamma M A w Omega',
  Omega; Gamma |- M ::: A @ w ->
  Omega *=* Omega' ->
  Omega'; Gamma |- M ::: A @ w.
intros; generalize dependent Omega'; induction H; intros;
econstructor;
try (eapply ok_L_permut);
try (eapply Mem_permut); eauto.
Qed.

Lemma PermutGamma_L:
forall Omega Gamma M A w Gamma',
  Omega; Gamma |- M ::: A @ w ->
  Gamma *=* Gamma' ->
  Omega; Gamma' |- M ::: A @ w.
intros; generalize dependent Gamma'; induction H; intros;
econstructor;
try (eapply ok_L_permut);
try (eapply Mem_permut); eauto.
Qed.

Lemma subst_t_L_types_preserv:
forall Omega Gamma Gamma0 M A B w w' N x,
  lc_w_L N -> lc_t_L N ->
  Omega; Gamma |- M ::: A @ w ->
  Gamma *=*  (w', (x, B)) :: Gamma0 ->
  Omega; nil |- N ::: B @ w' ->
  forall Gamma', Gamma' *=* Gamma0 ->
  Omega; Gamma' |- [ N // fte x ] M ::: A @ w.
intros.
generalize dependent Gamma0; generalize dependent Gamma'.
induction H1; intros; simpl in *.
(* hyp *)
case_if.
inversion H1; subst.
assert ((w', (x, B)) = (w, (x, A))).
  eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto.
  destruct Ok as (OkO, Ok);
  apply ok_L_Mem_contr with (w':=w) (b:=A) in Ok.
  apply Mem_permut with (l':=(w', (x, B)) :: Gamma0) in HT; auto.
  rewrite Mem_cons_eq in HT; destruct HT.
    symmetry; auto.
    contradiction.
inversion H5; subst; auto.
replace Gamma' with (nil ++ Gamma') by auto;
apply WeakeningGamma_L with (Gamma:=nil) (Gamma':=Gamma'); rew_app; auto;
eapply ok_L_permut with (G:=Gamma0); [ | symmetry | ]; eauto;
eapply ok_L_permut with (G':=(w, (x,A))::Gamma0) in Ok; eauto;
eapply ok_L_smaller_Gamma; eauto.
constructor; auto.
eapply ok_L_permut with (G':=(w', (x, B)) :: Gamma') in Ok; eauto.
apply ok_L_smaller_Gamma in Ok; auto. rewrite H4; auto.
apply Mem_permut with (l':= (w', (x, B)) :: Gamma0) in HT; eauto;
rewrite Mem_cons_eq in HT; destruct HT;
[ inversion H5; subst; elim H1 |
  symmetry in H4; apply Mem_permut with (l:=Gamma0) ]; auto.
(* lam *)
apply t_lam_L with (L:=L \u \{x}).
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
intros; unfold open_t_L in *;
rewrite <- subst_t_comm_L; auto; eapply H1; auto;
rewrite H2; rewrite H4; permut_simpl.
(* appl *)
apply t_appl_L with (A:=A).
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
eapply IHtypes_L1; auto; rewrite H2; rewrite H4; permut_simpl.
eapply IHtypes_L2; auto; rewrite H2; rewrite H4; permut_simpl.
(* box *)
apply t_box_L with (L:=L \u from_list Omega); auto.
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
intros; unfold open_w_L in *.
rewrite subst_order_irrelevant_bound_L; auto;
eapply H1; eauto. eapply WeakeningOmega_L; eauto.
destruct Ok; split; auto; constructor;
[apply notin_Mem |]; auto.
(* unbox *)
constructor.
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
eapply IHtypes_L; eauto.
(* fetch *)
constructor; eauto.
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
(* here *)
constructor; eauto.
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
(* get *)
constructor; eauto.
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H4;
eapply ok_L_permut with (G:=Gamma0); auto.
(* letd *)
apply t_letd_L with (A:=A) (Lt:=Lt \u \{x}) (Lw:=Lw \u from_list Omega).
eapply ok_L_permut with (G':=(w', (x, B))::Gamma0) in Ok; eauto;
apply ok_L_smaller_Gamma in Ok; symmetry in H5;
eapply ok_L_permut with (G:=Gamma0); auto.
eapply IHtypes_L; eauto.
intros; unfold open_t_L in *; unfold open_w_L in *.
rewrite subst_order_irrelevant_bound_L; auto;
rewrite <- subst_t_comm_L; auto; eapply H2; eauto.
eapply WeakeningOmega_L; eauto.
destruct Ok; split; simpl; auto; split; auto;
apply notin_Mem; auto.
rewrite H4; rewrite H5; permut_simpl.
Qed.

Lemma rename_w_L_types_preserv:
forall Omega Omega' Gamma M A w w0 w1 w' Gamma',
  Omega'; Gamma |- M ::: A @ w -> Mem w1 Omega ->
  w0 <> w1 ->
  w0::Omega *=* Omega' ->
  w' = (if eq_var_dec w w0 then w1 else w) ->
  Gamma' = rename_context_L w0 w1 Gamma ->
  Omega; Gamma' |- {{ fwo w1 // fwo w0 }} M ::: A @ w'.
intros;
generalize dependent w';
generalize dependent Gamma';
generalize dependent w1.
generalize dependent Omega;
generalize dependent w0.
induction H; intros; simpl in *.
(* hyp *)
case_if; try subst.
constructor; [eapply ok_L_rename | | ]; eauto.
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
[ | symmetry | ]; auto;
destruct Ok; split; auto; simpl in *; destruct H; auto.
eapply Mem_rename_context_L; repeat case_if; eauto; elim H; eauto.
constructor; [eapply ok_L_rename | | ]; eauto.
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
[ | symmetry | ]; auto;
destruct Ok; split; auto; simpl in *; destruct H3; auto.
apply Mem_permut with (l':=w0::Omega0) in World; [|symmetry]; auto;
rewrite Mem_cons_eq in World; destruct World; subst.
  elim H; auto. auto.
eapply Mem_rename_context_L; repeat case_if; eauto; elim H; eauto.
(* lam *)
econstructor; eauto.
subst.
eapply ok_L_rename; eauto.
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok; try symmetry; auto;
destruct Ok; split; simpl in *; destruct H3; auto.
intros; unfold open_t_L in *; case_if; subst.
replace ((w1, (x, A)) :: rename_context_L w0 w1 Gamma) with
  (rename_context_L w0 w1 ((w0, (x, A)) :: Gamma)) by (simpl; case_if; auto).
rewrite <- subst_order_irrelevant_free_L; simpl; auto.
eapply H; simpl; try case_if; eauto.
replace ((w, (x, A)) :: rename_context_L w0 w1 Gamma) with
  (rename_context_L w0 w1 ((w, (x, A)) :: Gamma)) by (simpl; case_if; auto).
rewrite <- subst_order_irrelevant_free_L; simpl; auto.
eapply H; simpl; try case_if; eauto.
(* appl *)
econstructor; eauto; clear IHtypes_L1 IHtypes_L2.
subst; apply ok_L_rename;
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
destruct Ok. split; simpl in *; destruct H4; auto. symmetry; auto.
auto.
(* box *)
apply t_box_L with (L:=L \u \{w0}); eauto.
subst; apply ok_L_rename;
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok; auto.
destruct Ok. split; simpl in *; destruct H3; auto.
symmetry; auto.
case_if; subst; auto. apply Mem_permut with (l':=w0::Omega0) in World.
rewrite Mem_cons_eq in World. destruct World; subst; [elim H5 | ]; auto.
symmetry; auto.
intros; unfold open_w_L in *.
rewrite <- subst_w_comm_L; eauto.
eapply H; eauto. subst; permut_simpl.
rew_app; auto.
rewrite Mem_cons_eq; right; auto.
repeat case_if; subst; auto; rewrite notin_union in H5; destruct H5;
rewrite notin_singleton in H4; elim H4; auto.
(* unbox *)
constructor.
subst; apply ok_L_rename;
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok; try symmetry; auto;
destruct Ok; split; simpl in *; destruct H3; auto.
eapply IHtypes_L; eauto.
(* fetch *)
repeat case_if; subst; try inversion H5; subst.
constructor; [ | eapply IHtypes_L | ]; repeat case_if; eauto;
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
constructor;
[ | eapply IHtypes_L |
  apply Mem_permut with (l':=w0::Omega0) in Hin];
repeat case_if; eauto.
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
rewrite Mem_cons_eq in Hin; destruct Hin; subst; [elim H6 | ]; auto.
symmetry; auto.
constructor; [ | eapply IHtypes_L | ]; repeat case_if; eauto;
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
constructor;
[ | eapply IHtypes_L |
  apply Mem_permut with (l':=w0::Omega0) in Hin];
repeat case_if; eauto.
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
rewrite Mem_cons_eq in Hin; destruct Hin; subst; [elim H6 | ]; auto.
symmetry; auto.
(* here *)
constructor.
subst; apply ok_L_rename;
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok; try symmetry; auto;
destruct Ok; split; simpl in *; destruct H3; auto.
eapply IHtypes_L; eauto.
(* get *)
repeat case_if; subst; try inversion H5; subst.
constructor; [ | eapply IHtypes_L | ]; repeat case_if; eauto;
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
constructor;
[ | eapply IHtypes_L |
  apply Mem_permut with (l':=w0::Omega0) in Hin];
repeat case_if; eauto.
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
rewrite Mem_cons_eq in Hin; destruct Hin; subst; [elim H6 | ]; auto.
symmetry; auto.
constructor; [ | eapply IHtypes_L | ]; repeat case_if; eauto;
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
constructor;
[ | eapply IHtypes_L |
  apply Mem_permut with (l':=w0::Omega0) in Hin];
repeat case_if; eauto.
apply ok_L_rename; apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
rewrite Mem_cons_eq in Hin; destruct Hin; subst; [elim H6 | ]; auto.
symmetry; auto.
(* letd *)
apply t_letd_L with (A:=A) (Lt:=Lt) (Lw:=Lw \u \{w0}).
subst; apply ok_L_rename;
apply ok_L_permut with (O':=w0::Omega0) (G':=Gamma) in Ok;
try symmetry; auto; destruct Ok as (OkA, OkB); split; simpl in *;
destruct OkA; auto.
eapply IHtypes_L; eauto.
unfold open_w_L in *; unfold open_t_L in *.
case_if; subst; intros;
replace ((w', (t, A)) :: rename_context_L w0 w1 Gamma) with
  (rename_context_L w0 w1 ((w', (t, A)) :: Gamma)) by
( simpl; rewrite notin_union in H5; destruct H5 as (H5a, H5b);
  rewrite notin_singleton in H5b; case_if; auto);
rewrite <- subst_w_comm_L; auto;
rewrite <- subst_order_irrelevant_free_L; simpl; auto;
eapply H0; try rewrite <- H2; try case_if; eauto; try permut_simpl;
rewrite Mem_cons_eq; right; auto.
Qed.

Lemma types_w_in_Omega_L:
forall Omega Gamma M A w,
  Omega; Gamma |- M ::: A @ w ->
  Mem w Omega.
intros; induction H; auto.
assert (exists x, x \notin L) by apply Fresh;
destruct H0 as (x, H0); specialize H with x;
apply H; auto.
Qed.

Lemma rename_w_types_preserv_in_new_L:
forall Omega Gamma M A w0 w1,
  w1::Omega; Gamma |- M ::: A @ w0 -> w0 <> w1 ->
  Omega; (rename_context_L w1 w0 Gamma) |- {{ fwo w0 // fwo w1 }} M ::: A @ w0.
intros; eapply rename_w_L_types_preserv with (w:=w0); eauto.
apply types_w_in_Omega_L in H; rewrite Mem_cons_eq in H; destruct H; subst;
[ elim H0 | ]; auto.
case_if; auto.
Qed.

Lemma rename_w_types_preserv_in_outer_L:
forall Omega Gamma M A w0 w1 w2,
  w1::Omega; Gamma |- M ::: A @ w2 -> w0 <> w1 -> w0 <> w2 -> w1 <> w2 ->
  Mem w0 Omega ->
  Omega; (rename_context_L w1 w0 Gamma) |- {{ fwo w0 // fwo w1 }} M ::: A @ w2.
intros; eapply rename_w_L_types_preserv; eauto.
case_if; auto.
Qed.

Lemma types_L_Mem_Omega:
forall M Omega Gamma A w,
  Omega; Gamma |- M ::: A @ w ->
  Mem w Omega.
intros; induction H; eauto;
assert (exists x, x \notin L) as H0 by apply Fresh; destruct H0 as (x);
apply H with (x:=x); auto.
Qed.

Lemma ProgressL:
forall Omega M A w
  (H_lc: lc_w_L M)
  (H_lc': lc_t_L M)
  (HProgress: Omega; nil |- M ::: A@w),
  value_L M \/ exists N, (M, fwo w) |-> (N, fwo w).
induction M; intros; eauto using value_L; inversion HProgress; subst.
(* hyp *)
rewrite Mem_nil_eq in HT; contradiction.
(* lam *)
right; inversion H_lc; inversion H_lc'; subst;
destruct (IHM1 (A0 ---> A) w H2 H7 HT1).
  inversion H; subst; inversion HT1; subst.
  inversion H2; inversion H7; subst;
  eexists; constructor; eauto. apply lc_t_subst_L; auto.
  destruct H; eexists; constructor; eauto.
(* unbox *)
right; inversion H_lc; inversion H_lc'; subst.
destruct (IHM ([*]A) w H1 H4 HT).
  inversion H; subst; inversion HT; subst.
  inversion H1; inversion H4; subst; eexists; constructor; eauto.
  apply lc_w_subst_L; auto.
  destruct H; eexists; constructor; eauto.
(* get *)
inversion H_lc; inversion H_lc'; subst.
destruct (IHM (<*>A0) w0 H1 H5 HT).
  inversion H; subst; inversion HT; subst.
  right; exists (get_L (fwo w2) (here_L M0)); apply red_get_val_L; eauto.
  destruct H as (N); right; eexists; constructor; eauto.
(* letd *)
right; inversion H_lc; inversion H_lc'; subst.
destruct (IHM1 (<*>A0) w H3 H8 HT1).
  inversion H; subst; inversion HT1; subst.
  inversion H; subst.
  inversion H8; inversion H3; subst;
  inversion H10; inversion H4; subst;
  eexists; constructor; eauto.
  apply lc_t_subst_L; auto.
  apply lc_w_subst_L; auto.
  destruct H; eexists; constructor; eauto.
  apply lc_t_subst_L; auto.
  apply lc_w_subst_L; auto.
(* here *)
inversion H_lc; inversion H_lc'; subst.
destruct (IHM A0 w H1 H4 HT).
  right; exists (get_L (fwo w) (here_L M)); constructor; auto.
  right; destruct H; eexists; constructor; eauto.
(* fetch *)
right; inversion H_lc; inversion H_lc'; subst.
destruct (IHM ([*]A0) w0 H1 H5 HT).
  inversion H; subst; inversion HT; subst.
    inversion H1; inversion H5; subst.
    eexists; apply red_fetch_val_L; eauto.
  destruct H; eexists; constructor; eauto.
Qed.

Lemma PreservationL:
forall Omega M N A w w'
  (HType: Omega; nil |- M ::: A@w)
  (HStep: (M, fwo w) |-> (N,fwo w')),
  Omega; nil |- N ::: A@w'.
intros; remember (@nil (prod var (prod var ty))) as Gamma;
generalize dependent N; generalize dependent w';
induction HType; intros; inversion HStep; subst; eauto using types_L.
(* red_appl_lam *)
inversion HType1; subst; unfold open_t_L in *.
assert (exists x, x \notin L \u used_vars_term_L M0 \u \{w'}) as HF
  by apply Fresh.
destruct HF as (v_f).
replace ([N // bte 0] M0) with ([N // fte v_f] ([hyp_L (fte v_f) // bte 0] M0)).
eapply subst_t_L_types_preserv with (B:=A); eauto.
rewrite <- subst_t_neutral_free_L with (n:=0); auto.
(* red_unbox_box *)
inversion HType; subst; unfold open_w_L in *;
assert (exists x, x \notin L \u used_worlds_term_L M0 \u \{w'}) as HF
  by apply Fresh;
destruct HF as (w_f).
replace ({{fwo w'//bwo 0}}M0) with ({{fwo w'//fwo w_f}}{{fwo w_f//bwo 0}}M0).
replace (@nil (prod var (prod var ty))) with (rename_context_L w_f w' nil) by
  (simpl; auto).
eapply rename_w_L_types_preserv; auto. case_if; auto.
rewrite <- subst_w_neutral_free_L; auto.
(* red_fetch_val *)
inversion HVal; subst; [inversion HType | | inversion HType].
inversion HType; subst; econstructor; eauto.
(* red_get_here *)
destruct Ok; repeat constructor; auto;
apply types_L_Mem_Omega in HType; auto.
(* red_get_val *)
inversion HType; subst; constructor; auto.
(* red_letd_here *)
clear H.
inversion HType; subst; unfold open_w_L in *; unfold open_t_L in *;
assert (exists x, x \notin Lt \u used_vars_term_L {{fwo w // bwo 0}}N)
  as HF by apply Fresh;
destruct HF as (v_f);
assert (exists x, x \notin Lw \u
                    used_worlds_term_L [hyp_L (fte v_f) // bte 0]N
                           \u \{w} \u \{w'})
  as HF by apply Fresh;
destruct HF as (w_f).
replace ([M0 // bte 0] ({{fwo w // bwo 0}}N)) with
  ([M0 // fte v_f] ([hyp_L (fte v_f) // bte 0] ({{fwo w// bwo 0}} N))) by
  (rewrite <- subst_t_neutral_free_L; auto);
apply subst_t_L_types_preserv with (Gamma:=(w, (v_f, A)) :: nil)
                                     (Gamma0:=nil) (w':=w)
                                                (B:=A); eauto.
rewrite <- subst_order_irrelevant_bound_L; [ | constructor];
replace ( {{fwo w // bwo 0}}([hyp_L (fte v_f) // bte 0]N)) with
  ({{fwo w // fwo w_f}} ({{fwo w_f // bwo 0}} ([hyp_L (fte v_f) // bte 0] N)))
  by (rewrite <- subst_w_neutral_free_L; auto).
replace ((w, (v_f, A)) :: nil)
  with (rename_context_L  w_f w ((w_f, (v_f, A))::nil)) by
( simpl; repeat rewrite notin_union in H0; rewrite notin_singleton in H0;
  repeat destruct H0 as (H0a, (H0b, H0c)); case_if; auto).
destruct (eq_var_dec w w'); subst.
(* w = w' *)
eapply rename_w_types_preserv_in_new_L.
rewrite subst_order_irrelevant_bound_L; auto.
constructor.
repeat rewrite notin_used in H0; intro; repeat rewrite notin_union in H0; subst;
destruct H0; destruct H1; rewrite notin_singleton in H2; elim H2; auto.
(* <> *)
eapply rename_w_types_preserv_in_outer_L.
rewrite subst_order_irrelevant_bound_L; auto.
constructor.
repeat rewrite notin_union in H0; destruct H0; destruct H1;
rewrite notin_singleton in H2; intro; elim H2; subst; auto.
auto.
repeat rewrite notin_union in H0; destruct H0; destruct H1; destruct H2;
rewrite notin_singleton in H3; auto.
apply types_L_Mem_Omega in HT; auto.
inversion HT; auto.
Qed.

Lemma lc_t_step_L_preserv:
forall M N w,
  lc_t_L M ->
  step_L (M, w) (N, w) ->
  lc_t_L N.
induction M; intros; inversion H0; subst; auto;
unfold open_t_L in *; unfold open_w_L in *.
constructor; [eapply IHM1 |]; eauto.
apply lc_t_n_L_subst_w; auto.
constructor; eapply IHM; eauto.
constructor; eapply IHM; eauto.
inversion H; subst; inversion H4; subst; constructor; auto.
inversion H; subst; inversion H10; subst.
apply lc_t_subst_L; auto;
apply lc_t_n_L_subst_w; auto.
inversion H; subst; constructor; auto.
apply IHM1 with w; auto.
inversion H; subst; constructor; auto.
apply IHM with w; auto.
inversion H; subst; constructor; auto.
inversion H; subst; constructor; auto.
apply IHM with v; auto.
Qed.

Lemma lc_w_step_L_preserv:
forall M N w,
  lc_w_L M ->
  step_L (M, fwo w) (N, fwo w) ->
  lc_w_L N.
induction M; intros; inversion H0; subst; auto;
unfold open_t_L in *; unfold open_w_L in *; simpl in *.
eapply lc_w_n_L_subst_t; auto.
constructor; [eapply IHM1 |]; eauto.
constructor; eapply IHM; eauto.
destruct v; [inversion H; subst; omega | constructor; eapply IHM; eauto].
inversion H; subst; try omega; auto.
inversion H; subst; try omega;
apply lc_w_n_L_subst_t; auto;
apply lc_w_n_L_subst_w; auto.
constructor; inversion H; subst; auto; eapply IHM1; eauto.
constructor; eapply IHM; eauto.
constructor; auto.
destruct v; [inversion H; subst; omega | constructor; eapply IHM; eauto].
Qed.

Lemma lc_t_steps_L_preserv:
forall M N w,
  lc_t_L M ->
  steps_L M N w ->
  lc_t_L N.
intros; induction H0.
apply lc_t_step_L_preserv with (M:=M) (w:=w); auto.
apply IHsteps_L;
apply lc_t_step_L_preserv with (M:=M) (w:=w); auto.
Qed.

Lemma lc_w_steps_L_preserv:
forall M N w,
  lc_w_L M ->
  steps_L M N (fwo w) ->
  lc_w_L N.
intros. remember (fwo w) as w'; generalize dependent w.
induction H0; intros; subst.
apply lc_w_step_L_preserv with (M:=M) (w:=w0); auto.
apply IHsteps_L with (w:=w0); auto;
apply lc_w_step_L_preserv with (M:=M) (w:=w0); auto.
Qed.

Lemma steps_L_appl_L:
forall M M' N w,
  lc_t_L M -> lc_t_L N -> lc_w_L M -> lc_w_L N ->
  steps_L M M' (fwo w) ->
  steps_L (appl_L M N) (appl_L M' N) (fwo w).
intros. remember (fwo w) as w'. generalize dependent w.
induction H3; intros;
[constructor; constructor; auto | ];
apply stepm_L with (M':=appl_L M' N);
[constructor; auto | eapply IHsteps_L]; eauto.
apply lc_t_step_L_preserv with (M:=M) (w:= w); eauto.
apply lc_w_step_L_preserv with (M:=M) (w:=w0); subst; eauto.
Qed.

Lemma steps_L_unbox_L_fetch_L:
forall M M' w v,
  lc_t_L M -> lc_w_L M ->
  steps_L M M' (fwo v) ->
  steps_L (unbox_L (fetch_L (fwo v) M)) (unbox_L (fetch_L (fwo v) M')) w.
intros; remember (fwo v) as v'; generalize dependent v.
induction H1; intros; subst.
repeat constructor; auto.
apply stepm_L with (M':=unbox_L (fetch_L (fwo v) M'));
[repeat constructor | eapply IHsteps_L ]; auto.
apply lc_t_step_L_preserv with (M:=M) (w:= fwo v); eauto.
apply lc_w_step_L_preserv with (M:=M) (w:=v); subst; eauto.
Qed.

Lemma steps_L_get_L_here_L:
forall M M' w v,
  lc_t_L M -> lc_w_L M ->
  steps_L M M' (fwo v) ->
  steps_L (get_L (fwo v) (here_L M)) (get_L (fwo v) (here_L M')) w.
intros; remember (fwo v) as v'; generalize dependent v.
induction H1; intros; subst.
repeat constructor; auto.
apply stepm_L with (M':=get_L (fwo v) (here_L M'));
[repeat constructor | eapply IHsteps_L ]; auto.
apply lc_t_step_L_preserv with (M:=M) (w:= fwo v); eauto.
apply lc_w_step_L_preserv with (M:=M) (w:=v); subst; eauto.
Qed.

Lemma steps_L_letd_L_get_L:
forall M M' N w v,
  lc_t_L M -> lc_t_n_L 1 N -> lc_w_L M -> lc_w_n_L 1 N ->
  steps_L M M' (fwo v) ->
  steps_L (letd_L (get_L (fwo v) M) N)
          (letd_L (get_L (fwo v) M') N) (fwo w).
intros; remember (fwo v) as v'; generalize dependent v.
remember (fwo w) as w'; generalize dependent w.
induction H3; intros; subst.
repeat constructor; unfold open_t_L; unfold open_w_L; auto;
[ apply lc_t_subst_L; try constructor | apply lc_w_subst_L]; auto.
apply stepm_L with (M':=letd_L (get_L (fwo v) M') N);
[repeat constructor; unfold open_t_L; unfold open_w_L; auto;
[ apply lc_t_subst_L; try constructor | apply lc_w_subst_L]
| eapply IHsteps_L ]; auto.
apply lc_t_step_L_preserv with (M:=M) (w:= fwo v); eauto.
apply lc_w_step_L_preserv with (M:=M) (w:=v); subst; eauto.
Qed.