Add LoadPath "src".
Require Import Maps.
Require Import Context.

Import Context.Context.
Require Import Coq.Lists.List.
Require Import LibTactics.
Require Import SmallCore.
Require Import Coq.ZArith.ZArith.
Require Import SmallCorePropSubty.
Require Import SmallCoreStep.
Require Import SmallCoreORFU.

Import SmallCore.SmallCore.
Import SmallCoreORFU.SmallCoreORFU.
Import SmallCoreStep.SmallCoreStep.
Import SmallCorePropSubty.SmallCorePropSubty.
Import Context.Context.

Module SmallCoreTyping.

Fixpoint extty_to_ty (extty : Extty) : ty.
    destruct extty.
    exact (TVar t).
    exact (TFun (TVar t) (extty_to_ty extty)).
    exact (TSum (extty_to_ty extty1) (extty_to_ty extty2)).
Defined.

Print extty_to_ty.

Theorem extty_orfu:
    forall T,
        orfu (extty_to_ty T).

    induction T; intros; simpl in *; eauto.
Qed.

Inductive has_type : Context (type := {x : ty | wf_ty x}) -> tm -> ty -> Prop :=
| ht_none :
    forall ctx,
        has_type ctx tnone TNone
| ht_rcd :
    forall ctx i t0 t1 T T',
        has_type ctx t0 T ->
        has_type ctx t1 T' ->
        orfu T' ->
        only_rcd T' ->
        rcd_field_ty' T' i = None ->
        has_type ctx (trcons i t0 t1) (TRcons i T T')
| ht_var: forall ctx T i (h: wf_ty T),
    byContext ctx i = Some (exist _ T h) ->
    orfu T ->
    has_type ctx (tvar i) T
| ht_fun : forall ctx i T body TO (h: wf_ty T),
    has_type (update i (exist _ T h) ctx) body TO ->
    orfu T ->
    has_type ctx (tfun i T h body) (TFun T TO)
| ht_app : forall ctx t0 t1 T0 T1,
    has_type ctx t0 (TFun T0 T1) ->
    has_type ctx t1 T0 ->
    has_type ctx (tapp t0 t1) T1
| ht_let : forall ctx i T bind body T' (h: wf_ty T),
    has_type ctx bind T ->
    has_type (update i (exist _ T h) ctx) body T' ->
    has_type ctx (tlet i T h bind body) T'
| ht_fix : forall ctx i body T (h:wf_ty T),
    has_type (update i (exist _ T h) ctx) body T ->
    has_type ctx (tfixApp i T h body) T
| ht_left : forall ctx t0 TL TR (h: wf_ty TR),
    has_type ctx t0 TL ->
    orfu TR ->
    has_type ctx (tleft t0 TR h) (TSum TL TR)
| ht_right : forall ctx t0 TL TR (h: wf_ty TL),
    has_type ctx t0 TR ->
    orfu TL ->
    has_type ctx (tright TL h t0) (TSum TL TR)
| ht_case : forall ctx crit tl tr TL TR TO,
    has_type ctx crit (TSum TL TR) ->
    has_type ctx tl (TFun TL TO) ->
    has_type ctx tr (TFun TR TO) ->
    has_type ctx (tcase crit tl tr) TO
| ht_field : forall ctx i T0 T (h0: only_rcd T0) (h1: wf_ty T0),
    rcd_field_ty T0 h0 h1 i = Some T ->
    orfu T0 ->
    orfu T ->
    has_type ctx (tfield T0 h0 h1 i) (TFun T0 T)
| ht_ext : forall ctx T t h,
    has_type ctx (text T t h) (extty_to_ty T)
| ht_subty: forall ctx t T0 T1,
    has_type ctx t T0 ->
    subty T0 T1 ->
    orfu T0 ->
    orfu T1 ->
    T0 <> T1 ->
    has_type ctx t T1.

Hint Constructors has_type.

Inductive free_occur_in : id -> tm -> Prop :=
    | fo_rcons0 : forall i j t0 t1,
                free_occur_in i t0 ->
                free_occur_in i (trcons j t0 t1)
    | fo_rcons1 : forall i j t0 t1,
                free_occur_in i t1 ->
                free_occur_in i (trcons j t0 t1)
    | fo_var : forall i,
                free_occur_in i (tvar i)

    | fo_fun : forall i j T h body,
                i <> j ->
                free_occur_in i body ->
                free_occur_in i (tfun j T h body)
    | fo_app0 : forall i t0 t1,
                free_occur_in i t0 ->
                free_occur_in i (tapp t0 t1)
    | fo_app1 : forall i t0 t1,
                free_occur_in i t1 ->
                free_occur_in i (tapp t0 t1)
    | fo_let0 : forall i j T h t0 t1,
                free_occur_in i t0 ->
                free_occur_in i (tlet j T h t0 t1)
    | fo_let1 : forall i j T h t0 t1,
                i <> j ->
                free_occur_in i t1 ->
                free_occur_in i (tlet j T h t0 t1)
    | fo_fixApp : forall i j T h t0,
                i <> j ->
                free_occur_in i t0 ->
                free_occur_in i (tfixApp j T h t0)
    | fo_left : forall i t0 T h,
                free_occur_in i t0 ->
                free_occur_in i (tleft t0 T h)
    | fo_right: forall i t0 T h,
                free_occur_in i t0 ->
                free_occur_in i (tright T h t0)
    | fo_case0: forall i t0 t1 t2,
                free_occur_in i t0 ->
                free_occur_in i (tcase t0 t1 t2)
    | fo_case1: forall i t0 t1 t2,
                free_occur_in i t1 ->
                free_occur_in i (tcase t0 t1 t2)
    | fo_case2: forall i t0 t1 t2,
                free_occur_in i t2 ->
                free_occur_in i (tcase t0 t1 t2).

Hint Constructors free_occur_in.

(*Lemma closed_no_free_occur:
    forall t T,
        has_type empty t T ->
        forall i, ~ free_occur_in i t.
    intros t T h0.
    remember empty as ctx0.
    glize Heqctx0 0.
    induction h0; intros; subst; intro;
    repeat (
        match goal with
        | h : ?x = ?x -> _ |- _ => poses' (h eq_refl); clear h
        end
    );
    try (
    repeat (
        match goal with
        | h : forall _ : id, _ |- _ => poses' (h i); glize h 0
        end);
    intros;
    try match goal with
    | h1 : free_occur_in _ _ |- _ => inversion h1; subst; eauto; fail
    | h1 : free_occur_in _ _ |- _ => inversion h1; subst;
        match goal with
        | h2 : free_occur_in ?ii ?t, h3: forall _:id, ~free_occur_in _ ?t |- _ =>
            poses' (h3 ii); eauto
        end; fail
    end;
    fail
    ).

    (* case tvar *)
    cbn in H. inversion H.
    (* case tfun *)
    inversion H; subst; eauto.
    Abort.
    *)
Definition relative_ctx_eq (t : tm) (ctx0 ctx1: Context) :=
    (forall i, free_occur_in i t ->
                byContext (type := {x : ty | wf_ty x}) ctx0 i = byContext ctx1 i).

Theorem rce_refl:
    forall t x,
    relative_ctx_eq t x x.
    unfold relative_ctx_eq.
    eauto.
Qed.

Theorem rce_symm:
    forall t x y,
        relative_ctx_eq t x y ->
        relative_ctx_eq t y x.
    unfold relative_ctx_eq.
    intros; eauto. symmetry. eauto.
Qed.

Theorem rce_trans:
    forall t x y z,
        relative_ctx_eq t x y ->
        relative_ctx_eq t y z ->
        relative_ctx_eq t x z.
    unfold relative_ctx_eq.
    intros. poses' (H _ H1); poses' (H0 _ H1).
    rewrite H2; rewrite H3.
    auto.
Qed.

Hint Unfold relative_ctx_eq.

Theorem ctx_change:
    forall ctx0 ctx1 t T,
    has_type ctx0 t T ->
    relative_ctx_eq t ctx0 ctx1 ->
    has_type ctx1 t T.

    intros ctx0 ctx1 t T h0. glize ctx1 0.
    unfold relative_ctx_eq.
    induction h0; intros; subst; eauto;
    try(
    repeat (
        match goal with
        | h1: forall _: Context, _ |- _ => poses' (h1 ctx1); glize h1 0
        end
    );
    intros;
    repeat (
        match goal with
        | h0 :  _ -> has_type _ _ _ |- _ => forwards: h0; glize h0 0
        end
    );
    intros;
    eauto;
    fail).

    (* case tvar*)
    forwards: H1; eauto.
    pattern (byContext ctx i) in H.
    rewrite H2 in H. eauto.

    (* case tfun*)
    eapply ht_fun.
    eapply IHh0.
    intros. cbn. destruct (eq_id_dec i0 i); subst; eauto.
    eauto.

    (* case tlet*)
    eapply ht_let. eapply IHh0_1.
    intros. eauto.
    eapply IHh0_2. intros; eauto.
    cbn. destruct (eq_id_dec i0 i); subst; eauto.

    (* case tfix *)
    eapply ht_fix. eapply IHh0. intros; cbn.
    destruct (eq_id_dec i0 i); subst; eauto.
Qed.

Lemma ctx_typed_fv_exists:
    forall ctx t T,
        has_type ctx t T ->
        (forall i, free_occur_in i t -> exists h, byContext ctx i = Some h).

    intros ctx t T h0.
    induction h0 ; subst; eauto; intros;
    try (
        match goal with
        | h: free_occur_in _ _ |- _ =>
            inversion h; subst; eauto; fail
        end
    );
    try (
        (* Eliminate all cases that depends inductibly and no special cases *)
    match goal with
    | h : free_occur_in ?ii (_ _) |- _ =>
            inversion h; subst; eauto;

                match goal with
                | h : forall _:id, _ , h0 : free_occur_in ?ii _ |- _ -> _ =>
                        destruct (h ii h0); glize h 0
                end
    end;
    intros; eauto
    ).

    (* case tfun *)
    inversion H0; subst; eauto.
    destruct (IHh0 i0 H6); subst; eauto.
    cbn in *. destruct (eq_id_dec i0 i); subst; eauto; try contradiction.

    (* case tlet *)
    inversion H; subst; eauto.
    destruct (IHh0_2 i0 H6); subst; eauto.
    (* destruct (IHh0_2 i0 H6); subst; eauto. *)
    cbn in *; subst; eauto. destruct (eq_id_dec i0 i); subst; eauto; try contradiction.

    (* case tfix*)
    inversion H; subst; eauto. destruct (IHh0 i0 H5); subst; eauto.
    cbn in *; subst; eauto. destruct (eq_id_dec i0 i); subst; eauto; try contradiction.

Qed.

Theorem typed_closed :
    forall t T,
        has_type empty t T ->
        (forall i, ~ free_occur_in i t).

    intros t T h0. remember empty as ctx0.
    glize Heqctx0 0.
    induction h0; intros; subst; intro;
    repeat (
        match goal with
        | h : ?x = ?x -> _ |- _ => poses' (h eq_refl); clear h
        end
    );
    try (
        match goal with
        | h : free_occur_in _ _ |- _ =>
            inversion h; subst; eauto;
            match goal with
            | h0 : free_occur_in ?ii ?tt, h1 : forall _:id, ~ free_occur_in _ ?tt |- _ =>
                destruct (h1 ii h0)
            end
        end; fail
    ).

    (* case tvar *)
    inversion H.
    (* case tfun*)
    inversion H0; subst; eauto.
    destruct
    (ctx_typed_fv_exists
    (update i (exist wf_ty T h) empty)
    body TO h0 i0 H6).
    cbn in *. destruct (eq_id_dec i0 i); subst; eauto; try contradiction.
    try discriminate.

    (* case tlet *)
    inversion H; subst; eauto.
    destruct (H0 _ H3).
    destruct
    (ctx_typed_fv_exists
    (update i (exist (fun x => wf_ty x) T h) empty)
    body T' h0_2 i0 H7
    ).
    cbn in H1. destruct (eq_id_dec i0 i); subst; eauto; try contradiction.
    inversion H1.

    (* case tfix *)
    inversion H; subst; eauto.
    destruct
    (ctx_typed_fv_exists
    (update i (exist wf_ty T h) empty)
    body T h0 i0 H5
    ).
    cbn in H0. destruct (eq_id_dec i0 i); subst; eauto; try contradiction.
    inversion H0.
Qed.

Theorem typed_relative_closed:
    forall t T,
        has_type empty t T ->
        forall ctx,
            relative_ctx_eq t ctx empty.
    intros t T h0.
    poses' (typed_closed t T h0).
    unfold relative_ctx_eq.
    intros. destruct (H _ H0).
Qed.

Theorem ctx_eq_rewrite:
    forall U V t T,
        has_type U t T ->
        CtxEq U V ->
        has_type V t T.
    intros U V t T h0;
    glize V 0.
    induction h0; subst; eauto.
    intros. poses' (CtxEq_byCtxEq _ _ H1).
    eapply ht_var. rewrite <- H2. eauto. eauto.
Qed.

Lemma empty_typed_ctx_typed:
    forall t T,
        has_type empty t T ->
        forall ctx,
            has_type ctx t T.

    intros t T h0 ctx.
    poses' (typed_relative_closed _ _ h0 ctx) .
    eapply ctx_change; eauto.
    eapply rce_symm; eauto.
Qed.

Ltac forwardALL :=
    repeat (
        match goal with
        | h0 : _ -> _ |- _ =>
            forwards*: h0; generalize dependent h0
        end
    ); intros.

Lemma Extty_well_formed:
    forall T,
        wf_ty (extty_to_ty T).
    induction T; intros; simpl in *; eauto; subst.
Qed.

Theorem has_type_orfu:
    forall ctx t T,
        has_type ctx t T ->
        orfu T.

    intros ctx t T h.
    induction h; intros; try intro; subst;
    try match goal with
        | h : only_rcd _ |- _ => inversion h; subst; eauto; try discriminate; try contradiction; fail
    end;
    try match goal with
    | h : orfu (_ _) |- _ => inversion h; subst; eauto; try discriminate; try contradiction; fail
    end;
    eauto.
    (* case extty_to_ty *)
    eapply extty_orfu.
Qed.

Theorem has_type_well_formed:
    forall ctx t T,
        has_type ctx t T ->
        wf_ty T.
    intros t T ctx h.

    induction h; try (intros; subst; eauto 10; fail); intros; subst;
    try (
        match goal with
        | h: wf_ty (_ _ ) |- _ => inversion h; subst; eauto
        end; fail
    ).

    unfold rcd_field_ty in *.
    eapply wfFun; eauto.
    eapply rcd_field_ty'_wf_is_wf; eauto.
    (* case EXTTY *)
    eapply Extty_well_formed.
    cut (wf_ty T0 /\ wf_ty T1); try tauto; eauto.
    eapply subty_wf; eauto.
Qed.

Lemma value_has_type_inver_tnone0:
    forall T,
        has_type empty tnone T ->
        T = TNone.
    intros T h.
    remember empty as ctx.
    remember tnone as t.
    glize Heqctx Heqt 0.
    induction h; intros; subst; eauto; try discriminate.
    forwards*:IHh; subst.
    eapply subty_onlyrefl_tnone0; eauto.
Qed.

Lemma value_has_type_inver_trcons0:
    forall i t0 t1 T,
        has_type empty (trcons i t0 t1) T ->
        only_rcd T.
    intros i t0 t1 T h.
    remember empty as ctx.
    remember (trcons i t0 t1) as t.
    glize i t0 t1 Heqctx 0.
    induction h; intros; subst; eauto; try discriminate.
    forwards: IHh; eauto.
    eapply subty_rcd1; eauto.
Qed.

Lemma value_has_type_inver_tsum0:
    forall ctx lt RT w T,
        has_type ctx (tleft lt RT w) T ->
        exists TL TR,
            T = TSum TL TR /\ has_type ctx lt TL.

    intros ctx lt RT w T h0.
    remember (tleft lt RT w) as t.
    glize lt RT 0.
    induction h0; intros;subst; eauto;
    try discriminate; try contradiction. inversion Heqt; subst; eauto.
    forwards :IHh0; subst; eauto.
    destructALL; subst; eauto.
    forwards: subty_extrac_tsum0; eauto; subst. destructALL; subst; eauto.
    inversion H0; inversion H1; subst; eauto.
    forwards: subty_extra_tsum; eauto; destructALL; subst.
    repeat eexists.
    destruct (eq_ty_dec x x1); subst; eauto.
Qed.

Lemma value_has_type_inver_tsum1:
    forall ctx LT w rt T,
        has_type ctx (tright LT w rt) T ->
        exists TL TR,
            T = TSum TL TR /\ has_type ctx rt TR.

    intros ctx LT w rt T h0.
    remember (tright LT w rt) as t.
    glize LT rt 0.
    induction h0; intros;subst; eauto;
    try discriminate; try contradiction. inversion Heqt; subst; eauto.
    forwards :IHh0; subst; eauto.
    destructALL; subst; eauto.
    forwards: subty_extrac_tsum0; eauto; subst. destructALL; subst; eauto.
    inversion H0; inversion H1; subst; eauto.
    forwards: subty_extra_tsum; eauto; destructALL; subst.
    repeat eexists.
    destruct (eq_ty_dec x0 x2); subst; eauto.

Qed.

Lemma extty_inver:
    forall T,
    (exists i, (extty_to_ty T) = TVar i )
    \/(exists I O, extty_to_ty T  = TFun I O)
    \/(exists L R, extty_to_ty T = TSum L R).
    intros T; destruct T; simpl in *; eauto.

Qed.

Lemma value_has_type_inver_tsum11:
    forall t,
        value t ->
        forall TL TR,
        has_type empty t (TSum TL TR) ->
        (exists tl tr w, t = tleft tl tr w) \/
        (exists tl tr w, t = tright tl w tr) \/
        (exists L R t' h, t = text (ETSum L R) t' h).

    intros t h0 TL TR h.
    remember empty as ctx;
    remember (TSum TL TR) as H.
    glize h0 Heqctx TL TR 0.
    induction h; intros; subst; eauto; try discriminate;
    try (
        match goal with
        | h : value _ |- _ =>
            inversion h; subst; eauto
        end;
        try (left; repeat eexists; eauto; fail);
        try (right; left; repeat eexists; eauto; fail);
        try (right; right; repeat eexists; eauto; fail);
        fail).

    (* case extty *)
    destruct T; cbn in *; subst; try discriminate; eauto.
    right; right; repeat eexists; eauto.

    forwards*: subty_extrac_tsum1.
Qed.

Lemma value_has_type_inver_tfun1:
    forall t,
        value t ->
        forall iT oT,
        has_type empty t (TFun iT oT) ->
        (exists i T w body, t = tfun i T w body /\ subty iT T /\ orfu T)
        \/ (exists T o w i, t = tfield T o w i)
        \/ (exists T x h, t = text T x h).

    intros t h0 iT oT H.
    remember empty as ctx;
    remember (TFun iT oT) as T'.
    glize iT oT Heqctx h0 0.
    induction H;intros; subst; eauto; try discriminate;
    try (
        match goal with
        | h : value (_ _) |- _ =>
            inversion h; subst; eauto
        end; fail
    ).

    inversion HeqT'; subst; eauto. left; eauto. exists i. exists iT. exists h. eauto.
    inversion HeqT'; subst; eauto. right; left; eauto.
    right;right; eauto.
    forwards*:subty_extrac_tfun1. destructALL; subst; eauto.
    forwards*:subty_extra_tfun; destructALL; subst.

    forwards*:IHhas_type; destructALL; subst; eauto.
    assert (subty iT x2); eauto.
    left. repeat eexists; eauto.
    right; left; eauto.
    right; right; eauto.

Qed.

Lemma value_has_type_inver_tfield0:
    forall ctx T0 ort wft i T,
        has_type ctx (tfield T0 ort wft i) T ->
        (exists Ti To,
            T = TFun Ti To /\ only_rcd Ti /\ subty Ti T0).
    intros ctx T0 ort wft i T h0.
    remember (tfield T0 ort wft i) as t.
    glize T0 i 0.
    induction h0; intros;subst; eauto;
    try discriminate; try contradiction.
    inversion Heqt; subst; eauto.
    repeat eexists; eauto.
    forwards :IHh0; subst; eauto.
    destructALL; subst; eauto.
    forwards: subty_extrac_tfun0; eauto; subst.
    destructALL; subst. forwards*: subty_extra_tfun;destructALL; subst; eauto.
    repeat exists. repeat split; eauto. eapply subty_rcd; eauto.
Qed.

Lemma value_has_type_inver_tfield0':
    forall ctx T0 ort wft i T,
        has_type ctx (tfield T0 ort wft i) T ->
        (exists Ti To,
            (T = TFun Ti To
            /\ only_rcd Ti
            /\ subty Ti T0
            /\ exists T', rcd_field_ty' T0 i = Some T' /\ subty T' To)
        /\ orfu T0
        ).
    intros ctx T0 ort wft i T h0.
    remember (tfield T0 ort wft i) as t.
    glize T0 i 0.
    induction h0; intros;subst; eauto;
    try discriminate; try contradiction.
    inversion Heqt; subst; eauto.
    repeat eexists; eauto. eapply subRefl.
    unfold rcd_field_ty in *. eapply rcd_field_ty'_wf_is_wf; eauto.
    forwards :IHh0; subst; eauto.
    destructALL; subst; eauto.
    forwards: subty_extrac_tfun0; eauto; subst.
    destructALL; subst. forwards*: subty_extra_tfun;destructALL; subst; eauto.
    repeat exists. repeat split; eauto. eapply subty_rcd; eauto.
Qed.

Lemma value_has_type_inver_trcd1:
    forall t,
        value t ->
        forall T,
        has_type empty t T ->
        only_rcd T ->
        wf_ty T ->
        t = tnone \/ exists i th tt, t = trcons i th tt.
    intros t h T H.
    remember empty as ctx.
    glize h Heqctx 0.
    induction H; intros; subst; eauto;
    try discriminate;
    try (
        match goal with
        | h: value _ |- _ =>
            inversion h; subst; eauto; fail
        | h: only_rcd _ |- _ =>
            inversion h; subst; eauto
        end;
        fail
    ).
    destruct (extty_inver T); destructALL;
        match goal with
        | h : extty_to_ty _ = _ |- _ => rewrite h in *
        end; inversion H.
    forwards*:IHhas_type. eapply subty_rcd; eauto.
    destruct (subty_wf _ _ H0); eauto.
Qed.

Lemma tfield_never_none:
    forall ctx x y z T,
        ~has_type ctx (tfield TNone x y z) T.

    intros ctx x y z T h.
    remember (tfield TNone x y z) as t.
    glize x y z 0.
    induction h; intros; subst; eauto ;try discriminate.
    inversion Heqt; subst; eauto.
    unfold rcd_field_ty in H. simpl in H; try discriminate.
Qed.

Lemma subty_onlyrefl_text:
    forall T T',
        (subty (extty_to_ty T) T') \/ subty T' (extty_to_ty T) ->
        T' = extty_to_ty T.

    induction T; intros; subst; simpl in *; eauto;
    destructALL.
    (* case TVar *)
    forwards*: subty_onlyrefl_TVar0; eauto.
    forwards*: subty_onlyrefl_TVar1; eauto.
    (* case TFun *)
    forwards*: subty_extrac_tfun0; eauto; destructALL; subst; eauto.
        forwards*: subty_extra_tfun; destructALL; subst; eauto.
        forwards*: subty_onlyrefl_TVar1; eauto.
        forwardALL; subst; eauto.
    forwards*: subty_extrac_tfun1; eauto; destructALL; subst; eauto.
        forwards*: subty_extra_tfun; destructALL; subst; eauto.
        forwards*: subty_onlyrefl_TVar0; eauto.
        forwardALL; subst; eauto.

    (* case TSum *)
    forwards*: subty_extrac_tsum0; destructALL; subst; eauto.
        forwards*: subty_extra_tsum; destructALL; subst; eauto.
        forwards*: IHT1; eauto; forwards*: IHT2; eauto; subst; eauto.

    forwards*: subty_extrac_tsum1; destructALL; subst; eauto.
        forwards*: subty_extra_tsum; destructALL; subst; eauto.
        forwards*: IHT1; eauto; forwards*: IHT2; eauto; subst; eauto.

Qed.

Lemma value_has_type_inver_text0:
    forall T t h T',
        has_type empty (text T t h) T' ->
        T' = extty_to_ty T.

    intros T t h0 T' h.
    remember empty as ctx.
    remember (text T t h0) as x.
    glize T t Heqctx 0.
    induction h; intros; subst; eauto; try discriminate.

    inversion Heqx; subst; eauto.
    edestruct H2.
    forwards*: IHh; subst; eauto.
    symmetry. eapply subty_onlyrefl_text; eauto.
Qed.

Lemma value_has_type_inver_text1:
    forall t T,
        has_type empty t (extty_to_ty T) ->
        exists x h0, t = text T x h0.

    intros t T.
    glize t 0.
    induction T; intros; simpl in *; subst; eauto.
    Focus 2.

Abort.

Lemma value_has_type_inver_TVar1:
    forall t I,
        has_type empty t (TVar I) ->
        value t ->
        exists x h0, t = text (ETVar I) x h0.

    intros t I h.
    remember empty as ctx.
    remember (TVar I) as T.
    glize I Heqctx 0.
    induction h; intros; subst; eauto; try discriminate;
    try (match goal with
        | h : value _ |- _ => inversion h; subst; eauto; try discriminate; fail
        end
    ).
    destruct T; simpl in *; try discriminate.
    inversion HeqT; subst; eauto.

    edestruct H2. eapply subty_onlyrefl_TVar1; eauto.
Qed.

Ltac eli_dupli_wf_ty :=
repeat (
    match goal with
    | w1 : wf_ty ?t, w2 : wf_ty ?t |- _ =>
        poses' (wf_ty_indistinct t w1 w2);
        subst
    end
).
Ltac eli_dupli_orcd :=
repeat (
    match goal with
    | w1 : only_rcd ?t, w2 : only_rcd ?t |- _ =>
        poses' (orcd_indistinct t w1 w2);
        subst
    end
).

Ltac eli_dupli_wf_ty_orcd := eli_dupli_wf_ty; eli_dupli_orcd.

Ltac construct_orcd :=
repeat match goal with
| h0 : subty ?x ?y, h1 : only_rcd ?x |- _ =>
    poses' (subty_rcd1 _ _ h1 h0);
    glize h0 0
| h0 : subty ?x ?y, h1 : only_rcd ?y |- _ =>
    poses' (subty_rcd _ _ h1 h0);
    glize h0 0
end; intros.

Ltac construct_wf_ty_and_orcd :=
repeat match goal with
| h0 : subty _ _ |- _ =>
    destruct (subty_wf _ _ h0);
    destructALL; glize h0 0
| h0 : has_type _ _ ?T |- _ =>
    poses' (has_type_well_formed _ _ _ h0);
    destructALL; glize h0 0
end; intros;construct_orcd.

Lemma value_has_type_inver_tfun3:
    forall ctx i T h body T0 T1,
        has_type ctx (tfun i T h body) (TFun T0 T1) ->
        has_type (update i (exist wf_ty T h) ctx) body T1.

    intros. remember (tfun i T h body) as tm.
    remember (TFun T0 T1) as Ty.
    glize T0 T T1 i body 0.

    induction H; intros; subst; eauto; try discriminate.
    inversion Heqtm; inversion HeqTy; subst; eauto.
    eli_dupli_wf_ty_orcd. eauto.

    forwards*: subty_extrac_tfun1. destructALL; subst; eauto.
    forwards*: IHhas_type.
    destruct (eq_ty_dec x0 T2); subst; eauto.
    inversion H1; inversion H2; subst; eauto.
    eapply ht_subty; eauto.
    forwards*: subty_extra_tfun; eauto.
Qed.

Lemma record_has_type_has_field:
    forall t T i T',
        has_type empty t T ->
        value t ->
        rcd_field_ty' T i = Some T' ->
        exists t', rcd_field_tm' t i = Some t'.

    intros t T i T' h.
    remember empty as ctx.
    glize  T' i Heqctx 0.
    induction h; subst; eauto;intros;subst; try discriminate;
    try match goal with
        | h : value _ |- _ => inversion h; subst; eauto; try discriminate; fail
        end;
    repeat match goal with
            | h: ?x = ?x -> _ |- _ => poses' (h eq_refl); clear h
            end.
    (* case ht_rcd *)
    simpl in *.
    destruct (eq_id_dec i i0); subst; eauto; try discriminate.
    inversion H2; subst; eauto.

    (* case ht_ext*)
    destruct (extty_inver T);destructALL;
    try match goal with | ho : extty_to_ty _ = _ |- _ => rewrite ho in * end;
    simpl in *; try discriminate; eauto.

    (* case ht_sub*)

    poses' (subty_defined_well_strong_orfu _ _ H H0 _ _ H4); destructALL.
    eapply H5; eauto.

Qed.

Lemma record_has_type_has_field_with_type:
    forall i t t' T T',
        has_type empty t T ->
        value t ->
        rcd_field_ty' T i = Some T' ->
        rcd_field_tm' t i = Some t' ->
        exists T'', has_type empty t' T'' /\ subty T'' T'.
    intros i t t' T T' h.
    remember empty as ctx.
    glize i Heqctx t' T' 0.
    induction h; intros; cbn in *; subst; eauto; try discriminate;
    try (
        match goal with
        | h : value (_ _) |- _ => inversion h; subst; eauto
        end
    ).
    destruct (eq_id_dec i i0); subst; eauto. inversion H3; inversion H4; subst; eauto.
    eexists; split; eauto. eapply subRefl. eapply has_type_well_formed; eauto.

    forwards*: subty_defined_well_strong_orfu. destructALL; eauto.

    forwards* : IHh; eauto.
Qed.

Theorem progress:
    forall t T,
        has_type empty t T ->
        value t \/ (exists t', step t t').

intros t T h.
remember empty as ctx.
glize Heqctx 0.
induction h; intros; subst; eauto; try discriminate;
repeat ( (* Remove Unnecessary assumption*)
    match goal with
    | h0 : ?x = ?x -> _ |- _ =>
        poses' (h0 eq_refl); clear h0
    end
);
try (
    destructALL;
    forwardALL;
    try (
        left; eauto; fail
    );
    try (
        right; eexists; eauto; fail
    ); fail
).

    (* case tapp *)
    destructALL;
    forwardALL;
    try (
        left; eauto; fail
    );
    try (
        right; eexists; eauto; fail
    ).
    poses' (value_has_type_inver_tfun1 _ H _ _ h1);
    destructALL; subst; eauto.
        (* case tfield*)
        right.
        forwards*: value_has_type_inver_tfield0'; destructALL; subst; eauto.
        inversion H1; subst; eauto.
        assert (orfu x3); eauto. eapply has_type_orfu; eauto.
        assert (has_type empty t1 x); eauto.
            destruct (eq_ty_dec x x3); subst; eauto.
        forwards*: (record_has_type_has_field); destructALL.

        (* case text *)
        right.
        forwards*: value_has_type_inver_text0; eauto.
        destruct x; subst; eauto; try discriminate.
        simpl in *; eauto.
        inversion H1; subst; eauto.
        forwards*: value_has_type_inver_TVar1; eauto; destructALL; subst; eauto.
    (* case tlet *)
    clear IHh2.
    destructALL;
    forwardALL; eauto.

    (* case tcase *)
    destructALL;
    forwardALL;
    try (
        left; eauto; fail
    );
    try (
        right; eexists; eauto; fail
    ).
    right.

    forwards*: (value_has_type_inver_tsum11 _ H); eauto.
    destructALL;subst; eauto;
    try (
        match goal with
        | h : value (_ _) |- _ => inversion h; subst; eauto; fail
        end
    ).

    destruct (ExttmSumResolver x x0 x1 x2) eqn:h0; eauto.
    destruct s; eauto.
    destruct s; eauto.
Qed.

Lemma subst_type_preserve:
    forall i Ti h ctx' ctx t body T,
        has_type ctx' body T ->
        ctx' -=- (update i (exist wf_ty Ti h) ctx) ->
        has_type ctx t Ti ->
        has_type ctx (subst i t body) T.
    intros i Ti h0 ctx' ctx t body T h h'.
    assert (ctx' =-= (update i (exist wf_ty Ti h0) ctx)); eauto.
    eapply CtxEq_byCtxEq; eauto.
    glize Ti t  ctx i 0.
    induction h; intros; subst; cbn in *; try discriminate; eauto.

    (* case tvar *)
    destruct (eq_id_dec i i0); subst; eauto.
    assert (byContext (update i0 (exist wf_ty Ti h0) ctx0) i0 = byContext ctx i0).
    eapply CtxEq_byCtxEq; eauto.
    rewrite H in *; cbn in *. rewrite eq_id_dec_id in *.
    inversion H3; subst; eauto.

    eli_dupli_wf_ty_orcd.
    eapply ht_var; eauto.
    assert (byContext (update i0 (exist wf_ty Ti h0) ctx0) i = Some (exist wf_ty T h)).
    rewrite <- H. symmetry. eapply H1. cbn in *; eauto. destruct (eq_id_dec i i0); subst; eauto; try contradiction.

    (* case tfun *)
    destruct (eq_id_dec i i0); subst; eauto.
    eapply ht_fun; eauto.
    assert (has_type (update i0 (exist wf_ty T h) (update i0 (exist wf_ty Ti h1) ctx0)) body TO).
    eapply ctx_eq_rewrite; eauto.
    assert (has_type (update i0 (exist wf_ty T h) ( ctx0)) body TO).
    eapply ctx_eq_rewrite; eauto. eauto.
    eapply ht_fun; eauto.

    eapply ctx_eq_rewrite.
    eapply IHh; eauto. eapply CtxEq_byCtxEq.
    eapply eqSymm. eapply eqTrans. eapply eqPermute; eauto.
    eapply eqUpdate. eapply eqSymm; eauto.

Abort.

(* Why ?! Why is cannot be proved ?! *)
Lemma subst_type_preserve:
    forall i Ti h ctx' ctx t body T,
        has_type ctx' body T ->
        ctx' -=- (update i (exist wf_ty Ti h) ctx) ->
        has_type empty t Ti ->
        has_type ctx (subst i t body) T.

    intros i Ti h0 ctx' ctx t body T h h'.
    assert (ctx' =-= (update i (exist wf_ty Ti h0) ctx)); eauto.
    eapply CtxEq_byCtxEq; eauto.
    glize Ti t  ctx i 0.
    induction h; intros; subst; cbn in *; try discriminate; eauto.

        (* case tvar *)
        destruct (eq_id_dec i i0); subst; eauto.
        assert (byContext (update i0 (exist wf_ty Ti h0) ctx0) i0 = byContext ctx i0).
        eapply CtxEq_byCtxEq; eauto.
        rewrite H in *; cbn in *. rewrite eq_id_dec_id in *.
        inversion H3; subst; eauto. eapply empty_typed_ctx_typed; eauto.

        eli_dupli_wf_ty_orcd.
        eapply ht_var; eauto.
        assert (byContext (update i0 (exist wf_ty Ti h0) ctx0) i = Some (exist wf_ty T h)).
        rewrite <- H. symmetry. eapply H1. cbn in *; eauto. destruct (eq_id_dec i i0); subst; eauto; try contradiction.

        (* case tfun *)
        destruct (eq_id_dec i i0); subst; eauto.
    eapply ht_fun; eauto.
    assert (has_type (update i0 (exist wf_ty T h) (update i0 (exist wf_ty Ti h1) ctx0)) body TO).
    eapply ctx_eq_rewrite; eauto.
    assert (has_type (update i0 (exist wf_ty T h) ( ctx0)) body TO).
    eapply ctx_eq_rewrite; eauto. eauto.
    eapply ht_fun; eauto.

    eapply ctx_eq_rewrite.
    eapply IHh; eauto. eapply CtxEq_byCtxEq.
    eapply eqSymm. eapply eqTrans. eapply eqPermute; eauto.
    eapply eqUpdate. eapply eqSymm; eauto. eapply CtxeqId.

    (* case tlet *)
    destruct (eq_id_dec i i0); subst; eauto.
    eapply ht_let; eauto.
    assert (has_type (update i0 (exist (fun x : ty => wf_ty x) T h1) (update i0 (exist wf_ty Ti h0) ctx0)) body T').
    eapply ctx_eq_rewrite; eauto.
    eapply ctx_eq_rewrite; eauto.
    eapply ht_let; eauto.
    eapply IHh2; eauto. eapply CtxEq_byCtxEq.
    eapply eqSymm. eapply eqTrans. eapply eqPermute. eauto.
    intro. subst; try contradiction. eapply eqUpdate. eapply eqSymm; eauto.

    (* case tfixApp *)
    destruct (eq_id_dec i i0); subst; eauto.
    eapply ht_fix.
    assert (has_type (update i0 (exist (fun x : ty => wf_ty x) T h) (update i0 (exist wf_ty Ti h1) ctx0)) body T).
    eapply ctx_eq_rewrite; eauto.
    eapply ctx_eq_rewrite; eauto.
    eapply ht_fix; eauto.
    eapply IHh; eauto. eapply CtxEq_byCtxEq.
    eapply eqSymm. eapply eqTrans. eapply eqPermute. eauto.
    intro. subst; try contradiction. eapply eqUpdate. eapply eqSymm; eauto.
Qed.

Theorem preservation:
    forall t t' T,
        has_type empty t T ->
        step t t' ->
        has_type empty t' T.

    intros t t' T h.
    remember empty as ctx.
    glize t' Heqctx 0.
    induction h;intros; subst; eauto; try discriminate;
    repeat (
        match goal with
        | hh : ?x = ?x -> _ |- _ => poses' (hh eq_refl); clear hh
        end
    );
    try (
        match goal with
        | h : step _ _ |- _ =>
            inversion h; subst; eauto;
            try (
                match goal with
                | HH : _ -> _ |- _=>
                    forwards*: HH; destructALL; eexists;split; subst;  eauto; fail
                end
            )
        end
    );
    construct_wf_ty_and_orcd;
    eli_dupli_wf_ty_orcd;
    try (
        match goal with
        | h0 : forall _, step ?x _ -> _, h1 : step ?x _ |- _ =>
            forwards*: h0; subst; eauto; destructALL;  eauto
        end
    );
    construct_wf_ty_and_orcd;
    construct_orcd;
    eli_dupli_wf_ty_orcd;
    eauto;

    try (eapply subst_type_preserve; eauto; fail).

    (* case tfun *)

    forwards*: (value_has_type_inver_tfun1 ((tfun i T h body)));
    destructALL; subst; try discriminate. inversion H2; subst; eauto.
    forwards*: value_has_type_inver_tfun3. eauto.
    eapply subst_type_preserve; eauto.
    destruct (eq_ty_dec T0 x0); subst; eauto.
    eapply ht_subty; eauto.
    eapply has_type_orfu; eauto.

    (* case tfield *)
    forwards*: (value_has_type_inver_tfield0');
    destructALL; subst; eauto. inversion H2; subst; eauto.
    assert (has_type empty t1 T); eauto.
        destruct (eq_ty_dec T x); subst; eauto.
        eapply ht_subty; eauto. eapply has_type_orfu; eauto.
    forwards*: record_has_type_has_field_with_type; destructALL; eauto.
    forwards*: has_type_orfu.
    forwards*: rcd_field_ty'_orfu_is_orfu.
    assert (orfu (TFun x x0)); eauto; try eapply has_type_orfu; eauto.
    inversion H17; subst; eauto.
    assert (has_type empty t' x1); eauto.
        destruct (eq_ty_dec x2 x1); subst; eauto.
    destruct (eq_ty_dec x1 x0); subst; eauto.

    (* case text*)
    destruct (eintp i O f x h0 h3).
    forwards* : value_has_type_inver_text0. cbn in *. inversion H2; subst; eauto.

    (* case tleft *)
    eapply ht_app; eauto.
    forwards*: value_has_type_inver_tsum0; destructALL; subst; eauto.
    inversion H3; subst; eauto.
    (* case tright *)
    eapply ht_app; eauto.
    forwards*: value_has_type_inver_tsum1; destructALL; subst; eauto.
    inversion H3; subst; eauto.

    (* case text TSum*)
    eapply ht_app; eauto.
    forwards*: value_has_type_inver_text0. cbn in *.
    inversion H3; subst; eauto.

    eapply ht_app; eauto.
    forwards*: value_has_type_inver_text0. cbn in *.
    inversion H3; subst; eauto.

Qed.

End SmallCoreTyping.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Canonical.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}
        {AX: NormalAxiomatization L GammaP GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}
        {wandAX: WandAxiomatization L GammaP}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {J: Join (Kworlds M)}
        {SM: Semantics L MD}
        {fsepconSM: SepconSemantics L MD M SM}
        {fwandSM: WandSemantics L MD M SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Hypothesis H_J: forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi -> (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).

Instance SA
         (AL_DC: at_least derivable_closed cP)
         (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP):
  SeparationAlgebra (Kworlds M).
Proof.
  constructor.
  + intros.
    destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    destruct (im_bij _ _ rel m) as [Phi ?].
    erewrite H_J in H |- * by eauto.
    hnf; intros.
    destruct H3 as [y [z [? [? ?]]]].
    subst.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    rewrite <- sepcon_comm_impp.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    apply H.
    exists z, y; split; [| split]; auto.
  + intros.
    destruct (im_bij _ _ rel mx) as [Phi_x ?].
    destruct (im_bij _ _ rel my) as [Phi_y ?].
    destruct (im_bij _ _ rel mz) as [Phi_z ?].
    destruct (im_bij _ _ rel mxy) as [Phi_xy ?].
    destruct (im_bij _ _ rel mxyz) as [Phi_xyz ?].
    erewrite H_J in H, H0 by eauto.
    assert (Included _ (context_sepcon (proj1_sig Phi_x)
             (context_sepcon (proj1_sig Phi_y) (proj1_sig Phi_z))) (proj1_sig Phi_xyz)).
    - hnf; intros xyz ?.
      destruct H6 as [x [yz [? [? ?]]]]; subst xyz.
      apply context_sepcon_derivable in H8.
      destruct H8 as [y [z [? [? ?]]]].
      rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xyz)).
      rewrite <- H6, sepcon_assoc.
      rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xyz)).
      apply H0.
      exists (x * y), z; split; [| split]; auto.
      rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi_xy)).
      apply H.
      exists x, y; split; [| split]; auto.
    - apply LIN_SR in H6.
      destruct H6 as [Phi_yz [? ?]].
      unfold context_sepcon_included_r in H7.
      destruct (su_bij _ _ rel Phi_yz) as [myz ?].
      exists myz.
      erewrite !H_J by eauto.
      auto.
Qed.

Instance uSA
         (AL_DC: at_least derivable_closed cP):
  UpwardsClosedSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  exists m1, m2.
  destruct (im_bij _ _ rel n) as [Psi ?].
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H |- * by eauto.
  erewrite H_R in H0 by eauto.
  do 2 erewrite H_R by eauto.
  split; [| split].
  + eapply Included_trans; eauto.
  + hnf; intros; auto.
  + hnf; intros; auto.
Qed.

Instance dSA
         (AL_DC: at_least derivable_closed cP):
  DownwardsClosedSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  exists m.
  destruct (im_bij _ _ rel n1) as [Psi1 ?].
  destruct (im_bij _ _ rel n2) as [Psi2 ?].
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H |- * by eauto.
  erewrite H_R in H0, H1 |- * by eauto.
  split.
  + eapply Included_trans; eauto.
    hnf; intros z [x [y [? [? ?]]]]; subst.
    exists x, y.
    split; [| split]; auto.
    - eapply deduction_weaken; eauto.
    - eapply deduction_weaken; eauto.
  + hnf; intros; auto.
Qed.

Lemma garbage_collected_canonical_increaing
      {gcsAX: GarbageCollectSeparationLogic L GammaP}
      (AL_DC: at_least derivable_closed cP):
  IncreasingSeparationAlgebra (Kworlds M).
Proof.
  constructor.
  intros m; hnf; intros n1 n2 ?.
  destruct (im_bij _ _ rel n1) as [Psi1 ?].
  destruct (im_bij _ _ rel n2) as [Psi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_R by eauto.
  erewrite H_J in H by eauto.
  unfold Included, Ensembles.In; intros.
  rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi1)).
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Psi2)).
  rewrite <- (sepcon_elim2 TT).
  rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Psi2)).
  apply H; auto.
  exists TT, x; split; [| split]; auto.
  apply derivable_impp_refl.
Qed.

Lemma ext_canonical_residual
      {ExtsAX: ExtSeparationLogic L GammaP}
      (AL_DC: at_least derivable_closed cP)
      (LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP):
  ResidualSeparationAlgebra (Kworlds M).
Proof.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  assert (Included _ (context_sepcon (Union _ empty_context (Singleton _ TT)) (proj1_sig Phi)) (proj1_sig Phi)).
  + hnf; intros.
    destruct H0 as [y [z [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H1.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    subst; rewrite <- H1.
    rewrite <- sepcon_comm, <- sepcon_ext; auto.
  + apply LIN_SL in H0.
    destruct H0 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    exists n; split.
    - erewrite H_J by eauto.
      auto.
    - erewrite H_R by eauto.
      hnf; intros; auto.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L GammaP}
        {fempSM: EmpSemantics L MD M SM}.

Instance unitSA
         (AL_DC: at_least derivable_closed cP)
         (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
         (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  UnitalSeparationAlgebra (Kworlds M).
Proof.
  intros.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  assert (Included _ (context_sepcon (proj1_sig Phi) (Union _ empty_context (Singleton _ emp))) (proj1_sig Phi)).
  + hnf; intros.
    destruct H0 as [y [z [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H2.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    subst; rewrite <- H2, sepcon_emp; auto.
  + apply LIN_SR in H0.
    destruct H0 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    split; [exists n; split |].
    - apply (@join_comm _ _ (SA AL_DC LIN_SR)).
      erewrite H_J by eauto.
      auto.
    - erewrite H_R by eauto.
      hnf; intros; auto.
    - clear H1 n Phi H.
      specialize (H0 emp ltac:(right; constructor)).
      unfold Ensembles.In in H0.
      rewrite <- (TRUTH emp) in H0 by eauto.
      rewrite sat_emp in H0; auto.
Qed.

Lemma nonsplit_canonical_split_smaller
      {nssAX: NonsplitEmpSeparationLogic L GammaP}
      (AL_DC: at_least derivable_closed cP)
      (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  IncreasingSplitSmallerSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  destruct (im_bij _ _ rel m1) as [Phi1 ?].
  destruct (im_bij _ _ rel m2) as [Phi2 ?].
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J in H0 by eauto.
  erewrite H_R by eauto.
  unfold Included, Ensembles.In; intros x ?.
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
  rewrite <- (emp_sepcon_truep_elim x).
  apply deduction_andp_intros.
  + apply derivable_assum; apply H0.
    exists x, TT; split; [| split]; auto.
    - apply derivable_assum; auto.
    - apply derivable_impp_refl.
  + rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    rewrite <- (TRUTH emp) by eauto.
    rewrite sat_emp; auto.
Qed.

Lemma dup_canonical_incr_join
      {desAX: DupEmpSeparationLogic L GammaP}
      (AL_DC: at_least derivable_closed cP)
      (TRUTH: forall x, forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  IncreasingJoinSelfSeparationAlgebra (Kworlds M).
Proof.
  hnf; intros.
  destruct (im_bij _ _ rel m) as [Phi ?].
  erewrite H_J by eauto.
  intros z [x [y [? [? ?]]]]; subst.
  rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
  rewrite <- (andp_elim1 x y).
  rewrite <- (andp_elim2 x y) at 2.
  rewrite <- emp_dup.
  apply deduction_andp_intros; [apply deduction_andp_intros |]; auto.
  rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
  unfold Ensembles.In; rewrite <- (TRUTH emp) by eauto.
  rewrite sat_emp; auto.
Qed.

End Canonical.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj9synthconj3 : forall  (lv0 : lst) (lv1 : lst), (@eq natural (len (append lv0 lv1)) (len (append lv0 lv1))).
Admitted.
QuickChick conj9synthconj3.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e174m3_3limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^414 - 17
Base: 25.875
***)

Definition curve : CurveParameters :=
  {|
    sz := 16%nat;
    base := 25 + 7/8;
    bitwidth := 32;
    s := 2^414;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 16); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Oprime Aprime Bprime Cprime X : Universe, ((wd_ B A /\ (wd_ Oprime Aprime /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ A Cprime /\ (wd_ C Aprime /\ (wd_ C Cprime /\ (wd_ B Oprime /\ (wd_ A Oprime /\ (wd_ B Cprime /\ (wd_ Bprime C /\ (col_ B A C /\ (col_ B B C /\ (col_ B A B /\ (col_ Oprime Aprime Bprime /\ (col_ Oprime Bprime Cprime /\ (col_ Oprime Aprime Cprime /\ (col_ X B C /\ (col_ X Bprime Cprime /\ col_ X B B))))))))))))))))))))))) -> col_ X B A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Canonical.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {SM: Semantics L MD}
        {kminSM: KripkeMinimunSemantics L MD M SM}
        {kpSM: KripkePropositionalSemantics L MD M SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Lemma classical_canonical_ident
      {cpSC: ClassicalPropositionalSequentCalculus L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (AL_OW: at_least orp_witnessed cP)
      (AL_CONSI: at_least consistent cP):
  IdentityKripkeIntuitionisticModel (Kworlds M).
Proof.
  constructor.
  intros.
  destruct (im_bij _ _ rel m) as [Phi ?].
  destruct (im_bij _ _ rel n) as [Psi ?].
  erewrite H_R in H by eauto.
  assert (Phi = Psi); [| subst; eapply (in_bij _ _ rel); eauto].
  clear rel H_R m n H0 H1.

  apply sig_context_ext.
  intros; split; [apply H; auto |].
  intros.
  pose proof derivable_excluded_middle (proj1_sig Phi) x.
  rewrite <- derivable_closed_element_derivable in H1 by (apply AL_DC, (proj2_sig Phi)).
  apply AL_OW in H1; [| apply (proj2_sig Phi)].
  destruct H1; auto.
  exfalso.
  apply H in H1; unfold Ensembles.In in H1.
  rewrite derivable_closed_element_derivable in H0, H1 by (apply AL_DC, (proj2_sig Psi)).
  pose proof deduction_modus_ponens _ _ _ H0 H1.
  revert H2; change (~ proj1_sig Psi |-- FF).
  rewrite <- consistent_spec.
  apply AL_CONSI, (proj2_sig Psi).
Qed.

Lemma GodelDummett_canonical_no_branch
      {SC: NormalSequentCalculus L Gamma}
      {minAX: MinimunAxiomatization L Gamma}
      {ipGamma: IntuitionisticPropositionalLogic L Gamma}
      {gdpGamma: GodelDummettPropositionalLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (AL_OW: at_least orp_witnessed cP):
  NoBranchKripkeIntuitionisticModel (Kworlds M).
Proof.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  destruct (im_bij _ _ rel m1) as [Psi1 ?].
  destruct (im_bij _ _ rel m2) as [Psi2 ?].
  erewrite !H_R in H, H0 by eauto.
  do 2 erewrite H_R by eauto.
  clear rel H_R m1 m2 n H1 H2 H3.

  apply NNPP; intro.
  apply not_or_and in H1; destruct H1.
  apply not_all_ex_not in H1.
  apply not_all_ex_not in H2.
  destruct H1 as [x1 ?], H2 as [x2 ?].
  pose proof deduction_weaken0 (proj1_sig Phi) _ (impp_choice x1 x2).
  rewrite <- derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Phi)).
  apply AL_OW in H3; [| apply (proj2_sig Phi)].
  destruct H3; pose proof H3; apply H in H3; apply H0 in H4.
  + rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi1)).
    rewrite derivable_closed_element_derivable in H4 by (apply AL_DC, (proj2_sig Psi2)).
    pose proof (fun HH => deduction_modus_ponens _ _ _ HH H3).
    pose proof (fun HH => deduction_modus_ponens _ _ _ HH H4).
    rewrite <- !derivable_closed_element_derivable in H5 by (apply AL_DC, (proj2_sig Psi1)).
    rewrite <- !derivable_closed_element_derivable in H6 by (apply AL_DC, (proj2_sig Psi2)).
    clear - H1 H2 H5 H6.
    tauto.
  + rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi1)).
    rewrite derivable_closed_element_derivable in H4 by (apply AL_DC, (proj2_sig Psi2)).
    pose proof (fun HH => deduction_modus_ponens _ _ _ HH H3).
    pose proof (fun HH => deduction_modus_ponens _ _ _ HH H4).
    rewrite <- !derivable_closed_element_derivable in H5 by (apply AL_DC, (proj2_sig Psi1)).
    rewrite <- !derivable_closed_element_derivable in H6 by (apply AL_DC, (proj2_sig Psi2)).
    clear - H1 H2 H5 H6.
    tauto.
Qed.

Lemma DeMorgan_canonical_branch_join
      {SC: NormalSequentCalculus L Gamma}
      {AX: NormalAxiomatization L Gamma}
      {minAX: MinimunAxiomatization L Gamma}
      {ipGamma: IntuitionisticPropositionalLogic L Gamma}
      {dmpGamma: DeMorganPropositionalLogic L Gamma}
      (AL_DC: at_least derivable_closed cP)
      (AL_OW: at_least orp_witnessed cP)
      (AL_CONSI: at_least consistent cP)
      (LIN_CD: forall x, Lindenbaum_constructable (cannot_derive x) cP):
  BranchJoinKripkeIntuitionisticModel (Kworlds M).
Proof.
  constructor.
  intros.
  destruct (im_bij _ _ rel n) as [Phi ?].
  destruct (im_bij _ _ rel m1) as [Psi1 ?].
  destruct (im_bij _ _ rel m2) as [Psi2 ?].
  erewrite !H_R in H, H0 by eauto.
  assert (exists Psi: sig cP, Included _ (proj1_sig Psi1) (proj1_sig Psi) /\
                              Included _ (proj1_sig Psi2) (proj1_sig Psi)).
  Focus 2. {
    destruct H4 as [Psi [? ?]].
    destruct (su_bij _ _ rel Psi) as [m ?].
    exists m.
    erewrite !H_R by eauto; auto.
  } Unfocus.
  clear rel H_R m1 m2 n H1 H2 H3.

  assert (~ (Union _ (proj1_sig Psi1) (proj1_sig Psi2)) |-- FF).
  + intro.
    apply derivable_closed_union_derivable in H1; [| apply AL_DC, (proj2_sig Psi2)].
    destruct H1 as [x [? ?]].
    rewrite derivable_closed_element_derivable in H1 by (apply AL_DC, (proj2_sig Psi2)).
    pose proof deduction_weaken0 (proj1_sig Phi) _ (weak_excluded_middle x).
    rewrite <- derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Phi)).
    apply AL_OW in H3; [| apply (proj2_sig Phi)].
    destruct H3.
    - apply H0 in H3; unfold Ensembles.In in H3.
      rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi2)).
      pose proof deduction_modus_ponens _ _ _ H1 H3.
      revert H4; change (~ proj1_sig Psi2 |-- FF).
      rewrite <- consistent_spec.
      apply AL_CONSI, (proj2_sig Psi2).
    - apply H in H3; unfold Ensembles.In in H3.
      rewrite derivable_closed_element_derivable in H3 by (apply AL_DC, (proj2_sig Psi1)).
      pose proof deduction_modus_ponens _ _ _ H2 H3.
      revert H4; change (~ proj1_sig Psi1 |-- FF).
      rewrite <- consistent_spec.
      apply AL_CONSI, (proj2_sig Psi1).
  + apply LIN_CD in H1.
    destruct H1 as [Psi [? ?]]; exists Psi.
    split; intros ? ?; apply H1; [left | right]; auto.
Qed.

End Canonical.


Require Import Coq.Arith.EqNat.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import GDTC.
Require Import CaseStudy.Names.

Section PNames.

  (* ============================================== *)
  (* TYPES                                          *)
  (* ============================================== *)

  (** SuperFunctor for Types. **)
  Variable D : Set -> Set.
  Context `{spf_D : SPF D}.

  (* ============================================== *)
  (* VALUES                                         *)
  (* ============================================== *)

  (** SuperFunctor for Values. **)
  Variable V : Set -> Set.
  Context `{spf_V : SPF V}.

  Context {Sub_StuckValue_V : StuckValue :<: V}.
  Context {WF_SubStuckValue_V : WF_Functor _ _ Sub_StuckValue_V}.
  Context {Sub_BotValue_V : BotValue :<: V}.
  Context {WF_SubBotValue_V : WF_Functor _ _ Sub_BotValue_V}.

  (* ============================================== *)
  (* EXPRESSIONS                                    *)
  (* ============================================== *)

  (** SuperFunctor for Expressions. **)
  Variable E : Set -> Set -> Set.
  Context {fun_E : forall A, Functor (E A)}.
  Context {pfun_E: forall A, PFunctor (E A)}.
  Context {spf_E : forall A, SPF (E A)}.

  (* ============================================== *)
  (* OPERATIONS                                     *)
  (* ============================================== *)

  (** TYPING **)

  Context {Typeof_E : forall T,
    FAlgebra TypeofName T (typeofR D) (E (typeofR D))}.

  Context {eval_E : forall T, FAlgebra EvalName T (evalR V) (E nat)}.
  Context {beval_E : FAlgebra EvalName (Fix (E nat)) (evalR V) (E nat)}.

  (* ============================================== *)
  (* EXPRESSION EQUIVALENCE RELATION                *)
  (* ============================================== *)

  Section eqv_Section.

    Record eqv_i (A B : Set) : Set := mk_eqv_i
      {env_A : Env A;
        env_B : Env B;
        eqv_a : Fix (E A);
        eqv_b : Fix (E B)}.

    (** SuperFunctor for Equivalence Relation. **)
    Variable EQV_E : forall A B,
      (@eqv_i A B -> Prop) -> eqv_i A B -> Prop.
    Context {ifun_EQV_E : forall A B, iFunctor (EQV_E A B)}.
    Context {ispf_EQV_E : forall A B, iSPF (EQV_E A B)}.

    Definition E_eqv A B := iFix (EQV_E A B).
    Definition E_eqvC {A B : Set} gamma gamma' e e' :=
      E_eqv _ _ (mk_eqv_i A B gamma gamma' e e').

    Variable (NP : Set -> Set).
    Context `{spf_NP : SPF NP}.
    Context {sub_NP_F : forall A, NP :<: E A}.

    Inductive NP_Functor_eqv
      (A B : Set)
      (C : eqv_i A B -> Prop)
      : eqv_i A B -> Prop :=
    | NP_eqv_0 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, NP D)
      (np_all : forall (D : Set) (P : D -> Prop),
                  All P (np D)),
      e = inject _ _ (subFG := sub_NP_F A) (np _) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _) ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C'),
        fmap f (np A') = fmap g (np B')) ->
      NP_Functor_eqv A B C (mk_eqv_i _ _ gamma gamma' e e')
    | NP_eqv_1 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, D -> NP D)
      (np_all : forall (D : Set) (P : D -> Prop) (d : D),
                  P d -> All P (np _ d))
      a a',
      e = inject _ _ (subFG := sub_NP_F A) (np _ a) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _ a') ->
      C (mk_eqv_i _ _ gamma gamma' a a') ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C')
        (a' : A') (b' : B'), f a' = g b' ->
        fmap f (np A' a') = fmap g (np B' b')) ->
      NP_Functor_eqv A B C (mk_eqv_i _ _ gamma gamma' e e')
    | NP_eqv_2 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, D -> D -> NP D)
      (np_all : forall (D : Set) (P : D -> Prop) (d1 d2 : D),
                  P d1 -> P d2 -> All P (np _ d1 d2))
      a a' b b',
      e = inject _ _ (subFG := sub_NP_F A) (np _ a b) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _ a' b') ->
      C (mk_eqv_i _ _ gamma gamma' a a') ->
      C (mk_eqv_i _ _ gamma gamma' b b') ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C')
        (a' a'' : A') (b' b'' : B'), f a' = g b' -> f a'' = g b'' ->
        fmap f (np A' a' a'') = fmap g (np B' b' b'')) ->
      NP_Functor_eqv A B C (mk_eqv_i _ _ gamma gamma' e e')
    | NP_eqv_3 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, D -> D -> D -> NP D)
      (np_all : forall (D : Set) (P : D -> Prop) (d1 d2 d3 : D),
                  P d1 -> P d2 -> P d3 -> All P (np _ d1 d2 d3))
      a a' b b' c c',
      e = inject _ _ (subFG := sub_NP_F A) (np _ a b c) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _ a' b' c') ->
      C (mk_eqv_i _ _ gamma gamma' a a') ->
      C (mk_eqv_i _ _ gamma gamma' b b') ->
      C (mk_eqv_i _ _ gamma gamma' c c') ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C')
        (a' a'' a''' : A') (b' b'' b''' : B'),
        f a' = g b' -> f a'' = g b'' -> f a''' = g b''' ->
        fmap f (np A' a' a'' a''') = fmap g (np B' b' b'' b''')) ->
      NP_Functor_eqv A B C (mk_eqv_i _ _ gamma gamma' e e').

    Inductive NP_Functor_eqv_S
      (A B : Set)
      : eqv_i A B -> Type :=
    | SNP_eqv_0 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, NP D)
      (np_all : forall (D : Set) (P : D -> Prop),
                  All P (np D)),
      e = inject _ _ (subFG := sub_NP_F A) (np _) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _) ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C'),
        fmap f (np A') = fmap g (np B')) ->
      NP_Functor_eqv_S A B (mk_eqv_i _ _ gamma gamma' e e')
    | SNP_eqv_1 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, D -> NP D)
      (np_all : forall (D : Set) (P : D -> Prop) (d : D),
                  P d -> All P (np _ d))
      a a',
      e = inject _ _ (subFG := sub_NP_F A) (np _ a) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _ a') ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C')
        (a' : A') (b' : B'), f a' = g b' ->
        fmap f (np A' a') = fmap g (np B' b')) ->
      NP_Functor_eqv_S A B (mk_eqv_i _ _ gamma gamma' e e')
    | SNP_eqv_2 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, D -> D -> NP D)
      (np_all : forall (D : Set) (P : D -> Prop) (d1 d2 : D),
                  P d1 -> P d2 -> All P (np _ d1 d2))
      a a' b b',
      e = inject _ _ (subFG := sub_NP_F A) (np _ a b) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _ a' b') ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C')
        (a' a'' : A') (b' b'' : B'), f a' = g b' -> f a'' = g b'' ->
        fmap f (np A' a' a'') = fmap g (np B' b' b'')) ->
      NP_Functor_eqv_S A B (mk_eqv_i _ _ gamma gamma' e e')
    | SNP_eqv_3 : forall (gamma : Env A) (gamma' : Env B)
      e e' (np : forall D : Set, D -> D -> D -> NP D)
      (np_all : forall (D : Set) (P : D -> Prop) (d1 d2 d3 : D),
                  P d1 -> P d2 -> P d3 -> All P (np _ d1 d2 d3))
      a a' b b' c c',
      e = inject _ _ (subFG := sub_NP_F A) (np _ a b c) ->
      e' = inject _ _ (subFG := sub_NP_F B) (np _ a' b' c') ->
      (forall (A' B' C' : Set) (f : A' -> C') (g : B' -> C')
        (a' a'' a''' : A') (b' b'' b''' : B'),
        f a' = g b' -> f a'' = g b'' -> f a''' = g b''' ->
        fmap f (np A' a' a'' a''') = fmap g (np B' b' b'' b''')) ->
      NP_Functor_eqv_S A B (mk_eqv_i _ _ gamma gamma' e e').

  Definition NP_Functor_eqv_P (A B : Set) (i : eqv_i A B) (x : NP_Functor_eqv_S A B i) : Type.
    destruct x.
    apply Empty_set.
    apply unit.
    apply (unit + unit)%type.
    apply (unit + unit + unit)%type.
  Defined.

  Definition NP_Functor_eqv_R (A B : Set) (i : eqv_i A B)
             (s : NP_Functor_eqv_S A B i)
             (p : NP_Functor_eqv_P A B i s) : eqv_i A B.
    destruct s; simpl in p.
    destruct p.
    apply (mk_eqv_i _ _ gamma gamma' a a').
    destruct p as [p|p].
    apply (mk_eqv_i _ _ gamma gamma' a a').
    apply (mk_eqv_i _ _ gamma gamma' b b').
    destruct p as [[p|p]|p].
    apply (mk_eqv_i _ _ gamma gamma' a a').
    apply (mk_eqv_i _ _ gamma gamma' b b').
    apply (mk_eqv_i _ _ gamma gamma' c c').
  Defined.

  Definition NP_Functor_eqv_to (A B : Set) (C : eqv_i A B -> Prop) (i : eqv_i A B) :
    IExt _ _ (NP_Functor_eqv_R A B) C i -> NP_Functor_eqv A B C i.
    refine(
    fun x => match x with
               | iext s pf =>
                 match s in NP_Functor_eqv_S _ _ i
                       return (forall p : NP_Functor_eqv_P A B i s,
                                 C (NP_Functor_eqv_R A B i s p)) ->
                              NP_Functor_eqv A B C i
                 with
                   | SNP_eqv_0 gamma gamma' e e' np np_all eq1 eq2 wf_np => fun pf' =>
                     NP_eqv_0 A B C gamma gamma' e e' np np_all eq1 eq2 wf_np
                   | SNP_eqv_1 gamma gamma' e e' np np_all a a' eq1 eq2 wf_np => fun pf' =>
                     NP_eqv_1 A B C gamma gamma' e e' np np_all a a' eq1 eq2 _ wf_np
                   | SNP_eqv_2 gamma gamma' e e' np np_all a a' b b' eq1 eq2 wf_np => fun pf' =>
                     NP_eqv_2 A B C gamma gamma' e e' np np_all a a' b b' eq1 eq2 _ _ wf_np
                   | SNP_eqv_3 gamma gamma' e e' np np_all a a' b b' c c' eq1 eq2 wf_np => fun pf' =>
                     NP_eqv_3 A B C gamma gamma' e e' np np_all a a' b b' c c' eq1 eq2 _ _ _ wf_np
                 end pf
             end); simpl in *.
    apply (pf' tt).
    apply (pf' (inl tt)).
    apply (pf' (inr tt)).
    apply (pf' (inl (inl tt))).
    apply (pf' (inl (inr tt))).
    apply (pf' (inr tt)).
  Defined.

  Definition NP_Functor_eqv_from (A B : Set) (C : eqv_i A B -> Prop) (i : eqv_i A B) :
    NP_Functor_eqv A B C i -> IExt _ _ (NP_Functor_eqv_R A B) C i.
    intro x.
    refine (match x in NP_Functor_eqv _ _ _ i return IExt _ _ (NP_Functor_eqv_R A B) C i
            with
              | NP_eqv_0 gamma gamma' e e' np np_all eq1 eq2 wf_np =>
                iext _ _ (SNP_eqv_0 _ _ gamma gamma' e e' np np_all eq1 eq2 wf_np) _
              | NP_eqv_1 gamma gamma' e e' np np_all a a' eq1 eq2 c1 wf_np =>
                iext _ _(SNP_eqv_1 _ _ gamma gamma' e e' np np_all a a' eq1 eq2 wf_np) _
              | NP_eqv_2 gamma gamma' e e' np np_all a a' b b' eq1 eq2 c1 c2 wf_np =>
                iext _ _(SNP_eqv_2 _ _ gamma gamma' e e' np np_all a a' b b' eq1 eq2 wf_np) _
              | NP_eqv_3 gamma gamma' e e' np np_all a a' b b' c c' eq1 eq2 c1 c2 c3 wf_np =>
                iext _ _(SNP_eqv_3 _ _ gamma gamma' e e' np np_all a a' b b' c c' eq1 eq2 wf_np) _
            end); simpl; intro p.
    destruct p.
    apply c1.
    destruct p as [p|p].
    apply c1.
    apply c2.
    destruct p as [[p|p]|p].
    apply c1.
    apply c2.
    apply c3.
  Defined.

  Global Instance NP_Functor_eqv_Container (A B : Set) : IContainer (NP_Functor_eqv A B) :=
    {| IS    := NP_Functor_eqv_S A B;
       IP    := NP_Functor_eqv_P A B;
       IR    := NP_Functor_eqv_R A B;
       ifrom := NP_Functor_eqv_from A B;
       ito   := NP_Functor_eqv_to A B
    |}.
  Proof.
    intros; destruct a; reflexivity.
    intros; destruct a; destruct s; simpl;
      apply f_equal; extensionality x; destruct x;
      try destruct s; try destruct u; reflexivity.
  Defined.

    Definition ind_alg_NP_Functor_eqv
      (A B : Set)
      (P : eqv_i A B -> Prop)
      (H : forall gamma gamma' e e' np np_all e_eq e'_eq wf_np,
        P (mk_eqv_i _ _ gamma gamma' e e'))
      (H0 : forall gamma gamma' e e' np np_all a a' e_eq e'_eq
        (IHa : P (mk_eqv_i _ _  gamma gamma' a a')) wf_np,
        P (mk_eqv_i _ _  gamma gamma' e e'))
      (H1 : forall gamma gamma' e e' np np_all a a' b b' e_eq e'_eq
        (IHa : P (mk_eqv_i _ _  gamma gamma' a a'))
        (IHb : P (mk_eqv_i _ _  gamma gamma' b b')) wf_np,
        P (mk_eqv_i _ _  gamma gamma' e e'))
      (H2 : forall gamma gamma' e e' np np_all a a' b b' c c' e_eq e'_eq
        (IHa : P (mk_eqv_i _ _  gamma gamma' a a'))
        (IHb : P (mk_eqv_i _ _  gamma gamma' b b'))
        (IHc : P (mk_eqv_i _ _  gamma gamma' c c')) wf_np,
        P (mk_eqv_i _ _  gamma gamma' e e'))
      i (e : NP_Functor_eqv A B P i) : P i :=
      match e in NP_Functor_eqv _ _ _  i return P i with
        | NP_eqv_0 gamma gamma' e e' np np_all e_eq e'_eq wf_np =>
          H gamma gamma' e e' np np_all e_eq e'_eq wf_np
        | NP_eqv_1 gamma gamma' e e' np np_all a a' e_eq e'_eq a_eqv wf_np =>
          H0 gamma gamma' e e' np np_all a a' e_eq e'_eq a_eqv wf_np
        | NP_eqv_2 gamma gamma' e e' np np_all a a' b b' e_eq e'_eq a_eqv b_eqv wf_np =>
          H1 gamma gamma' e e' np np_all a a' b b' e_eq e'_eq a_eqv b_eqv wf_np
        | NP_eqv_3 gamma gamma' e e' np np_all a a' b b' c c' e_eq e'_eq a_eqv b_eqv c_eqv wf_np  =>
          H2 gamma gamma' e e' np np_all a a' b b' c c' e_eq e'_eq a_eqv b_eqv c_eqv wf_np
      end.

    (* Projection doesn't affect Equivalence Relation.*)

    Variable Sub_NP_Functor_eqv_EQV_E : forall A B,
      Sub_iFunctor (NP_Functor_eqv A B) (EQV_E A B).

   End eqv_Section.

   Variable EQV_E : forall A B, (@eqv_i A B -> Prop) -> eqv_i A B -> Prop.
   Context {ifun_EQV_E : forall A B, iFunctor (EQV_E A B)}.
   Context {ispf_EQV_E : forall A B, iSPF (EQV_E A B)}.
   Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop.
   Context `{spfWFV : iSPF _ WFV}.

   Definition WF_eqv_environment_P (env_A_B : Env (typeofR D) * Env nat) gamma'' :=
     (forall m b : nat,
       lookup (snd env_A_B) m = Some b ->
       exists T, lookup (fst env_A_B) b = Some T) /\
     Datatypes.length (fst env_A_B) = Datatypes.length (snd env_A_B) /\
     (forall m b : nat, lookup (snd env_A_B) m = Some b -> b = m) /\
     WF_Environment _ _ WFV gamma'' (fst env_A_B).

    Definition eqv_eval_alg_Soundness'_P
      (typeof_rec : Fix (E (typeofR D)) -> typeofR D)
      (eval_rec : Fix (E nat) -> evalR V)
      (typeof_F : Mixin (Fix (E (typeofR D))) (E (typeofR D)) (typeofR D))
      (eval_F : Mixin (Fix (E nat)) (E nat) (evalR V))
      (i : eqv_i (typeofR D) nat) :=
      E_eqv EQV_E _ _ i /\
      eval_alg_Soundness_P D V (E nat) WFV
      _ WF_eqv_environment_P
      (E (typeofR D)) (env_A _ _ i, env_B _ _ i) typeof_rec eval_rec
      typeof_F eval_F
      (eqv_a _ _ i, eqv_b _ _ i).

    Lemma WF_eqv_environment_P_insert : forall gamma gamma' gamma'' v T,
      WF_eqv_environment_P (gamma, gamma') gamma'' ->
      WFValueC _ _ WFV v T ->
      WF_eqv_environment_P (insert _ (Some T) gamma, insert _ (Datatypes.length gamma') gamma')
      (insert _ v gamma'').
    Proof.
      intros; destruct H as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]].
      unfold WF_eqv_environment_P; simpl in *|-*; repeat split.
      rewrite <- WF_gamma2.
      revert WF_gamma; clear; simpl; induction gamma';
        destruct m; simpl; intros; try discriminate.
      injection H; intros; subst.
      clear; induction gamma; simpl; eauto; eexists.
      injection H; intros; subst.
      generalize b (WF_gamma 0 _ (eq_refl _)); clear; induction gamma; simpl; intros b H;
        destruct H as [T' lookup_T']; try discriminate.
      destruct b; eauto.
      eapply IHgamma'.
      intros n0 b0 H0; eapply (WF_gamma (S n0) _ H0).
      eassumption.
      assert (exists m', Datatypes.length gamma' = m') as m'_eq
        by (eexists _; reflexivity); destruct m'_eq as [m' m'_eq].
      rewrite m'_eq; generalize m' gamma' WF_gamma2; clear; induction gamma;
        destruct gamma'; intros; simpl; try discriminate;
          try injection H7; intros; eauto.
      simpl in *|-*.
      intro; caseEq (beq_nat m (Datatypes.length gamma')).
      assert (exists m', m' = Datatypes.length gamma') as ex_m' by
        (eexists _; reflexivity); destruct ex_m' as [m' m'_eq];
          rewrite <- m'_eq in H at 1.
      rewrite <- WF_gamma2 in H1.
      rewrite (beq_nat_true _ _ H).
      rewrite (beq_nat_true _ _ H), m'_eq in H1.
      rewrite <- WF_gamma2 in m'_eq; rewrite m'_eq.
      generalize m' b H1; clear.
      induction gamma'; simpl; intros; try discriminate.
      injection H1; auto.
      eauto.
      eapply WF_gamma'.
      rewrite <- WF_gamma2 in H1.
      assert (exists m', m' = Datatypes.length gamma') as ex_m' by
      (eexists _; reflexivity); destruct ex_m' as [m' m'_eq].
      generalize m' m (beq_nat_false _ _ H) H1; clear;
        induction gamma'; simpl; destruct m; intros;
          try discriminate; eauto.
      elimtype False; eauto.
      eapply P2_Env_insert.
      eauto.
      apply H0.
    Qed.

    Section NP_beval_Soundness.

    Variable (NP : Set -> Set).
    Context `{PFun_NP : PFunctor NP}.
    Context {sub_NP_F : forall A, NP :<: E A}.
    Context {WF_sub_NP_F_V : forall A, WF_Functor _ _ (sub_NP_F A)}.

    Context {Sub_NP_Functor_eqv_EQV_E : forall A B,
      Sub_iFunctor (NP_Functor_eqv NP A B) (EQV_E A B)}.

    Context {eval_Soundness_alg_NP : forall pb typeof_rec eval_rec,
      FPAlgebra (eval_alg_Soundness_P D V (E nat) WFV _ WF_eqv_environment_P (E (typeofR D)) pb typeof_rec eval_rec
        (f_algebra TypeofName (FAlgebra := Typeof_E _)) (f_algebra EvalName (FAlgebra := beval_E))) (inject2 NP _ _)}.

    Variable WF_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot D V) WFV.

    Inductive eqv_eval_SoundnessName : Set := eqv_eval_soundnessname.

    Context {Typeof_NP : forall T, FAlgebra TypeofName T (typeofR D) NP}.
    Context {beval_NP : FAlgebra EvalName (Fix (E nat)) (evalR V) NP}.
    Context {WF_eval_F : @WF_FAlgebra EvalName _ _ NP (E _)
      (sub_NP_F _) beval_NP (eval_E _)}.
    Context {WF_typeof_F : @WF_FAlgebra TypeofName _ _ NP (E _)
      (sub_NP_F _) (Typeof_NP _) (Typeof_E (Fix (E (typeofR D))))}.

    Global Instance eqv_eval_Soundness typeof_rec eval_rec :
      iPAlgebra eqv_eval_SoundnessName
      (eqv_eval_alg_Soundness'_P typeof_rec eval_rec
        (f_algebra TypeofName (FAlgebra := Typeof_E _))
        (f_algebra EvalName (FAlgebra := beval_E))) (NP_Functor_eqv _ _ _).
    Proof.
      constructor; unfold iAlgebra; intros.
      apply (ind_alg_NP_Functor_eqv NP); try eassumption;
        unfold eqv_eval_alg_Soundness'_P; simpl; intros.
      (* NP_eqv_0 *)
      split.
      apply inject_i; econstructor; eauto.
      rewrite e_eq, e'_eq.
      generalize (p_algebra (FPAlgebra := eval_Soundness_alg_NP (gamma, gamma') typeof_rec eval_rec) (np _)).
      unfold inject2.
      rewrite (wf_np _ _ _ (@fst (Fix (E (typeofR D))) (Fix (E nat))) id).
      rewrite (wf_np _ _ _ (@snd (Fix (E (typeofR D))) (Fix (E nat))) id).
      repeat rewrite fmap_id.
      intros H0; apply H0.
      apply np_all.
      (* NP_eqv_1 *)
      destruct IHa as [eqv_a IHa]; split; intros.
      apply inject_i; econstructor 2; eauto.
      rewrite e_eq, e'_eq.
      generalize (p_algebra (FPAlgebra := eval_Soundness_alg_NP (gamma, gamma') typeof_rec eval_rec) (np _ (a,a'))).
      unfold inject2.
      rewrite (wf_np _ _ _ (@fst (Fix (E (typeofR D))) (Fix (E nat))) id _ a); auto.
      rewrite (wf_np _ _ _ (@snd (Fix (E (typeofR D))) (Fix (E nat))) id _ a'); auto.
      repeat rewrite fmap_id.
      intros H0; apply H0.
      apply np_all; auto.
      (* NP_eqv_2 *)
      destruct IHa as [a_eqv IHa]; destruct IHb as [b_eqv IHb].
      split; intros.
      apply inject_i; econstructor 3; eauto.
      rewrite e_eq, e'_eq.
      generalize (p_algebra (FPAlgebra := eval_Soundness_alg_NP (gamma, gamma') typeof_rec eval_rec) (np _ (a,a') (b,b'))).
      unfold inject2.
      rewrite (wf_np _ _ _ (@fst (Fix (E (typeofR D))) (Fix (E nat))) id _ _ a b); auto.
      rewrite (wf_np _ _ _ (@snd (Fix (E (typeofR D))) (Fix (E nat))) id _ _ a' b'); auto.
      repeat rewrite fmap_id.
      intros H0; apply H0.
      apply np_all; auto.
      (* NP_eqv_3 *)
      destruct IHa as [a_eqv IHa]; destruct IHb as [b_eqv IHb]; destruct IHc as [c_eqv IHc].
      split; intros.
      apply inject_i; econstructor 4; eauto.
      rewrite e_eq, e'_eq.
      generalize (p_algebra (FPAlgebra := eval_Soundness_alg_NP (gamma, gamma') typeof_rec eval_rec) (np _ (a,a') (b,b') (c,c'))).
      unfold inject2.
      rewrite (wf_np _ _ _ (@fst (Fix (E (typeofR D))) (Fix (E nat))) id _ _ _ a b c); auto.
      rewrite (wf_np _ _ _ (@snd (Fix (E (typeofR D))) (Fix (E nat))) id _ _ _ a' b' c'); auto.
      repeat rewrite fmap_id.
      intros H0; apply H0.
      apply np_all; auto.
    Qed.

    Context {eqv_eval_soundness_alg : forall typeof_rec eval_rec,
      iPAlgebra eqv_eval_SoundnessName
      (eqv_eval_alg_Soundness'_P
        typeof_rec eval_rec
        (f_algebra TypeofName (FAlgebra := Typeof_E _))
        (f_algebra EvalName (FAlgebra := eval_E _))) (EQV_E _ _)}.

    Definition eqv_eval_soundness_P (i : eqv_i (typeofR D) nat) :=
      forall (gamma'' : Env _)
        (WF_gamma : forall n b, lookup (env_B _ _ i) n = Some b ->
          exists T, lookup (env_A _ _ i) b = Some T)
        (WF_gamma2 : List.length (env_A _ _ i) = List.length (env_B _ _ i))
        (WF_gamma' : forall n b, lookup (env_B _ _ i) n = Some b -> b = n)
        (WF_gamma'' : WF_Environment _ _ WFV gamma'' (env_A _ _ i)) T,
        typeof _ _ (eqv_a _ _ i) = Some T ->
        WFValueC _ _ WFV (eval (eval_E := eval_E)
          V _ (eqv_b _ _ i) gamma'') T.

    Variable (WF_MAlg_typeof : WF_MAlgebra Typeof_E).
    Variable (WF_MAlg_eval : WF_MAlgebra eval_E).

    Lemma eqv_eval_soundness' : forall gamma gamma' e' e'',
      E_eqvC EQV_E gamma gamma' e' e'' ->
      eqv_eval_soundness_P (mk_eqv_i _ _ gamma gamma' e' e'').
    Proof.
      intros; generalize (ifold_
        (if_algebra (iPAlgebra := eqv_eval_soundness_alg
          (fun e => typeof D (E (typeofR D)) e)
          (fun e => eval V (E nat) e))) (mk_eqv_i _ _ gamma gamma' e' e'') H).
      unfold eqv_eval_alg_Soundness'_P, eqv_eval_soundness_P; simpl;
        intros.
      revert H1.
      rewrite <- (in_out_inverse e'').
      unfold eval.
      rewrite fold_computation.
      rewrite wf_malgebra.
      unfold id at 1; simpl.
      unfold eval_alg_Soundness_P in H0.
      intros; eapply H0; unfold WF_eqv_environment_P.
      split; eauto.
      intros.
      unfold eval.
      revert H3.
      rewrite <- (in_out_inverse (fst a)).
      unfold typeof.
      rewrite fold_computation, wf_malgebra.
      unfold id at 1; simpl.
      intros.
      destruct a as [a1 a2]; simpl.
      rewrite <- (in_out_inverse a2).
      rewrite fold_computation, wf_malgebra.
      unfold id at 1; simpl.
      apply H2.
      apply H3.
      unfold typeof in H1.
      rewrite <- (in_out_inverse e'), fold_computation, wf_malgebra in H1.
      apply H1.
    Qed.

    Lemma eqv_eval_soundness : forall gamma gamma' e' e'',
        E_eqvC EQV_E gamma gamma' e' e'' ->
      forall (gamma'' : Env _)
        (WF_gamma : forall n b, lookup (gamma') n = Some b ->
          exists T, lookup (gamma) b = Some T)
        (WF_gamma2 : List.length (gamma) = List.length (gamma'))
        (WF_gamma' : forall n b, lookup (gamma') n = Some b -> b = n)
        (WF_gamma'' : WF_Environment _ _ WFV gamma'' (gamma)) T,
        typeof _ _ e' = Some T ->
        WFValueC _ _ WFV (eval (eval_E := eval_E)
          V _ e'' gamma'') T.
    Proof.
      intros; eapply eqv_eval_soundness'; eauto.
    Qed.

    Definition soundness_X'_P
      (typeof_rec : Fix (E (typeofR D)) -> typeofR D)
      (eval_rec : Fix (E nat) -> evalR V)
      (typeof_F : Mixin (Fix (E (typeofR D))) (E (typeofR D)) (typeofR D))
      (eval_F : Mixin (Fix (E nat)) (E nat) (evalR V))
      i :=
      forall (IH : forall (e : Fix _) (e' : Fix _)
        pb gamma'' (WF_gamma'' : WF_eqv_environment_P pb gamma'')
        T,
        E_eqvC EQV_E (fst pb) (snd pb) e e' ->
        typeof_rec e = Some T ->
        WFValueC _ _ WFV (eval_rec e' gamma'') T),
      E_eqv EQV_E _ _ i /\
      eval_alg_Soundness_P D V (E nat) WFV
      _ WF_eqv_environment_P
      (E (typeofR D)) (env_A _ _ i, env_B _ _ i) typeof_rec eval_rec
      typeof_F eval_F
      (eqv_a _ _ i, eqv_b _ _ i).

    Inductive soundness_XName : Set := soundness_Xname.

    Global Instance Lift_soundness_X_alg
      typeof_rec eval_rec typeof_alg eval_alg
      EQV_G {fun_EQV_G : iFunctor EQV_G}
      {EQV_G_EQV_Alg : iPAlgebra eqv_eval_SoundnessName
        (eqv_eval_alg_Soundness'_P typeof_rec eval_rec typeof_alg eval_alg) EQV_G} :
        iPAlgebra soundness_XName
        (soundness_X'_P
          typeof_rec eval_rec typeof_alg eval_alg) EQV_G.
      intros; econstructor; generalize (if_algebra); unfold iAlgebra; intros.
      unfold soundness_X'_P; intros.
      assert (EQV_G (eqv_eval_alg_Soundness'_P typeof_rec eval_rec typeof_alg eval_alg) i).
      eapply ifmap; try eapply H0.
      intros; apply H1; apply IH.
      apply (H _ H1).
    Defined.

    Context {soundness_X_alg : forall eval_rec,
      iPAlgebra soundness_XName
      (soundness_X'_P
        (typeof _ _) eval_rec
        (f_algebra TypeofName (FAlgebra := Typeof_E _))
        (f_algebra EvalName (FAlgebra := beval_E))) (EQV_E _ _)}.
    Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV.

    Definition soundness_X_P (i : eqv_i (typeofR D) nat) :=
      forall n (gamma'' : Env _)
        (WF_gamma : forall n b, lookup (env_B _ _ i) n = Some b ->
          exists T, lookup (env_A _ _ i) b = Some T)
        (WF_gamma2 : List.length (env_A _ _ i) = List.length (env_B _ _ i))
        (WF_gamma' : forall n b, lookup (env_B _ _ i) n = Some b -> b = n)
        (WF_gamma'' : WF_Environment _ _ WFV gamma'' (env_A _ _ i)) T,
        typeof _ _ (eqv_a _ _ i) = Some T ->
        WFValueC _ _ WFV (beval V (E _) n (beval_E := beval_E)
          (eqv_b _ _ i) gamma'') T.

    Lemma soundness_X' :
      forall eval_rec gamma gamma' e' e'',
        E_eqvC EQV_E gamma gamma' e' e'' ->
        soundness_X'_P (typeof _ _) eval_rec
        (f_algebra TypeofName (FAlgebra := Typeof_E _))
        (f_algebra EvalName (FAlgebra := beval_E)) (mk_eqv_i _ _ gamma gamma' e' e'').
    Proof.
      intros; apply (ifold_); try assumption.
      apply if_algebra.
    Qed.

    Variable SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop.
    Context `{ispf_SV : iSPF _ SV}.
    Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}.
    Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}.

    Context {WF_Value_continous_alg :
      iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}.
    Context {eval_continuous_Exp_E : FPAlgebra
       (eval_continuous_Exp_P V (E nat) SV) (inject (E nat) (E nat))}.

    Lemma soundness_X :
      forall n gamma gamma' gamma'' e' e'',
        E_eqvC EQV_E gamma gamma' e' e'' ->
        forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
          exists T, lookup gamma b = Some T)
        (WF_gamma2 : List.length gamma = List.length gamma')
        (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
        (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
        typeof _ _ e' = Some T ->
        WFValueC _ _ WFV (beval V (E _) n (beval_E := beval_E)
          e'' gamma'') T.
    Proof.
      induction n; simpl;
          intros; unfold beval; simpl in *|-*.
      apply (inject_i (subGF := Sub_WFV_Bot_WFV)); econstructor; eauto.
      generalize (soundness_X' (beval V (E _) n) _ _ _ _ H).
      unfold soundness_X'_P;
        unfold eval_alg_Soundness_P; simpl; intros.
      apply H1; auto.
      unfold beval; intros;
      destruct WF_gamma''0 as [WF_pb [WF_pb2 [WF_pb' WF_gamma''0]]].
      eapply IHn; eauto.
      repeat split; auto.
      intros.
      destruct a as [a a'].
      simpl in *|-*.
      apply (WF_Value_beval D V (E _) SV _ WFV n (S n) _ gamma''0); auto.
      apply Sub_Environment_refl; auto.
      apply H2.
      unfold typeof in H3.
      rewrite <- (in_out_inverse a) in H3.
      rewrite fold_computation, wf_malgebra in H3.
      unfold id at 1 in H3; simpl in H3; try rewrite <- eta_expansion in H3.
      unfold typeof.
      apply H3.
      unfold typeof in H0.
      rewrite <- (in_out_inverse e') in H0.
      rewrite fold_computation, wf_malgebra in H0.
      unfold id at 1 in H0; simpl in H0; try rewrite <- eta_expansion in H0.
      apply H0.
    Qed.

  End NP_beval_Soundness.

End PNames.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D T X Y : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ A D /\ (wd_ A T /\ (wd_ B C /\ (wd_ B D /\ (wd_ B T /\ (wd_ C D /\ (wd_ C T /\ (wd_ D T /\ (wd_ A Y /\ (wd_ A X /\ (wd_ T Y /\ (wd_ Y C /\ (wd_ Y D /\ (wd_ T X /\ (wd_ X B /\ (wd_ X D /\ (col_ X T Y /\ (col_ A X Y /\ (col_ A C Y /\ (col_ A B X /\ (col_ B D C /\ col_ A D T))))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus Zero lv0) (mult lv1 Zero)).
Admitted.
QuickChick conj5synthconj2.