Require Import Metalib.Metatheory.
Require Import Infrastructure.
Require Import Disjoint.
Require Import Syntax_ott.
Require Import Row_Intuitive_Syntax.
Require Import Row_Intuitive_Inf.

(* ********************************************************************** *)
(** * Auxiliary definitions *)
(* ********************************************************************** *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let C3 := gather_atoms_with (fun x : stctx => dom x) in
  let C4 := gather_atoms_with (fun x : sctx => dom x) in
  let D4 := gather_atoms_with (fun x => fv_sty_in_sty x) in
  let D5 := gather_atoms_with (fun x => fv_sty_in_sexp x) in
  let D6 := gather_atoms_with (fun x => fv_sexp_in_sexp x) in
  let E1 := gather_atoms_with (fun x : TContext => dom x) in
  let E2 := gather_atoms_with (fun x : GContext => dom x) in
  let E3 := gather_atoms_with (fun x  => fv_rexp_in_rexp x) in
  let E4 := gather_atoms_with (fun x  => fv_rtyp_in_rexp x) in
  let E5 := gather_atoms_with (fun x  => fv_rtyp_in_rtyp x) in
  let E6 := gather_atoms_with (fun x  => fv_rtyp_in_rt x) in
  let E7 := gather_atoms_with (fun x  => fv_rtyp_in_rlist x) in
  constr:(A \u B \u C3 \u C4 \u D4 \u D5 \u D6 \u E1 \u E2 \u E3 \u E4 \u E5 \u E6 \u E7).

Definition trans_Ttx T := map trans_rlist  T.

Definition trans_Gtx G := map trans_rt G.

Lemma trans_open_rt_wrt_rtyp_rec : forall A B n,
    trans_rt ( open_rt_wrt_rtyp_rec n B A ) = open_sty_wrt_sty_rec n (trans_rtyp B ) (trans_rt A )

with

trans_open_rlist_wrt_rtyp_rec : forall R A n,
    trans_rlist (open_rlist_wrt_rtyp_rec n A R) =  open_sty_wrt_sty_rec n (trans_rtyp A) (trans_rlist R)

with

trans_open_rtyp_wrt_rtyp_rec : forall A B m,
    trans_rtyp ( open_rtyp_wrt_rtyp_rec m B A ) = open_sty_wrt_sty_rec m (trans_rtyp B ) (trans_rtyp A ).

Proof with eauto.
  - Case "rt".
    intros A.
    induction A; intros B n; simpls...

    rewrite IHA1...
    rewrite IHA2...

    rewrite trans_open_rlist_wrt_rtyp_rec...
    rewrite IHA...

  - Case "rlist".

    intros R.
    induction R; intros A n; simpls...

    rewrite trans_open_rtyp_wrt_rtyp_rec...
    rewrite IHR...

  - Case "rtyp".

    intros A.
    induction A; intros B m; simpls...

    destruct (lt_eq_lt_dec n m)...
    destruct s...

    rewrite trans_open_rt_wrt_rtyp_rec...
    rewrite trans_open_rtyp_wrt_rtyp_rec...
    rewrite trans_open_rtyp_wrt_rtyp_rec...
Qed.

Lemma trans_open_rt_wrt_rtyp : forall t1 t2,
    trans_rt (open_rt_wrt_rtyp t1 t2) = open_sty_wrt_sty (trans_rt t1) (trans_rtyp t2).
Proof.
  intros.
  unfold open_rt_wrt_rtyp.
  unfold open_sty_wrt_sty.
  rewrite trans_open_rt_wrt_rtyp_rec.
  reflexivity.
Qed.

Lemma wfr_lc : forall T r,
    wfr T r ->
    lc_rtyp r

with

wfrt_lc : forall T t,
    wfrt T t ->
    lc_rt t

with

wfcl_lc : forall T R,
    wfcl T R ->
    lc_rlist R.
Proof with eauto.
  - Case "wft".
    introv WFR.
    induction WFR.

    constructor.
    constructor...
    constructor.
    constructor...

  - Case "wfrt".
    introv WFT.
    induction WFT.
    constructor.
    constructor...
    pick fresh a.
    specializes H1; auto.
    eapply lc_rt_ConQuan_exists...
    constructor...

  - Case "wfcl".
    introv WFCL.
    induction WFCL.
    constructor.
    constructor...
Qed.

Lemma wftc_uniq : forall T,
    wftc T ->
    uniq T.
Proof with eauto.
  intros T.
  alist induction T; intros; simpls...
  inverts H...
Qed.

Lemma trans_lc_typ : forall t,
    lc_rt t ->
    lc_sty (trans_rt t)

with

trans_lc_rlist : forall R,
    lc_rlist R ->
    lc_sty (trans_rlist R)

with

trans_lc_rty : forall r,
    lc_rtyp r ->
    lc_sty (trans_rtyp r).

Proof with eauto.
  - Case "typ".
    introv LC.
    induction LC; simpls...

    pick fresh X.
    apply lc_sty_all_exists with X...
    replace (sty_var_f X) with (trans_rtyp (r_TyVar_f X))...
    rewrite <- trans_open_rt_wrt_rtyp...

  - Case "rtyp".
    introv LC.
    induction LC; simpls...

  - Case "rlist".
    introv LC.
    induction LC; simpls...
Qed.

Hint Resolve wfr_lc wfrt_lc wftc_uniq.

Hint Constructors has_type.

Lemma notin_rtyp_sty : forall A X,
    X `notin` fv_rtyp_in_rt A ->
    X `notin` fv_sty_in_sty (trans_rt A )

with

notin_rtyp_rlist : forall R X,
    X `notin` fv_rtyp_in_rlist R ->
    X `notin` fv_sty_in_sty (trans_rlist R)

with

notin_rtyp_rtyp : forall r X,
    X `notin` fv_rtyp_in_rtyp r ->
    X `notin` fv_sty_in_sty (trans_rtyp r).

Proof with eauto.

  - Case "typ".

    intros A.
    induction A; introv Notin; simpls...

  - Case "rlist".

    intros R.
    induction R; introv Notin; simpls...

  - Case "rtyp".

    intros r.
    induction r; introv Notin; simpls...

Qed.

(* ********************************************************************** *)
(** * Type safety lemmas *)
(* ********************************************************************** *)

Inductive wtt : TContext -> GContext -> rexp -> rt -> sexp -> Prop :=    (* defn wtt *)
 | wtt_Eq : forall (Ttx:TContext) (Gtx:GContext) (re:rexp) (rt':rt) (ee:sexp) (rt5:rt),
     wtt Ttx Gtx re rt5 ee ->
     teq Ttx rt5 rt' ->
     wtt Ttx Gtx re rt' (sexp_anno ee (trans_rt rt'))
 | wtt_Var : forall (Ttx:TContext) (Gtx:GContext) (x:expvar) (rt5:rt),
     wftc Ttx ->
     wfc Ttx Gtx ->
     binds  x   rt5   Gtx  ->
     wtt Ttx Gtx (re_Var_f x) rt5 (sexp_var_f x)
 | wtt_Lit : forall (Ttx:TContext) (Gtx:GContext) (x:nat),
     wftc Ttx ->
     wfc Ttx Gtx ->
     wtt Ttx Gtx (re_Lit x) rt_Base (sexp_lit x)
 | wtt_ArrowI : forall (L:vars) (Ttx:TContext) (Gtx:GContext) (rt5:rt) (re:rexp) (rt':rt) (ee:sexp),
     wfrt Ttx rt5 ->
      ( forall x , x \notin  L  -> wtt Ttx  (( x ~ rt5 )++ Gtx )   ( open_rexp_wrt_rexp re (re_Var_f x) )  rt'  ( open_sexp_wrt_sexp ee (sexp_var_f x) )  )  ->
      wtt Ttx Gtx (re_Abs rt5 re) (rt_Fun rt5 rt')
          (sexp_anno  ( (sexp_abs ee) )  (sty_arrow  (trans_rt rt5) (trans_rt rt') ))
 | wtt_ArrowE : forall (Ttx:TContext) (Gtx:GContext) (re1 re2:rexp) (rt':rt) (ee1 ee2:sexp) (rt5:rt),
     wtt Ttx Gtx re1 (rt_Fun rt5 rt') ee1 ->
     wtt Ttx Gtx re2 rt5 ee2 ->
     wtt Ttx Gtx (re_App re1 re2) rt' (sexp_app ee1 ee2)
 | wtt_Base : forall (Ttx:TContext) (Gtx:GContext) (l:i) (re:rexp) (rt5:rt) (ee:sexp),
     wtt Ttx Gtx re rt5 ee ->
     wtt Ttx Gtx (re_SingleField l re) (rt_Record (r_SingleField l rt5)) (sexp_rcd l ee)
 | wtt_Empty : forall (Ttx:TContext) (Gtx:GContext),
     wftc Ttx ->
     wfc Ttx Gtx ->
     wtt Ttx Gtx re_Empty (rt_Record r_Empty) sexp_top
 | wtt_Merge : forall (Ttx:TContext) (Gtx:GContext) (re1 re2:rexp) (r1 r2:rtyp) (ee1 ee2:sexp),
     wtt Ttx Gtx re1 (rt_Record r1) ee1 ->
     wtt Ttx Gtx re2 (rt_Record r2) ee2 ->
     cmp Ttx r1 r2 ->
     wtt Ttx Gtx (re_Merge re1 re2) (rt_Record (r_Merge r1 r2)) (sexp_merge ee1 ee2)
 | wtt_Restr : forall (Ttx:TContext) (Gtx:GContext) (re:rexp) (l:i) (r:rtyp) (ee:sexp) (rt5:rt),
     wtt Ttx Gtx re (rt_Record (r_Merge (r_SingleField l rt5) r)) ee ->
     wtt Ttx Gtx (re_Res re l) (rt_Record r) (sexp_anno ee  (trans_rtyp r) )
 | wtt_Select : forall (Ttx:TContext) (Gtx:GContext) (re:rexp) (l:i) (rt5:rt) (ee:sexp) (r:rtyp),
     wtt Ttx Gtx re (rt_Record (r_Merge (r_SingleField l rt5) r)) ee ->
     wtt Ttx Gtx (re_Selection re l) rt5 (sexp_proj  ( (sexp_anno ee (sty_rcd l  (trans_rt rt5) )) )  l)

 | wtt_AllI : forall (L:vars) (Ttx:TContext) (Gtx:GContext) (R:rlist) (re:rexp) (rt5:rt) (ee:sexp),
     wfc Ttx Gtx ->
     wfcl Ttx R ->
     ( forall a , a \notin  L  ->
             wtt  (( a ~ R )++ Ttx )  Gtx
                  ( open_rexp_wrt_rtyp re (r_TyVar_f a) )
                  ( open_rt_wrt_rtyp rt5 (r_TyVar_f a) )
                  (open_sexp_wrt_sty ee (sty_var_f a))  ) ->
     wtt Ttx Gtx (re_ConTyAbs R re) (rt_ConQuan R rt5) (sexp_tabs (trans_rlist R)  ee)

 | wtt_AllE : forall (Ttx:TContext) (Gtx:GContext) (re:rexp) (r:rtyp) (rt5:rt) (ee:sexp) (R:rlist),
     wtt Ttx Gtx re (rt_ConQuan R rt5) ee ->
     cmpList Ttx r R ->
     wtt Ttx Gtx (re_ConTyApp re r)  (open_rt_wrt_rtyp  rt5   r )  (sexp_tapp ee (trans_rtyp r)) .

Section type_safe_trans.

  (* These are internal properties of Harper's system *)
  Variable cmp_regular : forall T r r',
    cmp T r r' ->
    wfr T r /\ wfr T r'.

  Variable wtt_regular : forall T G e1 t E,
    wtt T G e1 t E ->
    wfrt T t /\ wftc T.

  Lemma cmp_list_regular : forall T r R,
      cmpList T r R ->
      wftc T ->
      wfr T r /\ wfcl T R.
    Proof with eauto.
      introv CMP.
      induction CMP; introv WFTC; splits; simpls...
      forwards (? & ?) : cmp_regular H...
      forwards (? & ?) : cmp_regular H...
      forwards (? & ?) : IHCMP WFTC...
    Qed.

  Lemma wfcl_to_swft : forall T R,
      wfcl T R ->
      swft (trans_Ttx T) (trans_rlist R)
  with

  wfr_to_swft : forall T r,
      wfr T r ->
      swft (trans_Ttx T) (trans_rtyp r)

  with

  wft_to_swft :forall T t,
      wfrt T t ->
      swft (trans_Ttx T) (trans_rt t).

  Proof with eauto.
    - Case "wfcl_to_swft".

      introv WFCL.

      induction WFCL.

      + SCase "empty".
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

      + SCase "rl_rtyp".
        forwards : wfr_to_swft H.
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

    - Case "wfr_to_swft".

      introv WFR.

      induction WFR.

      + SCase "var".
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls.
        econstructor.
        eapply binds_map_2...

      + SCase "record".
        forwards : wft_to_swft H.
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

      + SCase "empty".
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

      + SCase "restrict".
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

    - Case "wft_to_swft".

      introv WFT.

      induction WFT.

      + SCase "base".
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

      + SCase "arrow".
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...

      + SCase "forall".
        forwards : wfcl_to_swft H.
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls.
        pick fresh X and apply swft_all...
        replace (sty_var_f X) with (trans_rtyp (r_TyVar_f X))...
        rewrite <- trans_open_rt_wrt_rtyp...

      + SCase "record".
        forwards : wfr_to_swft H.
        clear wfr_to_swft wft_to_swft wfcl_to_swft.
        simpls...
  Qed.

  Lemma wftc_to_swfte : forall T,
      wftc T ->
      swfte (trans_Ttx T).
  Proof with eauto.
    introv WFTC.

    induction WFTC; simpls...

    forwards : wfcl_to_swft H.

    econstructor...
    unfold trans_Ttx...
  Qed.

  Lemma wfc_to_swfe : forall T G,
      wfc T G ->
      swfe (trans_Ttx T) (trans_Gtx G).
  Proof with eauto using wft_to_swft.
    introv H.
    induction H; simpls...
    constructor...
    unfold trans_Gtx...
    unfold trans_Ttx...
  Qed.

  Lemma teq_csub : forall T t t',
      teq T t t' ->
      uniq T ->
      sub (trans_Ttx T) (trans_rt t) (trans_rt t') /\
      sub (trans_Ttx T) (trans_rt t') (trans_rt t)

  with

  ceq_csub: forall T R R',
      ceq T R R' ->
      uniq T ->
      sub (trans_Ttx T) (trans_rlist R) (trans_rlist R') /\
      sub (trans_Ttx T) (trans_rlist R') (trans_rlist R).

  Proof with eauto using wft_to_swft, wfr_to_swft, wfcl_to_swft, notin_rtyp_sty.

    - Case "teq".
      introv Eq.
      induction Eq; introv Uniq.

      + SCase "refl".
        clear teq_csub ceq_csub.
        splits...

      + SCase "sym".
        clear teq_csub ceq_csub.
        destruct IHEq...

      + SCase "trans".
        clear teq_csub ceq_csub.

        destruct (IHEq1 Uniq) as (Sub1 & Sub2).
        destruct (IHEq2 Uniq) as (Sub3 & Sub4).

        splits...

      + SCase "arrow".
        clear teq_csub ceq_csub.

        simpls.

        destruct (IHEq1 Uniq) as (Sub1 & Sub2).
        destruct (IHEq2 Uniq) as (Sub3 & Sub4).

        splits...

      + SCase "typ_all".
        simpls.
        splits.

        pick fresh a.
        forwards ( Sub1 & Sub2) : H1 a; auto.
        forwards (? & ?) : ceq_csub H; auto.
        rewrite trans_open_rt_wrt_rtyp in *.
        rewrite trans_open_rt_wrt_rtyp in *.
        pick fresh b and apply S_forall; eauto.
        apply sub_renaming with (X := a)...
        unfold trans_Ttx; eauto.
        unfold trans_Ttx; eauto.
        rewrite_env (nil ++ [(a, trans_rlist R')] ++ trans_Ttx Ttx).
        apply sub_narrow with (Q := trans_rlist R); auto.
        simpls...
        unfold trans_Ttx; eauto.

        pick fresh a.
        forwards (Sub1 & Sub2) : H1 a; auto.
        forwards (? & ?) : ceq_csub H; auto.
        rewrite trans_open_rt_wrt_rtyp in *.
        rewrite trans_open_rt_wrt_rtyp in *.
        pick fresh b and apply S_forall; eauto.
        apply sub_renaming with (X := a)...
        unfold trans_Ttx; eauto.
        unfold trans_Ttx; eauto.

      + SCase "base".
        forwards (? & ?) : teq_csub Eq; try assumption.
        clear teq_csub ceq_csub.

        simpls; splits...

      + SCase "merge".
        clear teq_csub ceq_csub.
        destruct (IHEq1 Uniq).
        destruct (IHEq2 Uniq).

        simpls; splits.

        eapply S_and.
        apply S_trans with (trans_rtyp r1)...
        apply S_trans with (trans_rtyp r2)...

        eapply S_and.
        apply S_trans with (trans_rtyp r1')...
        apply S_trans with (trans_rtyp r2')...

      + SCase "merge_unit".
        clear teq_csub ceq_csub.

        simpls; splits...

        eapply S_and...

      + SCase "merge_assoc".
        clear teq_csub ceq_csub.
        forwards (? & ?): cmp_regular H.
        forwards (? & ?): cmp_regular H0.
        simpls; splits.

        eapply S_and.
        eapply S_and.
        eapply S_andl...
        apply S_trans with ((sty_and (trans_rtyp r2) (trans_rtyp r3)))...
        eapply S_andr...
        apply S_trans with ((sty_and (trans_rtyp r2) (trans_rtyp r3)))...
        eapply S_andr...

        eapply S_and.
        apply S_trans with ((sty_and (trans_rtyp r1) (trans_rtyp r2)))...
        eapply S_andl...
        eapply S_and.
        apply S_trans with ((sty_and (trans_rtyp r1) (trans_rtyp r2)))...
        eapply S_andl...
        eapply S_andr...

      + SCase "merge_comm".
        clear teq_csub ceq_csub.
        forwards (? & ?): cmp_regular H.

        simpls; splits.

        eapply S_and...
        eapply S_and...

    - Case "ceq".

      introv Eq.
      induction Eq; introv Uniq.

      + SCase "refl".

        clear teq_csub ceq_csub.

        splits...

      + SCase "sym".
        clear teq_csub ceq_csub.

        destruct (IHEq Uniq).
        splits...

      + SCase "trans".
        clear teq_csub ceq_csub.

        destruct (IHEq1 Uniq) as (Sub1 & Sub2).
        destruct (IHEq2 Uniq) as (Sub3 & Sub4).

        splits...

      + SCase "inner".

        lets (? & ?) : teq_csub H; try assumption.
        clear teq_csub ceq_csub.

        destruct (IHEq Uniq) as (Sub1 & Sub2).
        simpls.
        splits.

        eapply S_and.
        apply S_trans with ((trans_rtyp r))...
        apply S_trans with ((trans_rlist R))...

        eapply S_and.
        apply S_trans with ((trans_rtyp r))...
        apply S_trans with ((trans_rlist R))...

      + SCase "swap".
        clear teq_csub ceq_csub.

        simpls.
        splits.

        eapply S_and.
        apply S_trans with ((sty_and (trans_rtyp r') (trans_rlist R)))...
        eapply S_andr...
        eapply S_and.
        eapply S_andl...
        apply S_trans with ((sty_and (trans_rtyp r') (trans_rlist R)))...
        eapply S_andr...

        eapply S_and.
        apply S_trans with ((sty_and (trans_rtyp r) (trans_rlist R)))...
        eapply S_andr...
        eapply S_and.
        eapply S_andl...
        apply S_trans with ((sty_and (trans_rtyp r) (trans_rlist R)))...
        eapply S_andr...

      + SCase "empty".
        clear teq_csub ceq_csub.
        simpls.
        splits...

        eapply S_and...

      + SCase "merge".
        clear teq_csub ceq_csub.

        simpls.
        inverts H.
        splits.

        eapply S_and.
        apply S_trans with ((sty_and (trans_rtyp r1) (trans_rtyp r2)))...
        eapply S_andl...
        eapply S_and.
        apply S_trans with ((sty_and (trans_rtyp r1) (trans_rtyp r2)))...
        eapply S_andl...
        eapply S_andr...

        eapply S_and.
        eapply S_and.
        eapply S_andl...
        apply S_trans with ((sty_and (trans_rtyp r2) (trans_rlist R)))...
        eapply S_andr...
        apply S_trans with ((sty_and (trans_rtyp r2) (trans_rlist R)))...
        eapply S_andr...

      + SCase "dupl".
        clear teq_csub ceq_csub.

        simpls; splits.

        eapply S_and.
        eapply S_andl...
        apply S_trans with ((sty_and (trans_rtyp r) (trans_rlist R)))...
        eapply S_andr...

        eapply S_and.
        eapply S_andl...
        apply S_trans with ((sty_and (trans_rtyp r) (trans_rlist R)))...

      + SCase "base".
        forwards (? & ?) : teq_csub H2; try assumption.
        clear teq_csub ceq_csub.

        simpls; splits.

        eapply S_and.
        eapply S_trans with ((sty_rcd l (trans_rt rt5)))...
        eapply S_andr...

        eapply S_and.
        apply S_trans with ((sty_rcd l (trans_rt rt')))...
        eapply S_andr...

  Qed.

  Lemma rtyp_in_rlist_sub: forall T r R,
      rtyp_in_rlist r R ->
      wfcl T R ->
      wfr T r ->
      sub (trans_Ttx T) (trans_rlist R) (trans_rtyp r).
  Proof with eauto using wfcl_to_swft, wfr_to_swft, wfr_to_swft.
    introv Rlst.
    induction Rlst; introv WFCL WFT; simpls...

    inverts WFCL.

    eapply S_andl...

    inverts WFCL.
    specializes IHRlst...
  Qed.

  Lemma cmp_disjoint : forall T r r',
      cmp T r r' ->
      wftc T ->
      disjoint (trans_Ttx T) (trans_rtyp r) (trans_rtyp r').
  Proof with eauto using wft_to_swft, wfr_to_swft, wftc_to_swfte.
    introv CMP.

    induction CMP; introv Uniq; simpls...

    - Case "eq".
      assert (uniq (trans_Ttx Ttx)).
      unfold trans_Ttx...
      lets (? & ?) : teq_csub H...
      lets (? & ?) : teq_csub H0...
      specializes IHCMP Uniq.
      eapply disjoint_symmetric in IHCMP...
      forwards HH3 : disjoint_sub IHCMP...
      eapply disjoint_symmetric in HH3...
      eapply disjoint_sub...

    - Case "symm".
      specializes IHCMP Uniq.
      eapply disjoint_symmetric...
      unfold trans_Ttx...

    - Case "tvar".
      forwards ? : rtyp_in_rlist_sub H0...
      unfolds trans_Ttx...

    - Case "mergeE1".
      specializes IHCMP Uniq.
      eapply disjoint_and in IHCMP...
      destruct IHCMP...
      forwards (? & ?): cmp_regular CMP...

    - Case "mergeE2".
      specializes IHCMP Uniq.
      eapply disjoint_and in IHCMP...
      destruct IHCMP...
      forwards (? & ?): cmp_regular CMP...

  Qed.

  Lemma cmp_list_disjoint : forall T r R,
      cmpList T r R ->
      wftc T ->
      disjoint (trans_Ttx T) (trans_rtyp r) (trans_rlist R).
  Proof with eauto using wfr_to_swft, cmp_disjoint.
    introv CMP.
    induction CMP; introv Uniq; simpls...
  Qed.

  Theorem type_safe : forall T G e t E,
      wtt T G e t E ->
      has_type (trans_Ttx T) (trans_Gtx G) E Inf (trans_rt t).
  Proof with eauto using wft_to_swft, wfc_to_swfe, wftc_to_swfte, cmp_disjoint, wfcl_to_swft, wfr_to_swft, cmp_list_disjoint.

    introv WTT.

    induction WTT; simpls...

    - Case "wtt_eq".
      lets (? & ?) : teq_csub...
      forwards (? & ?) : wtt_regular WTT...

    - Case "wtt_var".
      econstructor...
      eapply binds_map_2...

    - Case "wtt_abs".
      econstructor...

      pick fresh x and apply T_abs...
      forwards WTT : H0 x...
      forwards (? & ?) : wtt_regular WTT...
      forwards : H1 x...

    - Case "wtt_app".
      forwards (WFTC & ?) : wtt_regular WTT1...
      inverts WFTC...

      econstructor...

    - Case "wtt_merge".
      forwards (W & ?) : wtt_regular WTT1.
      inverts W.
      forwards (W & ?) : wtt_regular WTT2.
      inverts W.

      econstructor...

    - Case "wtt_restr".
      forwards (W & ?) : wtt_regular WTT.
      inverts W as W.
      inverts W as W.
      inverts W as W.

      econstructor.
      eapply T_sub...

    - Case "wtt_select".
      forwards (W & ?) : wtt_regular WTT.
      inverts W as W.
      inverts W as W.
      inverts W as W.
      econstructor...
      econstructor...
      eapply T_sub...

    - Case "wtt_tabs".
      pick fresh a and apply T_tabs...
      forwards : H1 a...
      replace (sty_var_f a) with (trans_rtyp (r_TyVar_f a))...
      rewrite <- trans_open_rt_wrt_rtyp...
      eapply H2...

    - Case "wtt_tapp".
      forwards (? & ?) : wtt_regular WTT.
      forwards (? & ?) : cmp_list_regular H...
      rewrite trans_open_rt_wrt_rtyp...
  Qed.

End type_safe_trans.


(** * Representing Erros.

    We use the sumor type to represent constructs in the verse
language that might be erroneous. This module developes the monadic
notation for it for ease of use in the rest of the program.

*)

Require Export Verse.Monad.
Global Notation "{- A -}" := (inleft A).
Global Notation "'error' A" := (inright A) (at level 40).

Section Error.
  Variable A   : Type.
  Variable Err : Prop.

  Definition TypeE := Type + {Err}.

  Definition inject (A : TypeE) : Type :=
    match A with
    | {- T -} => T
    | _       => Empty_set + {Err}
    end.

  Definition lift (fam : A -> Type) : A + {Err} -> Type
    := fun ae => inject (fam <$> ae).

  Section DependentApply.

    Variable fam : A -> Type.

    Definition apD (f : forall a, fam a) : forall y, lift fam y
      := fun y =>
           match y as y0 return lift fam y0 with
           | {- a -} => f a
           |  error e => error e
           end.

  End DependentApply.

  Definition recover (x : A + {Err}) : if x then A else Err
    := match x with
       | {- a -} => a
       | inright b => b
       end.

  Definition noErrorIsNotError {e : Err} {a : A}  : error e <> inleft a.
    intro pf.
    refine (match pf with
            |eq_refl => _
            end); exact idProp.
  Defined.

  Definition recover' (ae : A + {Err}) : (exists a, ae = inleft a) -> { a : A | ae = inleft a}
    := match ae as ae0 return (exists a, ae0 = {- a -}) -> {a | ae0 = {- a -} } with
       | inleft a  => fun _  => exist _ a eq_refl
       | inright _ =>
         let absurdity pf :=  match pf with
                              | ex_intro _ _ pf0 => noErrorIsNotError pf0
                              end in
         fun pf => False_rect _ (absurdity pf)
       end.

End Error.
Arguments recover' [A Err].

(* Type to capture translation error *)
Inductive TranslationError : Prop :=
| UpdatesNeedHostEndian
| UpdatesNotForRotatesInC
| ExplicitClobberNotInC
| CouldNotTranslate : forall A : Type, A -> TranslationError
| CouldNotTranslateBecause : forall A : Type, A -> TranslationError -> TranslationError.

Arguments  CouldNotTranslate [A].
Arguments  CouldNotTranslateBecause [A].

Notation "'updates' 'need' 'host' 'endian' 'lhs'"
  := UpdatesNeedHostEndian  (only printing).
Notation "'updates' 'with' 'rotates' 'not' 'supported' 'in' 'C'"
  := UpdatesNotForRotatesInC (only printing).
Notation "'explicit' 'clobber' 'not' 'supported' 'in' 'C'"
  := ExplicitClobberNotInC (only printing).
Notation "'could' 'not' 'translate' X"
  := (CouldNotTranslate  X) (at level 100, only printing).
Notation "'unable' 'to' 'translate' X 'because,' E"
  := (CouldNotTranslateBecause X E)
       ( at level 101, right associativity, only printing,
         format "'[v   ' 'unable'  'to'  'translate'  X  'because,' '/' E ']'"
       ).

Class Castable (E1 E2 : Prop) := { cast : E1 -> E2 }.

Instance idCast E : Castable E E := { cast := @id _ }.

Section Lifts.

  Variable T    : Type.
  Variable E E1 E2 : Prop.

  Variable E1toE : Castable E1 E.
  Variable E2toE : Castable E2 E.

  Definition liftErr (t : T + {E1}) : T + {E} :=
    match t with
    | {- t' -} => {- t' -}
    | error e  => error (cast e)
    end.

  Definition collectErr (t : T + {E1} + {E2}) : T + {E} :=
    match t with
    | error e2       => error (cast e2)
    | {- error e1 -} => error (cast e1)
    | {- {- t' -} -} => {- t' -}
    end.

End Lifts.

Arguments liftErr [T E E1 _] _.
Arguments collectErr [T E E1 E2 _ _] _.

Section Conditionals.

  (** Some type *)
  Variable A : Type.

  (** A decidable predicate on A *)
  Variable P : A -> Prop.

  (** The decision procedure for P *)
  Variable decP : forall a : A, {P a} + {~ P a}.

  (** Emit the value only whe the predicate is satisfied
   *)
  Definition when (a : A) : A + {~ P a} :=
    match decP a with
    | left _  => {- a -}
    | right err => error err
    end.

  (** Emit the value unless the predicate is true. *)
  Definition unless (a : A ) : A + {P a} :=
    match decP a with
    | left err => error err
    | right _ => {- a -}
    end.

End Conditionals.

Arguments when [A P] _ _.
Arguments unless [A P] _ _.
Arguments apD [A Err fam].
Arguments recover [A Err] _.

Require Import List.
Import ListNotations.

Require Import Vector.
Import VectorNotations.

Section PullOut.

  Variable A : Type.
  Variable Err : Prop.

  Fixpoint pullOutVector {n} (verr : Vector.t (A + {Err}) n) : Vector.t A n + {Err} :=
  match verr with
  | []                            => {- [] -}
  | inright err :: _              => inright err
  | Vector.cons _ {- x -} m xs => Vector.cons _ x m  <$> (pullOutVector xs)
  end.

  Fixpoint pullOutList (lerr : list (A + {Err})) : list A + {Err} :=
    match lerr with
    | [] => {- [] -}
    | error err :: _  => inright err
    | {- x -}   :: xs => do res <- pullOutList xs;; {- x :: res -}
    end%list.

  Definition pullOutSigT {P : A -> Type} (serr : sigT (fun A => P A + {Err})) : sigT P + {Err}
    := let 'existT _ a pae := serr in
       match pae with
       | error err => inright err
       | {- pa -}  => {- existT _ _ pa -}
       end.

End PullOut.

Arguments pullOutVector [A Err n].
Arguments pullOutList [A Err].
Arguments pullOutSigT {A Err P}.  (* Using [] instead of {} does not allow this to be mapped! *)

Section PartialFunctions.
  Variable A B : Type.
  Variable E   : Prop.
  Variable partial : A -> B + {E}.

  Definition InDomain a := exists b, partial a = inleft b.
  Definition InRange  b := exists a, partial a = inleft b.

  Definition domain := {a | InDomain a}.
  Definition range  := {b | InRange b}.

  Definition totalise (aD : domain) : B :=
    match aD with
    | exist _ a pf
      => match recover' (partial a) pf with
         | exist _ b _ => b
         end
    end.

  (* Get the total core of the partial function *)
  Definition totalCore (aD : domain) : range :=
    match aD with
    | exist _ a pf =>
      match recover' (partial a) pf with
      | exist _ b pf0 => exist _ b (ex_intro _ a pf0)
      end
    end.

End PartialFunctions.
Arguments InDomain [A B E].
Arguments InRange  [A B E].
Arguments totalCore [A B E].


From Coq Require Import String Arith Psatz Bool List Program.Equality Lists.ListSet .
From DanTrick Require Import DanTrickLanguage DanLogProp DanLogicHelpers
  StackLanguage StackLangEval EnvToStack StackLogicGrammar LogicProp TranslationPure FunctionWellFormed ImpVarMap ImpVarMapTheorems StackLangTheorems.

From DanTrick Require Export LogicTranslationBase ParamsWellFormed FunctionWellFormed.

Lemma compile_bool_args_sound_pos :
  forall (vals: list bool) (sargs: list bexp_stack) (dargs: list bexp_Dan) (num_args: nat) (idents: list ident),
    compile_bool_args num_args idents dargs sargs ->
    forall fenv_d fenv_s func_list,
    forall (FENV_WF: fenv_well_formed' func_list fenv_d),
      fenv_s = compile_fenv fenv_d ->
      (forall aD aS,
          aS = compile_aexp aD (fun x => one_index_opt x idents) (List.length idents) ->
          forall (FUN_APP_AEXP: fun_app_well_formed fenv_d func_list aD),
          forall (MAP_WF_AEXP: var_map_wf_wrt_aexp idents aD),
          forall nenv dbenv stk n rho,
            List.length dbenv = num_args ->
            state_to_stack idents nenv dbenv stk ->
            a_Dan aD dbenv fenv_d nenv n ->
            aexp_stack_sem aS fenv_s (stk ++ rho) (stk ++ rho, n)) ->
      (forall bD bS,
          bS = compile_bexp bD (fun x => one_index_opt x idents) (List.length idents) ->
          forall (FUN_APP_BEXP: fun_app_bexp_well_formed fenv_d func_list bD),
          forall (MAP_WF_BEXP: var_map_wf_wrt_bexp idents bD),
          forall nenv dbenv stk bl rho,
            List.length dbenv = num_args ->
            state_to_stack idents nenv dbenv stk ->
            b_Dan bD dbenv fenv_d nenv bl ->
            bexp_stack_sem bS fenv_s (stk ++ rho) (stk ++ rho, bl)) ->
      forall nenv dbenv,
        List.length dbenv = num_args ->
        (eval_prop_args_rel
           (fun (b : bexp_Dan) (v : bool) =>
              b_Dan b dbenv fenv_d nenv v) dargs vals) ->
        forall (ARGS_FUN_APP: prop_args_rel (V := bool) (fun_app_bexp_well_formed fenv_d func_list) dargs),
        forall (ARGS_MAP_WF: prop_args_rel (V := bool) (var_map_wf_wrt_bexp idents) dargs),
        forall stk,
          state_to_stack idents nenv dbenv stk ->
          forall rho,
            eval_prop_args_rel
              (fun (boolexpr : bexp_stack) (boolval : bool) =>
                 bexp_stack_sem boolexpr (compile_fenv fenv_d)
                                (stk ++ rho) (stk ++ rho, boolval)) sargs vals.
Proof.
  induction vals.
  - intros. inversion H4. subst. inversion H. subst.
    inversion H0. subst. apply RelArgsNil.
  - intros. inversion H4. subst. inversion H. subst. inversion H0. subst.
    inversion ARGS_FUN_APP. inversion ARGS_MAP_WF. subst.
    apply RelArgsCons.
    + pose proof (BEXP := H2 arg (comp_bool idents arg)).
      eapply BEXP.
      -- unfold comp_bool. auto.
      -- eauto.
      -- eauto.
      -- eapply eq_refl.
      -- apply H5.
      -- auto.
    + pose proof (IHvals args' args (Datatypes.length dbenv) idents) as int.
      pose proof (CompiledBoolArgs idents (Datatypes.length dbenv) args args' H9).
      pose proof (int H3 fenv_d (compile_fenv fenv_d)) as int2.
      pose proof (eq_refl (compile_fenv fenv_d)) as eq.
      pose proof (int2 func_list FENV_WF eq H1 H2 nenv dbenv) as int3.
      pose proof (eq_refl (Datatypes.length dbenv)) as eq2.
      pose proof (int3 eq2 H11 H12 H17 stk H5 rho) as conc.
      apply conc.
Qed.

Lemma compile_arith_args_sound_pos :
forall vals sargs dargs num_args idents,
  compile_arith_args num_args idents dargs sargs ->
  forall fenv_d fenv_s func_list,
    forall (FENV_WF: fenv_well_formed' func_list fenv_d),
    fenv_s = compile_fenv fenv_d ->
    (forall aD aS,
          aS = compile_aexp aD (fun x => one_index_opt x idents) (List.length idents) ->
          forall (FUN_APP_AEXP: fun_app_well_formed fenv_d func_list aD),
          forall (MAP_WF_AEXP: var_map_wf_wrt_aexp idents aD),
          forall nenv dbenv stk n rho,
            List.length dbenv = num_args ->
            state_to_stack idents nenv dbenv stk ->
            a_Dan aD dbenv fenv_d nenv n ->
            aexp_stack_sem aS fenv_s (stk ++ rho) (stk ++ rho, n)) ->
      (forall bD bS,
          bS = compile_bexp bD (fun x => one_index_opt x idents) (List.length idents) ->
          forall (FUN_APP_BEXP: fun_app_bexp_well_formed fenv_d func_list bD),
          forall (MAP_WF_BEXP: var_map_wf_wrt_bexp idents bD),
          forall nenv dbenv stk bl rho,
            List.length dbenv = num_args ->
            state_to_stack idents nenv dbenv stk ->
            b_Dan bD dbenv fenv_d nenv bl ->
            bexp_stack_sem bS fenv_s (stk ++ rho) (stk ++ rho, bl)) ->
    forall nenv dbenv,
      List.length dbenv = num_args ->
      (eval_prop_args_rel
      (fun (b : aexp_Dan) (v : nat) =>
         a_Dan b dbenv fenv_d nenv v) dargs vals) ->
      forall (ARGS_FUN_APP: prop_args_rel (V := nat) (fun_app_well_formed fenv_d func_list) dargs),
      forall (ARGS_MAP_WF: prop_args_rel (V := nat) (var_map_wf_wrt_aexp idents) dargs),
      forall stk,
        state_to_stack idents nenv dbenv stk ->
        forall rho,
          eval_prop_args_rel
          (fun (boolexpr : aexp_stack) (boolval : nat) =>
          aexp_stack_sem boolexpr (compile_fenv fenv_d)
            (stk ++ rho) (stk ++ rho, boolval)) sargs vals.
Proof.
  induction vals.
  - intros. inversion H4. subst. inversion H. subst.
    inversion H0. subst. apply RelArgsNil.
  - intros. inversion H4. subst. inversion H. subst. inversion H0. subst.
    inversion ARGS_FUN_APP. inversion ARGS_MAP_WF. subst.
    apply RelArgsCons.
    + pose proof (AEXP := H1 arg (comp_arith idents arg)).
      eapply AEXP.
      -- auto.
      -- auto.
      -- auto.
      -- reflexivity.
      -- eauto.
      -- eauto.
    + pose proof (IHvals args' args (Datatypes.length dbenv) idents) as int.
      pose proof (CompiledArithArgs idents (Datatypes.length dbenv) args args' H9).
      pose proof (int H3 fenv_d (compile_fenv fenv_d)) as int2.
      pose proof (eq_refl (compile_fenv fenv_d)) as eq.
      pose proof (int2 func_list FENV_WF eq H1 H2 nenv dbenv) as int3.
      pose proof (eq_refl (Datatypes.length dbenv)) as eq2.
      pose proof (int3 eq2 H11 H12 H17 stk H5 rho) as conc.
      apply conc.
Qed.

Lemma trans_sound_pos_assume_comp_basestate_lp_aexp (idents : list DanTrickLanguage.ident)
      (dbenv : list nat)
      (fenv_d : fun_env)
      (func_list : list fun_Dan)
      (FENV_WF : fenv_well_formed' func_list fenv_d)
      (H1 : forall (aD : aexp_Dan) (aS : aexp_stack),
          aS =
            compile_aexp aD (fun x : ident => one_index_opt x idents)
                         (Datatypes.length idents) ->
          fun_app_well_formed fenv_d func_list aD ->
          var_map_wf_wrt_aexp idents aD ->
          forall (nenv : nat_env) (dbenv0 stk : list nat)
            (n : nat) (rho : list nat),
            Datatypes.length dbenv0 = Datatypes.length dbenv ->
            state_to_stack idents nenv dbenv0 stk ->
            a_Dan aD dbenv0 fenv_d nenv n ->
            aexp_stack_sem aS (compile_fenv fenv_d) (stk ++ rho)
                           (stk ++ rho, n))
      (H2 : forall (bD : bexp_Dan) (bS : bexp_stack),
          bS =
            compile_bexp bD (fun x : ident => one_index_opt x idents)
                         (Datatypes.length idents) ->
          fun_app_bexp_well_formed fenv_d func_list bD ->
          var_map_wf_wrt_bexp idents bD ->
          forall (nenv : nat_env) (dbenv0 stk : list nat)
            (bl : bool) (rho : list nat),
            Datatypes.length dbenv0 = Datatypes.length dbenv ->
            state_to_stack idents nenv dbenv0 stk ->
            b_Dan bD dbenv0 fenv_d nenv bl ->
            bexp_stack_sem bS (compile_fenv fenv_d) (stk ++ rho)
                           (stk ++ rho, bl))
      (OKfuncs: funcs_okay_too func_list (compile_fenv fenv_d))
      (OKparams : Forall (fun func => all_params_ok (DanTrickLanguage.Args func) (DanTrickLanguage.Body func)) func_list)
      (nenv : nat_env)
      (l : LogicProp nat aexp_Dan)
      (stk : list nat)
      (H5 : state_to_stack idents nenv dbenv stk)
      (rho : list nat)
      (FUN_APP : Dan_lp_prop_rel (fun_app_well_formed fenv_d func_list)
                                 (fun_app_bexp_well_formed fenv_d func_list)
                                 (Dan_lp_arith l))
      (MAP_WF : Dan_lp_prop_rel (var_map_wf_wrt_aexp idents)
                                (var_map_wf_wrt_bexp idents) (Dan_lp_arith l))
      (H0 : Dan_lp_rel (Dan_lp_arith l) fenv_d dbenv nenv)
      (s : LogicProp nat aexp_stack)
      (TRANSLATE : lp_transrelation (Datatypes.length dbenv) idents
                              (Dan_lp_arith l) (MetaNat s)):
  meta_match_rel (MetaNat s) (compile_fenv fenv_d) (stk ++ rho).
Proof.
  invc FUN_APP. invc MAP_WF. invc TRANSLATE. invc H9. invc H0.
  constructor.
  - Tactics.revert_until s.
    revert l.
    induction s; intros; invc H.
    + constructor.
    + invs H4.
    + invs H4. econstructor.
      * eapply H1; try eauto.
        reflexivity. invs H6. assumption. invs H7. assumption.
      * assumption.
    + invs H4. invs H7. invs H6. econstructor.
      * eapply H1; [reflexivity | | | reflexivity | .. ]; eassumption.
      * eapply H1; [reflexivity | | | reflexivity | .. ]; eassumption.
      * assumption.
    + invs H4. invs H6. invs H7. econstructor.
      * eapply IHs1. eapply H12. eassumption. assumption. assumption.
      * eapply IHs2; [ eapply H13 | eassumption .. ].
    + invs H6. invs H7. invs H4; [eapply RelOrPropLeft | eapply RelOrPropRight].
      * eapply IHs1; [ eapply H8 | eassumption .. ].
      * eapply IHs2; [ eapply H9 | eassumption .. ].
    + invs H4. invs H6. invs H7. econstructor; [ eapply H1; try reflexivity .. |]; eassumption.
    + invs H4. invs H6. invs H7. econstructor; [ | eassumption ].
      eapply compile_arith_args_sound_pos; try eassumption.
      econstructor. assumption. reflexivity. reflexivity.
  - Tactics.revert_until s. revert l.
    induction s; intros; invs H.
    + constructor.
    + invs H4.
    + invs H4. eapply arith_compile_prop_rel_implies_pure'; eauto.
    + invs H4. invs H6. invs H7.
      eapply arith_compile_prop_rel_implies_pure'; eauto.
    + invs H4. invs H6. invs H7.
      econstructor; [ eapply IHs1; [ eapply H13 | ..] | eapply IHs2; [ eapply H14 | .. ]]; eauto.
    + invs H6.
      eapply arith_compile_prop_rel_implies_pure'; eauto.
    + invs H6. eapply arith_compile_prop_rel_implies_pure'; eauto.
    + invs H6. invs H7. constructor. eapply arith_compile_prop_args_rel_implies_pure'; eauto.
Qed.

Lemma trans_sound_pos_assume_comp_basestate_lp_bexp (idents : list DanTrickLanguage.ident)
      (dbenv : list nat)
      (fenv_d : fun_env)
      (func_list : list fun_Dan)
      (FENV_WF : fenv_well_formed' func_list fenv_d)
      (H1 : forall (aD : aexp_Dan) (aS : aexp_stack),
          aS =
            compile_aexp aD (fun x : ident => one_index_opt x idents)
                         (Datatypes.length idents) ->
          fun_app_well_formed fenv_d func_list aD ->
          var_map_wf_wrt_aexp idents aD ->
          forall (nenv : nat_env) (dbenv0 stk : list nat)
            (n : nat) (rho : list nat),
            Datatypes.length dbenv0 = Datatypes.length dbenv ->
            state_to_stack idents nenv dbenv0 stk ->
            a_Dan aD dbenv0 fenv_d nenv n ->
            aexp_stack_sem aS (compile_fenv fenv_d) (stk ++ rho)
                           (stk ++ rho, n))
      (H2 : forall (bD : bexp_Dan) (bS : bexp_stack),
          bS =
            compile_bexp bD (fun x : ident => one_index_opt x idents)
                         (Datatypes.length idents) ->
          fun_app_bexp_well_formed fenv_d func_list bD ->
          var_map_wf_wrt_bexp idents bD ->
          forall (nenv : nat_env) (dbenv0 stk : list nat)
            (bl : bool) (rho : list nat),
            Datatypes.length dbenv0 = Datatypes.length dbenv ->
            state_to_stack idents nenv dbenv0 stk ->
            b_Dan bD dbenv0 fenv_d nenv bl ->
            bexp_stack_sem bS (compile_fenv fenv_d) (stk ++ rho)
                           (stk ++ rho, bl))
      (OKfuncs: funcs_okay_too func_list (compile_fenv fenv_d))
      (OKparams : Forall (fun func => all_params_ok (DanTrickLanguage.Args func) (DanTrickLanguage.Body func)) func_list)
      (nenv : nat_env)
      (s : LogicProp bool bexp_stack)
      (l : LogicProp bool bexp_Dan)
      (H4 : AbsEnv_rel (AbsEnvLP (Dan_lp_bool l)) fenv_d dbenv nenv)
      (stk : list nat)
      (H5 : state_to_stack idents nenv dbenv stk)
      (rho : list nat)
      (FUN_APP : Dan_lp_prop_rel (fun_app_well_formed fenv_d func_list)
                                 (fun_app_bexp_well_formed fenv_d func_list)
                                 (Dan_lp_bool l))
      (MAP_WF : Dan_lp_prop_rel (var_map_wf_wrt_aexp idents)
                                (var_map_wf_wrt_bexp idents) (Dan_lp_bool l))
      (H : prop_rel (var_map_wf_wrt_bexp idents) l)
      (TRANSLATE : compile_prop_rel (comp_bool idents) l s):
  meta_match_rel (MetaBool s) (compile_fenv fenv_d) (stk ++ rho).
Proof.
  invc FUN_APP. invc MAP_WF. invc H4. invc H3.
  constructor.
  - Tactics.revert_until s.
    induction s; intros; invs TRANSLATE.
    + constructor.
    + invs H4.
    + invs H4. invs H7. invs H8. econstructor; [ | eassumption ].
      eapply H2; try reflexivity; try eassumption.
    + invs H4. invs H7. invs H8. econstructor; [ .. | eassumption ].
      all: eapply H2; try reflexivity; try eassumption.
    + invs H4. invs H7. invs H8. econstructor; [ eapply IHs1; [ | eapply H15 | .. ] | eapply IHs2; [ | eapply H16 | .. ]]; eassumption.
    + invs H7. invs H8. invs H4.
      * eapply RelOrPropLeft. eapply IHs1; [ | eapply H13 | .. ]; eassumption.
      * eapply RelOrPropRight. eapply IHs2; [ | eapply H14 | .. ]; eassumption.
    + invs H4. invs H7. invs H8.
      econstructor; [ .. | eassumption ].
      all: eapply H2; try reflexivity; try eassumption.
    + invs H4. invs H7. invs H8. econstructor; [ | eassumption ].
      eapply compile_bool_args_sound_pos; try reflexivity;
        try eassumption.
      constructor. assumption.
  - Tactics.revert_until s.
    induction s; intros; invs TRANSLATE.
    + constructor.
    + constructor.
    + invs H7. invs H8. eapply bool_compile_prop_rel_implies_pure'; try eassumption.
      reflexivity. reflexivity.
    + invs H7. invs H8. eapply bool_compile_prop_rel_implies_pure'; eauto.
    + invs H7. invs H8. eapply bool_compile_prop_rel_implies_pure'; eauto.
    + invs H7. invs H8. eapply bool_compile_prop_rel_implies_pure'; eauto.
    + invs H7. invs H8. eapply bool_compile_prop_rel_implies_pure'; eauto.
    + invs H7. invs H8. constructor.  eapply bool_compile_prop_args_rel_implies_pure'; eauto.
Qed.

Lemma trans_sound_pos_assume_comp_basestate (m : MetavarPred)
      (idents : list DanTrickLanguage.ident)
      (dbenv : list nat)
      (d : Dan_lp)
      (fenv_d : fun_env)
      (func_list : list fun_Dan)
      (FENV_WF : fenv_well_formed' func_list fenv_d)
      (H1 : forall (aD : aexp_Dan) (aS : aexp_stack),
          aS =
            compile_aexp aD (fun x : ident => one_index_opt x idents)
                         (Datatypes.length idents) ->
          fun_app_well_formed fenv_d func_list aD ->
          var_map_wf_wrt_aexp idents aD ->
          forall (nenv : nat_env) (dbenv0 stk : list nat)
            (n : nat) (rho : list nat),
            Datatypes.length dbenv0 = Datatypes.length dbenv ->
            state_to_stack idents nenv dbenv0 stk ->
            a_Dan aD dbenv0 fenv_d nenv n ->
            aexp_stack_sem aS (compile_fenv fenv_d) (stk ++ rho)
                           (stk ++ rho, n))
      (H2 : forall (bD : bexp_Dan) (bS : bexp_stack),
          bS =
            compile_bexp bD (fun x : ident => one_index_opt x idents)
                         (Datatypes.length idents) ->
          fun_app_bexp_well_formed fenv_d func_list bD ->
          var_map_wf_wrt_bexp idents bD ->
          forall (nenv : nat_env) (dbenv0 stk : list nat)
            (bl : bool) (rho : list nat),
            Datatypes.length dbenv0 = Datatypes.length dbenv ->
            state_to_stack idents nenv dbenv0 stk ->
            b_Dan bD dbenv0 fenv_d nenv bl ->
            bexp_stack_sem bS (compile_fenv fenv_d) (stk ++ rho)
                           (stk ++ rho, bl))
      (OKfuncs: funcs_okay_too func_list (compile_fenv fenv_d))
      (OKparams : Forall (fun func => all_params_ok (DanTrickLanguage.Args func) (DanTrickLanguage.Body func)) func_list)
      (nenv : nat_env)
      (H4 : AbsEnv_rel (AbsEnvLP d) fenv_d dbenv nenv)
      (stk : list nat)
      (H5 : state_to_stack idents nenv dbenv stk)
      (rho : list nat)
      (H10 : lp_transrelation (Datatypes.length dbenv) idents d m)
      (H0 : Dan_lp_rel d fenv_d dbenv nenv)
      (MAP_WF : Dan_lp_prop_rel (var_map_wf_wrt_aexp idents)
                             (var_map_wf_wrt_bexp idents) d)
      (FUN_APP : Dan_lp_prop_rel (fun_app_well_formed fenv_d func_list)
                             (fun_app_bexp_well_formed fenv_d func_list) d):
  absstate_match_rel
    (BaseState
       (AbsStkSize (Datatypes.length idents + Datatypes.length dbenv)) m)
    (compile_fenv fenv_d) (stk ++ rho).
Proof.
  constructor.
  - constructor.
    inversion H5. simpl. rewrite app_length. rewrite app_length. rewrite map_length. lia.
  - inversion MAP_WF. subst. invs FUN_APP. invs H10. invs H9.
    clear H9. eapply trans_sound_pos_assume_comp_basestate_lp_aexp; eauto.
    subst. invc H10. invc H8; eauto.
    eapply trans_sound_pos_assume_comp_basestate_lp_bexp; eauto.
Qed.

Lemma trans_sound_pos_assume_comp :
  forall state dan_log num_args idents,
    logic_transrelation num_args idents dan_log state ->
    forall fenv_d fenv_s func_list,
    forall (FENV_WF: fenv_well_formed' func_list fenv_d)
      (OKfuncs: funcs_okay_too func_list (compile_fenv fenv_d))
      (OKparams : Forall (fun func => all_params_ok (DanTrickLanguage.Args func) (DanTrickLanguage.Body func)) func_list),
      fenv_s = compile_fenv fenv_d ->
      (forall aD aS,
          aS = compile_aexp aD (fun x => one_index_opt x idents) (List.length idents) ->
          forall (FUN_APP_AEXP: fun_app_well_formed fenv_d func_list aD),
          forall (MAP_WF_AEXP: var_map_wf_wrt_aexp idents aD),
          forall nenv dbenv stk n rho,
            List.length dbenv = num_args ->
            state_to_stack idents nenv dbenv stk ->
            a_Dan aD dbenv fenv_d nenv n ->
            aexp_stack_sem aS fenv_s (stk ++ rho) (stk ++ rho, n)) ->
      (forall bD bS,
          bS = compile_bexp bD (fun x => one_index_opt x idents) (List.length idents) ->
          forall (FUN_APP_BEXP: fun_app_bexp_well_formed fenv_d func_list bD),
          forall (MAP_WF_BEXP: var_map_wf_wrt_bexp idents bD),
          forall nenv dbenv stk bl rho,
            List.length dbenv = num_args ->
            state_to_stack idents nenv dbenv stk ->
            b_Dan bD dbenv fenv_d nenv bl ->
            bexp_stack_sem bS fenv_s (stk ++ rho) (stk ++ rho, bl)) ->
      forall nenv dbenv,
        List.length dbenv = num_args ->
        forall (FUN_APP: AbsEnv_prop_rel (fun_app_well_formed fenv_d func_list)
                                     (fun_app_bexp_well_formed fenv_d func_list)
                                     dan_log)
          (MAP_WF: AbsEnv_prop_rel (var_map_wf_wrt_aexp idents)
                                    (var_map_wf_wrt_bexp idents)
                                    dan_log),
        AbsEnv_rel dan_log fenv_d dbenv nenv ->
        forall stk,
          state_to_stack idents nenv dbenv stk ->
          forall rho,
            absstate_match_rel state fenv_s (stk ++ rho).
Proof.
  induction state; intros.
  - inversion H. subst. clear H. inversion H4. inversion MAP_WF. inversion FUN_APP. subst.
    eapply trans_sound_pos_assume_comp_basestate; eauto.

  - invs H. invs H4. invs MAP_WF. invs FUN_APP.
    constructor.
    + eapply IHstate1; try eassumption; try reflexivity.
    + eapply IHstate2; try eassumption; try reflexivity.
  - invs H. invs MAP_WF. invs FUN_APP. invs H4.
    + eapply RelAbsOrLeft. eapply IHstate1; try eassumption; try reflexivity.
    + eapply RelAbsOrRight. eapply IHstate2; try eassumption; try reflexivity.
Qed.


Require Import Verdi.GhostSimulations.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Require Import VerdiRaft.SortedInterface.
Require Import VerdiRaft.AppendEntriesRequestTermSanityInterface.

Section AppendEntriesRequestTermSanity.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {si : sorted_interface}.

  Theorem lift_sorted :
    forall net,
      refined_raft_intermediate_reachable net ->
      logs_sorted (deghost net).
  Proof using si rri.
    intros.
    eapply lift_prop; eauto using logs_sorted_invariant.
  Qed.

  Lemma ghost_packet :
    forall (net : network (params := raft_refined_multi_params)) p,
      In p (nwPackets net) ->
      In (deghost_packet p) (nwPackets (deghost net)).
  Proof using.
    unfold deghost.
    simpl. intuition.
    apply in_map_iff.
    eexists; eauto.
  Qed.

  Lemma logs_sorted_aerts :
    forall net,
      logs_sorted (deghost net) ->
      append_entries_request_term_sanity net.
  Proof using.
    unfold logs_sorted, append_entries_request_term_sanity. intuition.
    unfold packets_ge_prevTerm in *. find_apply_lem_hyp ghost_packet.
    eauto.
  Qed.

  Instance aertsi : append_entries_request_term_sanity_interface.
  Proof.
    split. intros. find_apply_lem_hyp lift_sorted.
    eauto using logs_sorted_aerts.
  Qed.
End AppendEntriesRequestTermSanity.