(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * SemGroup.v : Language extension with a cyclic group type *)

Set Implicit Arguments.

Require Import PPT.
Require Export BuildTac.
Require Export Group2.

Module MAKE_SEM_GROUP (CGK : CYCLIC_GROUP_WITH_ORDER).

(** Semantics with optimizations *)
Module Entries.

 Module MG := MAKE_GROUP CGK.
 Module CGKP := CGO_Properties CGK.

 Import MG.

 Module SemO <: SEM_OPT.

  Module T_ := MakeType Gt.

  Module Uop_ := Gop T_.

  Module US_ := EmptySupport Gt T_.

  Module Sem := MakeSem.Make Gt T_ Uop_ US_.
  Export Sem.

  Notation "x '^' y" := (E.Eop (O.Ouser OGpow) {x, y}).
  Notation "x '**' y" := (E.Eop (O.Ouser OGmul) {x , y})
   (at level 40, left associativity).
  Notation "'g'" := (E.Eop (O.Ouser OGen) (@dnil T.type E.expr)).
  Notation "'q'" := (E.Eop (O.Ouser OGorder) (@dnil T.type E.expr)).

  Definition simpl_op (op : Uop.t) :
   E.args (Uop.targs op) -> E.expr (Uop.tres op) :=
   match op as op0 return E.args (Uop.targs op0) -> E.expr (Uop.tres op0) with
   | OGpow => fun args =>
      E.app_expr (T.User Tg) args
      (fun (e:E.expr (T.User Tg)) (e3:E.expr T.Nat) =>
        match E.get_uop e with
        | Some (existT uop args) =>
          match uop as uop0 return E.args (Uop.targs uop0) -> E.expr (T.User Tg) with
          | OGpow => fun args =>
            E.app_expr (T.User Tg) args
             (fun (e1:E.expr (T.User Tg)) (e2:E.expr T.Nat) => e1 ^ (e2 *! e3))
          | _ => fun _ => e ^ e3
          end args
       | None => e ^ e3
       end)
   | op => fun args => E.Eop (O.Ouser op) args
   end.

  Implicit Arguments simpl_op [].

  Lemma simpl_op_spec : forall k op args (m:Mem.t k),
   E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
  Proof.
   destruct op; simpl; trivial.
   intros args;T.dlist_inversion args; rewrite Heq; intros; simpl.
   generalize (E.get_uop_spec x); destruct (E.get_uop x); trivial.
   destruct s as (uop, args0).
   intros H; generalize (H uop args0 (refl_equal _)); clear H; simpl; intros.
   destruct uop; trivial.
   rewrite (T.eq_dep_eq H); clear H.
   clear Heq;T.dlist_inversion args0; rewrite Heq.
   simpl; unfold O.eval_op; simpl.
   rewrite CGKP.pow_pow; trivial.
  Qed.

 End SemO.

 Module BP := BaseProp.Make SemO.Sem.

 Module Uppt.

  Import BP.

  Implicit Arguments T.size [k t].

  Open Scope nat_scope.

  (** PPT expression *)
  Definition PPT_expr (t:T.type) (e:E.expr t)
  (F:polynomial -> polynomial)
  (G:polynomial -> polynomial) : Prop :=
  forall k (m:Mem.t k) p,
   (forall t (x:Var.var t),
    BP.Vset.mem x (BP.fv_expr e) -> T.size (m x) <= peval p k)  ->
   let (v,n) := E.ceval_expr e m in
    T.size v <= peval (F p) k /\
    n <= peval (G p) k.

  (** PPT support *)
  Definition PPT_support t (s:E.support t)
  (F:polynomial -> polynomial)
  (G:polynomial -> polynomial) : Prop :=
  forall k (m:Mem.t k) p,
   (forall t (x:Var.var t),
    BP.Vset.mem x (BP.fv_distr s) -> T.size (m x) <= peval p k)  ->
   let (l,n) := E.ceval_support s m in
    (forall v, In v l -> T.size v <= peval (F p) k) /\
    n <= peval (G p) k.

  Definition utsize : UT.t -> nat := fun _ => 1.

  Definition utsize_default_poly : nat -> polynomial :=
   fun _ => pplus (pcst 1) pvar.

  Lemma utsize_default_poly_spec : forall r ut,
   utsize ut <= r ->
   forall k, UT.size (t:=ut) (UT.default k ut) <= peval (utsize_default_poly r) k.
  Proof.
   intros r ut _ k.
   case ut; simpl.
   unfold UT.size, utsize_default_poly.
   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
  Qed.

  Definition uop_poly (o:Uop.t) : bool :=
   match o with
   | OGen | OGmul | OGpow => true
   | _ => false
   end.

  Lemma uop_poly_spec : forall o (la:dlist E.expr (O.targs (O.Ouser o))),
   uop_poly o ->
   (forall t (e:E.expr t), @DIn _ E.expr _ e _ la ->
    exists F, exists G, PPT_expr e F G) ->
   exists F, exists G, PPT_expr (E.Eop (O.Ouser o) la) F G.
  Proof.
   intros o la H Hla.
   destruct o.

   (* OGorder *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   exists (fun _ => pplus (pcst 1) (pplus (pcst 1) pvar)).
   exists (fun _ => pplus (pcst 1) pvar).
   simpl; split.
   rewrite pplus_spec, pplus_spec, pcst_spec, pvar_spec; simpl.
   rewrite <- size_nat_pow_2.
   apply size_nat_monotonic.
   assert (Hb := CGK.o_bouned k).
   apply lt_le_weak.
   replace (2 ^ S k) with (2 ^ (k + 1));[ omega | auto with zarith ].
   simpl; rewrite plus_0_r.
   rewrite pplus_spec, pcst_spec, pvar_spec.
   destruct (eq_nat_dec k 0); intros.
   subst; simpl; trivial.
   eapply le_trans; [ apply size_nat_le | ]; omega.

   (* OGen *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   exists (fun _ => pplus (pcst 1) pvar).
   exists (fun _ => 1).
   simpl; split.
   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pcst_spec; trivial.

   (* OGmul *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   destruct (Hla _ x) as [F1 [G1 H1] ].
   left; trivial.
   destruct (Hla _ x0) as [F2 [G2 H2] ].
   right; left; trivial.
   exists (fun _ => pplus (pcst 1) pvar).
   exists (fun p => pplus CGK.cost_mul_poly (pplus (G1 p) (G2 p))).
   intros k m p Hm; simpl; split.

   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pplus_spec, pplus_spec.
   apply plus_le_compat.
   apply le_trans with (peval CGK.cost_mul_poly (pred (size_nat (2^k)))).
   apply CGK.cost_mul_poly_spec.
   rewrite size_nat_pow_2; trivial.

   generalize (H1 k m p) (H2 k m p); clear H1 H2.
   case_eq (E.ceval_expr x m); simpl.
   case_eq (E.ceval_expr x0 m); simpl.
   intros i n Heqi i0 n0 Heqi0 Hi Hi0.
   destruct Hi.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x); [ | trivial].
   unfold fv_expr; simpl.
   apply fv_expr_rec_subset.
   destruct Hi0.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x0); [ | trivial].
   unfold fv_expr at 2; simpl.
   fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
   rewrite union_fv_expr_spec.
   apply VsetP.subset_union_l.
   rewrite plus_0_r; apply plus_le_compat; auto.

   (* OGpow *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   destruct (Hla _ x) as [F1 [G1 H1] ].
   left; trivial.
   destruct (Hla _ x0) as [F2 [G2 H2] ].
   right; left; trivial.
   exists (fun _ => pplus (pcst 1) pvar).
   exists (fun p => pplus CGK.cost_pow_poly (pplus (G1 p) (G2 p))).
   intros k m p Hm; simpl; split.

   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pplus_spec, pplus_spec.
   apply plus_le_compat.
   apply le_trans with (peval CGK.cost_pow_poly (pred (size_nat (2^k)))).
   apply CGK.cost_pow_poly_spec.
   rewrite size_nat_pow_2; trivial.

   generalize (H1 k m p) (H2 k m p); clear H1 H2.
   case_eq (E.ceval_expr x m); simpl.
   case_eq (E.ceval_expr x0 m); simpl.
   intros i n Heqi i0 n0 Heqi0 Hi Hi0.
   destruct Hi.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x); [ | trivial].
   unfold fv_expr; simpl.
   apply fv_expr_rec_subset.
   destruct Hi0.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x0); [ | trivial].
   unfold fv_expr at 2; simpl.
   fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
   rewrite union_fv_expr_spec.
   apply VsetP.subset_union_l.
   rewrite plus_0_r; apply plus_le_compat; auto.

   (* OGinv *)
   T.dlist_inversion la.
   rewrite Heq in Hla; discriminate.
  Qed.

  Definition usupport_poly t (us:US.usupport t) : bool := false.

  Lemma usupport_poly_spec : forall t (us:US.usupport t),
   usupport_poly us ->
   exists F, exists G, PPT_support (E.Duser us) F G.
  Proof.
   intros t us; case us.
  Qed.

 End Uppt.

End Entries.

Module Tactics := BuildTac.Make Entries.
Export Tactics.

Definition minus_mod (x m k:nat) :=
 match le_lt_dec m x with
 | left _ => (x - m) %nat
 | _ => (k - m + x)%nat
 end.

Lemma mult_uniform :
 forall E (n:Var.var T.Nat) (x:Var.var (T.User Tg)) (e:E.expr (T.User Tg)) P,
  ~Vset.mem n (fv_expr e) ->
  equiv P
  E [n <$- [0..q-!1]; x <- g ^ n ** e]
  E [n <$- [0..q-!1]; x <- g ^ n]
  (kreq_mem {{x}}).
Proof.
 intros E n x e P Hn.
 apply equiv_cons with
  (fun k (m1 m2:Mem.t k) =>
   m1 n = minus_mod (m2 n) (CGK.log (E.eval_expr e m1)) (CGK.o k)).

 (* equiv_random_permut *)
 eapply equiv_strengthen;
  [ | apply equiv_random_permut with
     (f:=fun k (m1 m2:Mem.t k) v => minus_mod v (CGK.log (E.eval_expr e m1)) (CGK.o k))].
 red; intros; split.

 (* permut_support *)
 unfold permut_support.
 change (E.eval_support [0..q -! 1] m2) with (E.eval_support [0..q -! 1] m1).
 generalize (CGK.log (E.eval_expr e m1)) (CGK.log_lt (E.eval_expr e m1)).
 intros p; destruct (zerop p); intros; subst.

  (* p = 0 *)
  apply PermutP_refl.
  intros a _; unfold minus_mod; destruct (le_lt_dec 0 a); omega.

  (* p > 0 *)
  assert (Hs:forall (m:Mem.t k), E.eval_support [0..q-!1] m = seq 0 (CGK.o k)).
  simpl; unfold O.eval_op; simpl.
  destruct (CGK.o k)%nat; simpl.
  elimtype False; omega.
  rewrite <- minus_n_O; trivial.

  rewrite Hs.
  assert (Hle:(p <= CGK.o k)%nat) by auto with arith.
  assert (W:=@seq_PermutP (CGK.o k) p Hle).
  apply PermutP_weaken with (R2:=fun x y => y = x) in W; auto.
  apply PermutP_sym in W.
  apply PermutP_trans with (2:=W).
  pattern (CGK.o k)%nat at 2; replace (CGK.o k)%nat with (((CGK.o k) - p) + p)%nat; auto with zarith.
  rewrite seq_append; apply PermutP_app.
  apply Permut_seq_R; unfold minus_mod; intros.
  destruct (le_lt_dec p (i + p)); omega.
  apply Permut_seq_R; unfold minus_mod; intros.
  destruct (le_lt_dec p (i + 0)); omega.

 (* precondition *)
 intros v Hv.
 rewrite Mem.get_upd_same, Mem.get_upd_same.
 assert (
  E.eval_expr e m1 =
  E.eval_expr e (m1 {!n <-- minus_mod v (CGK.log (E.eval_expr e m1)) (CGK.o k)!})).
 apply EqObs_e_fv_expr.
 red; intros; rewrite Mem.get_upd_diff; trivial.
 intros Heq; rewrite <- Heq in H0; apply Hn; trivial.
 rewrite <- H0; trivial.

 (* assignment *)
 eapply equiv_strengthen; [ | apply equiv_assign].
 intros k m1 m2 H t w H0.
 Vset_mem_inversion H0; rewrite Heq.
 repeat rewrite Mem.get_upd_same.
 simpl; unfold O.eval_op, T.app_op, O.interp_op, Uop.interp_op.
 rewrite H.
 set (X:=E.eval_expr e m1).
 pattern X at 2; rewrite (CGK.log_spec X).
 generalize (m2 n) (CGK.log X) (CGK.log_lt X); intros n1 p Hlt.
 rewrite CGKP.mul_pow_plus.
 unfold minus_mod.
 destruct (le_lt_dec p n1).
 rewrite plus_comm, le_plus_minus_r; trivial.
 rewrite plus_comm; repeat rewrite plus_assoc.
 rewrite le_plus_minus_r; auto with arith.
 rewrite plus_comm, <- CGKP.mul_pow_plus, CGK.cyclic_k, CGK.mul_0_r; trivial.
Qed.

End MAKE_SEM_GROUP.


From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import frac.
From cap_machine Require Export rules_base.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Inductive Mov_spec (regs: Reg) (dst: RegName) (src: Z + RegName) (regs': Reg): cap_lang.val -> Prop :=
  | IsPtr_spec_success w:
      word_of_argument regs src = Some w →
      incrementPC (<[ dst := w ]> regs) = Some regs' →
      Mov_spec regs dst src regs' NextIV
  | Mov_spec_failure w:
      word_of_argument regs src = Some w →
      incrementPC (<[ dst := w ]> regs) = None →
      Mov_spec regs dst src regs' FailedV.

  Lemma wp_Mov Ep pc_p pc_b pc_e pc_a  w dst src regs :
    decodeInstrW w = Mov dst src ->
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    regs !! PC = Some (WCap pc_p pc_b pc_e pc_a) →
    regs_of (Mov dst src) ⊆ dom regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ Mov_spec regs dst src regs' retv ⌝ ∗
        pc_a ↦ₐ w ∗
        [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ns l1 l2 nt) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iIntros "_".
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.
    unfold exec in Hstep.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    assert (exists w, word_of_argument regs src = Some w) as [wsrc Hwsrc].
    { destruct src as [| r0]; eauto; cbn.
      destruct (Hri r0) as [? [? ?]]. set_solver+. eauto. }

    pose proof Hwsrc as Hwsrc'. eapply word_of_argument_Some_inv' in Hwsrc; eauto.

    assert (exec_opt (Mov dst src) (r, m) = updatePC (update_reg (r, m) dst wsrc)) as HH.
    { destruct Hwsrc as [ [? [? ?] ] | [? (? & ? & Hr') ] ]; simplify_eq; eauto.
      cbn. by rewrite /= Hr'. }
    rewrite HH in Hstep. rewrite /update_reg /= in Hstep.

    destruct (incrementPC (<[ dst := wsrc ]> regs)) as [regs'|] eqn:Hregs';
      pose proof Hregs' as H'regs'; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      rewrite Hregs' in Hstep. simplify_pair_eq.
      iFrame. iApply "Hφ"; iFrame. iPureIntro. econstructor; eauto. }

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & HuPC & ->).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto.
    rewrite HuPC in Hstep. simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iModIntro. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  Lemma wp_move_success_z E pc_p pc_b pc_e pc_a pc_a' w r1 wr1 z :
    decodeInstrW w = Mov r1 (inl z) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ WInt z }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_move_success_reg E pc_p pc_b pc_e pc_a pc_a' w r1 wr1 rv wrv :
    decodeInstrW w = Mov r1 (inr rv) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1
        ∗ ▷ rv ↦ᵣ wrv }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ wrv
          ∗ rv ↦ᵣ wrv }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hrv) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hrv") as "[Hmap (%&%&%)]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert (insert_commute _ PC r1) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_move_success_reg_same E pc_p pc_b pc_e pc_a pc_a' w r1 wr1 :
    decodeInstrW w = Mov r1 (inr r1) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ wr1 }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_move_success_reg_samePC E pc_p pc_b pc_e pc_a pc_a' w :
    decodeInstrW w = Mov PC (inr PC) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a) Hφ".
    iDestruct (map_of_regs_1 with "HPC") as "Hmap".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite !insert_insert.
      iDestruct (regs_of_map_1 with "Hmap") as "?"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_move_success_reg_toPC E pc_p pc_b pc_e pc_a w r1 p b e a a':
    decodeInstrW w = Mov PC (inr r1) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (a + 1)%a = Some a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ WCap p b e a }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap p b e a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ WCap p b e a }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_move_success_reg_fromPC E pc_p pc_b pc_e pc_a pc_a' w r1 wr1 :
    decodeInstrW w = Mov r1 (inr PC) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ WCap pc_p pc_b pc_e pc_a }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

End cap_lang_rules.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the static semantics of statements and expressions, pg. 63.

*)
Set Implicit Arguments.
Require Import Cyclone_Static_Semantics.
Require Import Cyclone_Test_Utilities.
Require Import Cyclone_LN_Tactics.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* Automating these rules is still a bit of a mystery.
These three are L and a Tau and are the hardest.
styp_let_3_6
styp_open_3_7
styp_openstar_3_8

 These three are L but no Tau.
SR_3_13
SR_3_12
K_etype

 The cases I have here may or may not be needed in the proofs,
so I may wait until a proof case comes up then automate.

 I can automate simpl_K being called and I can automate and
rename apply_fresh_fresh with a simpl_env to make this a
bit easier.
*)

Example p63_1:
  styp ddot udot gdot
       (letx (i_e (i_i 0)) (e_s (p_e (bevar 0) nil)))
       cint.
Proof.
  apply_fresh_from styp_let_3_6 with fv_of_static_goal; auto.
  (* But I'm not really solving the undirected type issues. *)
Qed.

Example p63_2:
    styp ddot udot gdot
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil)) (e_s (p_e (bevar 0) nil))))
         (ptype cint).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint; auto.
(*
    [simpl; case_nat; case_nat| auto | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also (ptype cint);
    [simpl; case_nat | auto | auto].
  auto.
*)
Qed.

Example p62_3:
    styp ddot udot gdot
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil))
                     (letx (pack cint
                                 (cpair (amp (p_e (bevar 2) nil)) (p_e (bevar 2) nil))
                                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
                        (e_s (p_e (bevar 0) nil)))))
         (etype aliases B (cross (ptype (btvar 0)) (btvar 0))).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint;
  [simpl_env; try simpl_K | auto | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also (ptype cint);
    [ simpl_env; try simpl_K| auto | auto].
  foo.
  auto.
(* Once there are no existential variables, it solves these. *)
(*  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also (ptype cint);
    try simpl_env; auto. *)
Qed.

Example p63_4:
    styp ddot udot gdot
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil))
                     (letx (pack cint
                                 (cpair (amp (p_e (bevar 2) nil)) (p_e (bevar 2) nil))
                                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
                           (openstar (p_e (bevar 1) nil)
                                     (e_s (p_e (bevar 0) nil))))))
         (ptype (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint;
    try simpl_env; try simpl_K;
   [ idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
    also (ptype cint);
    try simpl_env; try simpl_K;
    [idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
  also (etype aliases B (cross (ptype (btvar 0)) (btvar 0)));
    try simpl_env; try simpl_K;
    [idtac | auto].
  apply styp_openstar_3_8 with
  (L:= (\{ y} \u \{ y0}) \u \{ y1})
    (tau':= (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
    (k:= B);
    try simpl_env; try simpl_K;
      [idtac | auto].
  intros.
  constructor.
  apply SR_3_1 with (tau':= (ptype (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))));
    auto.
Qed.

Example p63_4_open:
    styp ddot udot gdot
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil))
                     (letx (pack cint
                                 (cpair (amp (p_e (bevar 2) nil)) (p_e (bevar 2) nil))
                                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
                           (openx (p_e (bevar 1) nil)
                                     (e_s (p_e (bevar 0) nil))))))
         (etype aliases B (cross (ptype (btvar 0)) (btvar 0))).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint;
    try simpl_env; try simpl_K;
   [ idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
    also (ptype cint);
    try simpl_env; try simpl_K;
    [idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
  also (etype aliases B (cross (ptype (btvar 0)) (btvar 0)));
    try simpl_env; try simpl_K;
    [idtac | auto].
(*
  apply styp_openstar_3_8 with
  (L:= (\{ y} \u \{ y0}) \u \{ y1})
    (tau':= (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
    (k:= B);
    try simpl_env; try simpl_K;
      [idtac | auto].
  intros.
  constructor.
  apply SR_3_1 with (tau':= (ptype (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))));
    auto.
Qed.
 *)
Admitted.

(* Test ret, the return checker. *)

Example ret_ret_test:
  ret (retn e).
Proof.
  auto. (* apply ret_ret.*)
Qed.

Example ret_if_test_not:
  ~ret (if_s e (e_s (i_e (i_i 0))) (e_s (i_e (i_i 0)))).
Proof.
  intros H.
  inversion H.
  inversion H2.
Qed.

Example ret_if_test:
  ret (if_s e (retn (i_e (i_i 0))) (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_if;*)
Qed.

Example ret_seq_1_test:
 ret (seqx (retn (i_e (i_i 0))) (e_s (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_seq_1;*)
Qed.

Example ret_seq_2_test:
  ret (seqx (e_s (i_e (i_i 0))) (retn (i_e (i_i 0)))).
Proof.
  auto.
  (* apply ret_seq_2;*)
Qed.

Example ret_let_test:
  ret (letx e (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_let.*)
Qed.

Example ret_open_test:
  ret (openx e (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_open.*)
Qed.

Example ret_openstar_test:
  ret (openstar e (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_openstar.*)
Qed.

(* Test ltyp. *)

Example SL_3_1_test:
  ltyp ddot udot (gdot & (varx ~ cint))  (p_e (fevar varx) nil) cint.
Proof.
  auto.
Qed.

Example SL_3_2_test:
  ltyp ddot udot (gdot & (varx ~ (ptype cint))) (star (p_e (fevar varx) nil)) cint.
Proof.
  auto.
  (* apply SL_3_2. *)
Qed.

Example SL_3_3_test:
  ltyp ddot udot (gdot & (varx ~ (cross cint cint)))
       (dot (p_e (fevar varx) nil) zero_pe) cint.
Proof.
  auto.
(*
  apply SL_3_3 with (t1:=cint).
  apply SL_3_1 with (tau':= (cross cint cint));
  auto.
*)
Qed.

Example SL_3_4_test:
  ltyp ddot udot (gdot & (varx ~ (cross cint cint))) (dot (p_e (fevar varx) nil) one_pe) cint.
Proof.
  auto. (* apply SL_3_4 with (t0:=cint);   auto.*)
Qed.

(* Test styp *)
(* Return at the end of a program, any old type will do. *)
Example styp_e_test:
  styp ddot udot gdot (e_s e) tau.
Proof.
  unfold_test_utilities.
  auto.
(*
  applys~ styp_e_3_1.
  auto.
  apply styp_e_3_1 with (tau':= cint);
  auto.
*)
Qed.

Example styp_return_test:
  styp ddot udot gdot (retn e) tau.
Proof.
  unfold_test_utilities.
  auto.
(*  apply styp_return_3_2; *)
Qed.

Example styp_seq_test:
  styp ddot udot gdot (seqx s1 s2) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply styp_seq_3_3; *)
Qed.

Example styp_while_test:
  styp ddot udot gdot (while e s) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply styp_while_3_4; *)
Qed.

Example styp_if_test:
  styp ddot udot gdot (if_s e s1 s2) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply styp_if_3_5; *)
Qed.

Example styp_let_test:
  styp ddot udot gdot (letx e s) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply_fresh_from* styp_let_3_6 with fv_of_static_goal. *)
  (* apply styp_let_3_6 with (L:= ltac(fv_of_static_goal)) (tau':= cint); auto. *)
Qed.

Example K_B_test:
  K ((alpha_ ~ B) & ddot) (ftvar alpha_) B.
Proof.
  auto.
  (* apply K_B; auto *)
Qed.

(* Let's make some polymorphic pairs. *)
Definition axaa  := etype aliases A (cross (btvar 0) (btvar 0)).
Definition paxaa := pack cint (cpair (i_e (i_i 0)) (i_e (i_i 1))) axaa.
(* alpha is bound here to the witness type so we can pass it on inside. *)
Definition oaxaa := openx paxaa (e_s (p_e (bevar 0) (cons (i_pe zero_pe) nil))).
(*
Example styp_open_test:
  styp ddot udot gdot
       cint
       oaxaa.
Proof.
  unfold_test_utilities.
  unfold oaxaa, paxaa, axaa.
  apply styp_open_3_7
        with (L := \{})
             (p    := aliases)
             (k    := B)
             (tau  := cint)
             (tau' := (cross (btvar 0) (btvar 0))).
  simpl.
  case_nat.
  intros.
  apply styp_e_3_1 with (tau':= cint).
  admit.

  apply_fresh_from styp_open_3_7 with fv_of_static_goal.
  simpl.
  intros.
  case_nat~.

  admit.
  auto.

   auto.
Qed.

Example styp_openstar_test:
  styp ddot udot gdot
       cint
       (openstar (pack cint
                   (cpair (i_e (i_i 0)) (i_e (i_i 1)))
                   (etype aliases alpha B
                          (cross (tv_t alpha) (tv_t alpha))))
             alpha x (e_s (p_e x [i_pe zero_pe]))).
Proof.
  apply styp_openstar_3_8
        with (k    := B)
             (tau  := cint)
             (tau' := (cross (tv_t alpha) (tv_t alpha)));
  auto.
Qed.

*)

(* Test rtyp. *)

(* Bug 26, bad contexting in SR_3_2. *)
Example SR_3_1_test:
  rtyp ddot udot (gdot & (varx ~ tau)) (p_e x nil) tau.
Proof.
  unfold tau.
  auto.
  (* apply SR_3_1 with (tau':= tau);
  auto. *)
Qed.

Example SR_3_2_test:
  rtyp ddot udot (gdot & (varx ~ (ptype cint))) (star (p_e x nil)) cint.
Proof.
  auto.
  (* apply SR_3_2;
  auto. *)
Qed.

Example SR_3_3_test:
  rtyp ddot udot gdot (dot (cpair (i_e (i_i 0)) (i_e (i_i 1))) zero_pe) cint.
Proof.
  auto.
  (* apply SR_3_3 with (t1:=cint); *)
Qed.

Example SR_3_4_test:
  rtyp ddot udot (gdot & (varx ~ (cross cint cint)))
       (dot (p_e x nil) one_pe) cint.
Proof.
  auto.
  (* apply SR_3_4 with (t0:= cint). *)
Qed.

Example SR_3_5_test:
  rtyp ddot udot gdot (i_e (i_i 0)) cint.
Proof.
  auto.
  (* apply SR_3_5. *)
Qed.

(* Bug 27, star instead of amp. *)
Example SR_3_6_test:
  rtyp ddot udot (gdot & (varx ~ (cross cint cint)))
       (amp (p_e x nil)) (ptype (cross cint cint)).
Proof.
  auto.
  (* apply SR_3_6. *)
Qed.

Example SR_3_7_test:
  rtyp ddot udot gdot (cpair (i_e (i_i 0)) (i_e (i_i 1))) (cross cint cint).
Proof.
  auto.
  (* apply SR_3_7;*)
Qed.

Example SR_3_8_test:
  rtyp ddot udot (gdot & (varx ~ cint))
       (assign (p_e x nil) (i_e (i_i 0))) cint.
Proof.
  auto.
  (* apply SR_3_8. *)
Qed.

Example SR_3_9_test:
  rtyp ddot udot gdot
       (appl (f_e (dfun cint cint (retn (p_e (bevar 0) nil))))
             (i_e (i_i 0)))
       cint.
Proof.
  (* apply SR_3_9 with (tau':= cint);   auto. *)
  auto.
(*
  applys~ SR_3_9.
  apply_fresh_from* SR_3_13 with fv_of_static_goal.
  simpls~.
  case_nat~.
  destruct (classicT (0 = 0)).
  auto.
  tryfalse.
*)
Qed.

Example SR_3_10_test:
  rtyp ddot udot gdot
       (call (retn (i_e (i_i 0))))
       cint.
Proof.
  auto.
  (* apply SR_3_10;
  auto.*)
Qed.

(* Bogus: can't instantiate anything but a universal type.
Example SR_3_11_test_simpl:
  rtyp
    ddot udot ((varx ~ cint) & gdot)
    (inst (p_e (fevar varx) nil)
          cint)
    cint.
Proof.
  apply SR_3_11 with (k:= B) (tau':= cint); auto. (* 20 runs way too many times. *)
  apply SR_3_1 with (tau':= cint).
  auto.
  admit.
  auto.
  auto.
Qed.
*)

Example SR_3_11_test:
  rtyp
    ddot udot gdot
    (inst (f_e (ufun B (dfun (btvar 0) (btvar 0) (retn (p_e (bevar 0) nil)))))
          cint)
    (arrow cint cint).
Proof.
  apply SR_3_11 with
          (k := B)
            (tau':= (arrow (btvar 0) (btvar 0)));
    try solve[auto]; try solve[simpl; case_nat~].
Qed.

Example simplest_pack:
  rtyp ddot udot (gdot & (varx ~ cint))
        (pack cint (p_e (fevar varx) nil)
              (etype aliases B (btvar 0)))
        (etype aliases B (btvar 0)).
Proof.
  auto.
Qed.

Example pack_int:
  rtyp ddot udot ( gdot & (varx ~ cint))
        (pack cint (p_e (fevar varx) nil)
              (etype aliases B (btvar 0)))
        (etype aliases B (btvar 0)).
Proof.
 apply_fresh_from* SR_3_12 with fv_of_static_goal.
Qed.

Example pack_int_star:
  rtyp ddot udot (gdot & (varx ~ cint))
        (pack cint (amp (p_e (fevar varx) nil))
              (etype aliases B (ptype (btvar 0))))
        (etype aliases B (ptype (btvar 0))).
Proof.
 apply_fresh_from SR_3_12 with fv_of_static_goal; auto.
Qed.

(*
Example pack_int_open:
  varx <> vary ->
  styp ddot udot (gdot & (varx ~ cint) & (vary ~ cint))
        cint
        (openx (pack cint (p_e (fevar varx) nil) (etype aliases B (btvar 0)))
               (e_s (p_e (fevar vary) nil))).
Proof.
  intros.
  apply styp_open_3_7
  with (L:=\{varx})
       (k:=B)
       (tau':= (etype aliases B cint)); try simpl_env; auto.
  intros.
  constructor.
  applys~ SR_3_1; try simpl_env. (* BUG simp_env breaking *)
  (* WFC deficiency *)
  admit.
  apply_fresh_from' SR_3_12 with (fv_of_static_goal) also (etype aliases B cint).

try simpl_env; auto.

  auto.
Qed.

Example let_pack_openstar:
  styp ddot udot ((varx ~ cint) & gdot)
       cint
  (letx (pack cint (p_e (fevar varx) nil) (etype aliases B (btvar 0)))
        (openstar (p_e (bevar 0) nil)
                  (e_s (assign (star (p_e (bevar 0) nil)) (i_e (i_i 7)))))).
Proof.
  apply styp_let_3_6 with
  (L:= (fv_delta ddot \u fv_upsilon udot) \u fv_gamma (varx ~ cint & gdot))
  (tau':= (etype aliases B (btvar 0))).
  (* apply_fresh_from styp_let_3_6 with fv_of_static_goal.*)
  intros.
  simpl.
  case_nat.
  case_nat.
  apply styp_openstar_3_8
  with (L:= \{varx} \u (fv_delta ddot \u fv_upsilon udot) \u fv_gamma (varx ~ cint & gdot))
         (k:= B)
         (tau':= cint).
  simpl.
  intros.
  case_nat.
  constructor.
  constructor.
  constructor.
  apply SR_3_1 with (tau':= (ptype cint)).
  simpl_env.
admit.
  admit.
  constructor.
  admit.
  constructor.
  constructor.
  constructor.
  admit.
  apply_fresh_from SR_3_12 with fv_of_static_goal.
  simpl.
  apply SR_3_1 with (tau':= cint).
  simpl_env.
  constructor.
  constructor.
  constructor.
  auto.
  auto.
  auto.
Qed.

Example pack_int_openstar:
  styp ddot udot ((varx ~ cint) & gdot)
       (ptype cint)
       (openstar (pack cint (p_e (fevar varx) nil)
                       (etype aliases B (btvar 0)))
                 (e_s (p_e (fevar varx) nil))).
Proof.
  apply styp_openstar_3_8
  with (L:=\{varx})
         (k:=B)
         (tau':= (btvar 0)).
  simpl.
  intros.
  case_nat.
  constructor.
  apply SR_3_1 with (tau':= (ptype cint)).
  admit.
  auto.
  auto.
  admit. (* WFC won't solve but should be good. *)

  constructor.
  auto.
  admit.
  apply_fresh_from* SR_3_12 with fv_of_static_goal.
  auto.
Qed.
*)

(* Thesis example munged. Pg 62 line 3.
Definition E_62_3 :=
           (pack (ptype cint) (cpair (amp (p_e (fevar varx) nil)) (p_e (fevar varx) nil))
                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))).
Example SR_3_12_test:
  rtyp ddot udot ((varx ~ cint) & gdot)
    (pack (ptype (cross (ptype cint) cint))
          (cpair (amp (p_e (fevar varx) nil)) (p_e (fevar varx) nil))
          (etype aliases B (ptype (cross (ptype (btvar 0)) (btvar 0)))))
    (etype aliases B (ptype (cross (ptype (btvar 0)) (btvar 0)))).
Proof.
  apply_fresh_from* SR_3_12 with fv_of_static_goal.
  simpl.

Qed.

Example SR_3_12_test:
  rtyp ddot udot gdot
       (pack ((cross cint cint) (cpair (i_e (i_i 0)) (i_e (i_i 1)))
             (etype aliases A (ptype (cross (btvar 0) (btvar 0)))))
       (etype aliases A (ptype (cross (btvar 0) (btvar 0)))).
Proof.
  apply_fresh_from SR_3_12 with fv_of_static_goal.
  simpl in Fry.
  simpl.
  auto.
  apply_fresh_from K_etype with fv_of_kinding_goal.
  intros.
  simpl.
  case_nat.
  apply K_B_A.
  apply K_ptype.
  apply K_cross.
  apply K_B_A.
  auto.
Qed.
*)

Example SR_3_13_test:
  rtyp ddot udot gdot
       (f_e (dfun cint cint (retn (i_e (i_i 0)))))
       (arrow cint cint).
Proof.
  auto.
(*  apply SR_3_13; *)
Qed.

Example SR_3_14_test:
  rtyp ddot udot gdot
       (f_e (ufun B (dfun (btvar 0) (btvar 0) (retn (p_e (bevar 0) nil)))))
       (utype B (arrow (btvar 0) (btvar 0))).
Proof.
  auto.
  (* apply_fresh_from* SR_3_14 with fv_of_static_goal. *)
Qed.

(* Test htyp. *)
Example htyp_empty_test:
  htyp udot gdot hdot gdot.
Proof.
  apply htyp_empty;
  auto.
Qed.

(* Question: we are at the H & (x~v) & H' match issue. *)
Example htyp_xv_test:
  htyp udot gdot (hdot & (varx ~ v) & hdot) (gdot & (varx ~ tau) & gdot).
Proof.
  unfold_test_utilities.
  (* loss of syntax direction here but we don't mind really as eauto is working. *)
  (* auto. *)
  eapply htyp_xv with (g':= gdot);
  auto.
  (* Bug needs hdot & hdot = hdot. *)
Admitted.

(* Test refp. *)

Example refp_empty_test:
  refp h udot.
Proof.
  auto.
  (* apply refp_empty. *)
Qed.

(* BUG
Example refp_pack_test:
  refp [(x,
         pack (cross cint cint)
              (cpair (i_e (i_i 0)) (i_e (i_i 0)))
              (etype aliases alpha A (cross cint cint)))]
       ([((x, [u_pe]), (cross cint cint))] ++ nil).
Proof.
  constructor.
  auto.
  apply refp_pack with
  (k     := A)
  (v     := (cpair (i_e (i_i 0)) (i_e (i_i 0))))
  (v'    := pack (cross cint cint)
                 (cpair (i_e (i_i 0)) (i_e (i_i 0)))
                 (etype aliases alpha A (cross cint cint)))
  (tau   := (cross cint cint))
  (alpha := alpha);
  auto.
  constructor.
  constructor.
  constructor.
  constructor.
  constructor.
   (* Bug, after get(v,nil,v) fix. *)
Admitted.
*)

(* Test prog. *)

Example program_test:
  prog hdot (retn (i_e (i_i 0))).
Proof.
  auto.
  apply program with (u:= udot) (g:= gdot) (tau:=cint);
  auto.
Qed.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Lists.List.
Require Import Coq.Vectors.Vector.
Require Import ExtLib.Structures.Monads.
Import ListNotations VectorNotations MonadNotation.
Open Scope monad_scope.

Require Import Cava.Core.Core.
Require Import Cava.Lib.CavaPrelude.
Require Import Cava.Lib.Combinators.
Require Import Cava.Util.Vector.

(**** IMPORTANT: if you make changes to the API of these definitions, or add new
      ones, make sure you update the reference at docs/reference.md! ****)

Section WithCava.
  Context `{semantics:Cava}.

  (* Build a half adder *)
  Definition halfAdder '(x, y) :=
    partial_sum <- xor2 (x, y) ;;
    carry <- and2 (x, y) ;;
    ret (partial_sum, carry).

  (* A full adder *)
  Definition fullAdder '(cin, (x, y))
                       : cava (signal Bit * signal Bit) :=
    '(xyl, xyh) <- halfAdder (x, y) ;;
    '(xycl, xych) <- halfAdder (xyl, cin) ;;
    cout <- or2 (xyh, xych) ;;
    ret (xycl, cout).

  (* Unsigned adder for n-bit vectors with carry bits both in and out *)
  Definition addC {n : nat}
             (inputs : signal (Vec Bit n) * signal (Vec Bit n) * signal Bit) :
    cava (signal (Vec Bit n) * signal Bit) :=
    let '(x, y, cin) := inputs in
    x <- unpackV x ;;
    y <- unpackV y ;;
    col fullAdder cin (vcombine x y).

  (* Unsigned adder for n-bit vectors with bit-growth and no carry bits in or out *)
  Definition addN {n : nat}
            (xy: signal (Vec Bit n) * signal (Vec Bit n)) :
    cava (signal (Vec Bit n)) :=
    '(sum, _) <- addC (xy, zero) ;;
    ret sum.

  (* Increment an n-bit vector, representing result as an n-bit vector and a
     carry bit *)
  Definition incrC {n : nat} : signal (Vec Bit n) -> cava (signal (Vec Bit n) * signal Bit) :=
    match n with
    | 0 => fun input => ret (input, one) (* incrementing a 0-length vector always overflows *)
    | S m =>
      fun input : signal (Vec Bit (S m)) =>
        (* use synthesizable adder to add 1 *)
        onev <- packV [one] ;;
        sum <- unsignedAdd (input, onev) ;;
        (* resize (1 + Nat.max (S m) 1) to S (S m) *)
        sum <- Vec.resize_default (S (S m)) sum ;;
        (* separate highest bit from rest of sum *)
        sum_low <- Vec.shiftout sum ;;
        sum_high <- Vec.last sum ;;
        ret (sum_low, sum_high)
    end.

  (* Increment an n-bit vector with no bit-growth *)
  Definition incrN {n : nat} (input : signal (Vec Bit n)) : cava (signal (Vec Bit n)) :=
    '(out, _) <- incrC input ;;
    ret out.

  Section XilinxAdders.
    (* Build a full-adder with explicit use of Xilinx FPGA fast carry logic *)
    Definition xilinxFullAdder '(cin, (x, y))
    : cava (signal Bit * signal Bit) :=
      part_sum <- xor2 (x, y) ;;
      sum <- xorcy (part_sum, cin) ;;
      cout <- muxcy part_sum cin x  ;;
      ret (sum, cout).

    (* An unsigned adder built using the fast carry full-adder.*)
    Definition xilinxAdderWithCarry {n: nat}
               (xyc : signal (Vec Bit n) * signal (Vec Bit n) * signal Bit)
      : cava (signal (Vec Bit n) * signal Bit)
      := let '(x, y, cin) := xyc in
         x <- unpackV x ;;
         y <- unpackV y ;;
         col xilinxFullAdder cin (vcombine x y).

    (* An unsigned adder with no bit-growth and no carry in or out *)
    Definition xilinxAdder {n: nat}
               (x y : signal (Vec Bit n))
      : cava (signal (Vec Bit n)) :=
      '(sum, carry) <- xilinxAdderWithCarry (x, y, zero) ;;
      ret sum.
  End XilinxAdders.
End WithCava.


Require Export PArith.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From stablesort Require Import param stablesort.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module CBN_ (M : MergeSig).

Section CBN.

Variable (T : Type) (leT : rel T).

Fixpoint sort2_rec (c : bool) (n : positive) (s : seq T) : seq T * seq T :=
  let rec c1 c2 n s :=
    let (s1, s') := sort2_rec c1 n s in
    let (s2, s'') := sort2_rec c2 n s' in (M.merge leT s1 s2, s'')
  in
  match n, c, s with
    | 1%positive, _, [::] | 2%positive, _, [::] => ([::], s)
    | 1%positive, false, x :: s
    | 1%positive, true, x :: [::] as s
    | 2%positive, _, x :: [::] as s => ([:: x], s)
    | 1%positive, true, x :: y :: s | 2%positive, false, x :: y :: s =>
      ((if leT x y then [:: x; y] else [:: y; x]), s)
    | xO n, _, s => rec false c n s
    | xI n, _, s => rec c true n s
  end.

Definition sort2 (s : seq T) :=
  if bin_of_nat (size s) is Npos n then (sort2_rec false n s).1 else [::].

Import StableSort.

Lemma sort2_recP (c : bool) (n : positive) (s : seq T) :
  let n' := c + nat_of_pos n in
  {t : trace leT |
    take n' s = flatten_trace t & sort2_rec c n s = (sort_trace t, drop n' s) }.
Proof.
elim: n c s => /= [n IHn c s|[n|n|] IHn c s|].
- case: sort2_rec (IHn c s) => [_ s'] [t1 Ht1 [-> s'E]].
  case: sort2_rec (IHn true s') => [_ s''] [t2 Ht2 [-> s''E]].
  rewrite NatTrec.doubleE; exists (branch_trace true t1 t2).
  + rewrite /= -Ht1 -Ht2 s'E take_drop addnACA addnn addSnnS.
    rewrite -[LHS](cat_take_drop (c + nat_of_pos n)) take_take //.
    by rewrite leq_add2l leqW // -addnn leq_addr.
  + by rewrite s''E s'E drop_drop addnACA addnn add1n addSnnS M.mergeE.
- case: sort2_rec (IHn false s) => [_ s'] [t1 Ht1 [-> s'E]].
  case: sort2_rec (IHn c s') => [_ s''] [t2 Ht2 [-> s''E]].
  rewrite NatTrec.doubleE; exists (branch_trace true t1 t2).
  + rewrite /= -Ht1 -Ht2 s'E take_drop addnACA addnn add0n addn0.
    rewrite -[LHS](cat_take_drop (nat_of_pos (xI n))) take_take //.
    by rewrite -addnn addnA leq_addl.
  + by rewrite s''E s'E drop_drop addnACA addnn addn0 M.mergeE.
- case: sort2_rec (IHn false s) => [_ s'] [t1 Ht1 [-> s'E]].
  case: sort2_rec (IHn c s') => [_ s''] [t2 Ht2 [-> s''E]].
  rewrite NatTrec.doubleE; exists (branch_trace true t1 t2).
  + rewrite /= -Ht1 -Ht2 s'E take_drop addnACA addnn add0n addn0.
    rewrite -[LHS](cat_take_drop (nat_of_pos (xO n))) take_take //.
    by rewrite -addnn addnA leq_addl.
  + by rewrite s''E s'E drop_drop addnACA addnn addn0 M.mergeE.
- case: c s => [] [|x [|y s]].
  + by exists (leaf_trace true [::] isT).
  + by exists (leaf_trace true [:: x] isT).
  + case: sort2_rec (IHn false [:: x, y & s]) => [_ s'] [t1 Ht1 [-> s'E]].
    case: sort2_rec (IHn true s') => [_ s''] [t2 Ht2 [-> s''E]].
    rewrite NatTrec.doubleE; exists (branch_trace true t1 t2).
    * by rewrite /= -Ht1 -Ht2 s'E.
    * by rewrite s''E s'E M.mergeE.
  + by exists (leaf_trace true [::] isT).
  + by exists (leaf_trace true [:: x] isT).
  + have sorted_xy: sorted (fun x0 y0 => leT x0 y0 == leT x y) [:: x; y].
      by rewrite /= eqxx.
    exists (leaf_trace (leT x y) [:: x; y] sorted_xy).
      by rewrite /= take0.
    by rewrite /= drop0.
- case=> [[|x [|y s]] | [|x s]] //=.
  + by exists (leaf_trace true [::] isT).
  + by exists (leaf_trace true [:: x] isT).
  + have sorted_xy: sorted (fun x0 y0 => leT x0 y0 == leT x y) [:: x; y].
      by rewrite /= eqxx.
    exists (leaf_trace (leT x y) [:: x; y] sorted_xy).
      by rewrite take0.
    by rewrite drop0.
  + by exists (leaf_trace true [::] isT).
  + exists (leaf_trace true [:: x] isT).
      by rewrite take0.
    by rewrite drop0.
Qed.

Lemma sort2P (s : seq T) :
  {t : trace leT | s = flatten_trace t & sort2 s = sort_trace t}.
Proof.
rewrite /sort2.
case: (bin_of_nat _) (bin_of_natK (size s)) => [|n] //=.
- by move=> /esym /size0nil ->; exists (leaf_trace true [::] isT).
- move=> nE; case: (sort2_recP false n s) => t /=.
  by rewrite add0n nE take_oversize // drop_oversize // => -> -> /=; exists t.
Qed.

End CBN.

Realizer M.merge as merge_R arity 2 := M.merge_R.

Parametricity sort2.

Definition sort2_stable := StableSort.Pack sort2 sort2_R sort2P.

End CBN_.

Module CBN := CBN_(Merge).
Module CBNAcc := CBN_(MergeAcc).

Canonical CBN.sort2_stable.
Canonical CBNAcc.sort2_stable.


From mm Require Import util abt abtutil map.

Module exprop.
  Inductive t' :=
  | abs
  | app
  | tt
  | ff
  | If
  | ref
  | deref
  | assign
  | addr (a : nat)
  .
  Definition t := t'.

  Definition arity (op : t) : arity.t :=
    match op with
    | abs => [1]
    | app => [0; 0]
    | tt => []
    | ff => []
    | If => [0; 0; 0]
    | ref => [0]
    | deref => [0]
    | assign => [0; 0]
    | addr _ => []
    end.

  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
    decide equality.
    apply eq_nat_dec.
  Defined.
End exprop.

Module type.
  Inductive t :=
  | bool
  | arrow : t -> t -> t
  | ref : t -> t
  .
End type.

Module expr_abt := abt.abt exprop.

Module expr_ast.
  Inductive t :=
  | var (x : nat) : t
  | abs : t -> t
  | app : t -> t -> t
  | tt : t
  | ff : t
  | If : t -> t -> t -> t
  | addr (a : nat) : t
  | ref : t -> t
  | deref : t -> t
  | assign : t -> t -> t
  .
End expr_ast.

Module expr_basis.
  Module A := expr_abt.

  Import expr_ast.
  Definition t := t.

  Fixpoint to_abt (ty : t) : A.t :=
    match ty with
    | var n => A.var n
    | abs e' => A.op exprop.abs [A.bind 1 (to_abt e')]
    | app e1 e2 => A.op exprop.app [A.bind 0 (to_abt e1); A.bind 0 (to_abt e2)]
    | tt => A.op exprop.tt []
    | ff => A.op exprop.ff []
    | If e1 e2 e3 => A.op exprop.If [A.bind 0 (to_abt e1);
                                            A.bind 0 (to_abt e2);
                                            A.bind 0 (to_abt e3)]
    | addr n => A.op (exprop.addr n) []
    | ref e' => A.op exprop.ref [A.bind 0 (to_abt e')]
    | deref e' => A.op exprop.deref [A.bind 0 (to_abt e')]
    | assign e1 e2 => A.op exprop.assign [A.bind 0 (to_abt e1); A.bind 0 (to_abt e2)]
    end.

  Fixpoint of_abt (a : A.t) : t :=
    match a with
    | A.var n => var n
    | A.op exprop.abs [A.bind 1 a'] => abs (of_abt a')
    | A.op exprop.app [A.bind 0 a1; A.bind 0 a2] => app (of_abt a1) (of_abt a2)
    | A.op exprop.tt [] => tt
    | A.op exprop.ff [] => ff
    | A.op exprop.If [A.bind 0 a1; A.bind 0 a2; A.bind 0 a3] =>
      If (of_abt a1) (of_abt a2) (of_abt a3)
    | A.op (exprop.addr n) [] => addr n
    | A.op exprop.ref [A.bind 0 a'] => ref (of_abt a')
    | A.op exprop.deref [A.bind 0 a'] => deref (of_abt a')
    | A.op exprop.assign [A.bind 0 a1; A.bind 0 a2] => assign (of_abt a1) (of_abt a2)
    | _ => var 0 (* bogus *)
    end.

  Fixpoint t_map ov c (e : t) : t :=
    match e with
    | var x => ov c x
    | abs e' => abs (t_map ov (S c) e')
    | app e1 e2 => app (t_map ov c e1) (t_map ov c e2)
    | tt => tt
    | ff => ff
    | If e1 e2 e3 => If (t_map ov c e1) (t_map ov c e2) (t_map ov c e3)
    | addr n => addr n
    | ref e' => ref (t_map ov c e')
    | deref e' => deref (t_map ov c e')
    | assign e1 e2 => assign (t_map ov c e1) (t_map ov c e2)
    end.

  Fixpoint shift c d (e : t) : t :=
    match e with
    | var x => var (if x <? c then x else x + d)
    | abs e' => abs (shift (S c) d e')
    | app e1 e2 => app (shift c d e1) (shift c d e2)
    | tt => tt
    | ff => ff
    | If e1 e2 e3 => If (shift c d e1) (shift c d e2) (shift c d e3)
    | addr n => addr n
    | ref e' => ref (shift c d e')
    | deref e' => deref (shift c d e')
    | assign e1 e2 => assign (shift c d e1) (shift c d e2)
    end.

  Fixpoint subst rho e :=
    match e with
    | var x => match nth_error rho x with
                  | Some e' => e'
                  | None => e
                  end
    | abs e' => abs (subst (var 0 :: map (shift 0 1) rho) e')
    | app e1 e2 => app (subst rho e1) (subst rho e2)
    | tt => tt
    | ff => ff
    | If e1 e2 e3 => If (subst rho e1) (subst rho e2) (subst rho e3)
    | addr n => addr n
    | ref e' => ref (subst rho e')
    | deref e' => deref (subst rho e')
    | assign e1 e2 => assign (subst rho e1) (subst rho e2)
    end.

  Fixpoint wf n e :=
    match e with
    | var x => x < n
    | abs e' => wf (S n) e'
    | app e1 e2 => wf n e1 /\ wf n e2
    | tt => True
    | ff => True
    | If e1 e2 e3 => wf n e1 /\ wf n e2 /\ wf n e3
    | addr _ => True
    | ref e' => wf n e'
    | deref e' => wf n e'
    | assign e1 e2 => wf n e1 /\ wf n e2
    end.

  Fixpoint identity_subst (n : nat) : list t :=
    match n with
    | 0 => []
    | S n => var 0 :: map (shift 0 1) (identity_subst n)
    end.

  Lemma ws_to_abt : forall e, A.ws (to_abt e).
  Proof. A.basis_util.prove_ws_to_abt. Qed.

  Lemma of_to_abt : forall e, of_abt (to_abt e) = e.
  Proof. A.basis_util.prove_of_to_abt. Qed.

  Lemma to_of_abt : forall a, A.ws a -> to_abt (of_abt a) = a.
  Proof. A.basis_util.prove_to_of_abt to_abt of_abt. Qed.

  Lemma t_map_to_abt_comm : forall ov e c,
      to_abt (t_map ov c e) = A.t_map (fun c x => to_abt (ov c x)) c (to_abt e).
  Proof. A.basis_util.prove_t_map_to_abt_comm. Qed.

  Lemma shift_to_abt_comm : forall e c d, to_abt (shift c d e) = A.shift c d (to_abt e).
  Proof. A.basis_util.prove_shift_to_abt_comm. Qed.

  Lemma map_shift_to_abt_comm :
    forall c d rho, map to_abt (map (shift c d) rho) = map (A.shift c d) (map to_abt rho).
  Proof. A.basis_util.prove_map_shift_to_abt_comm shift_to_abt_comm. Qed.

  Lemma subst_to_abt_comm : forall e rho,
      to_abt (subst rho e) = A.subst (map to_abt rho) (to_abt e).
  Proof. A.basis_util.prove_subst_to_abt_comm t map_shift_to_abt_comm. Qed.

  Lemma wf_to_abt : forall e n, wf n e <-> A.wf n (to_abt e).
  Proof. A.basis_util.prove_wf_to_abt. Qed.

  Lemma identity_subst_to_abt_comm :
    forall n, List.map to_abt (identity_subst n) = A.identity_subst n.
  Proof. A.basis_util.prove_identity_subst_to_abt_comm map_shift_to_abt_comm. Qed.

  Definition var := var.
  Arguments var /.
  Lemma var_to_abt : forall n, to_abt (var n) = A.var n.
  Proof. reflexivity. Qed.
End expr_basis.

Module expr.
  Include abt_util expr_basis.
  Notation abs := expr_ast.abs.
  Notation app := expr_ast.app.
  Notation tt := expr_ast.tt.
  Notation ff := expr_ast.ff.
  Notation If := expr_ast.If.
  Notation addr := expr_ast.addr.
  Notation ref := expr_ast.ref.
  Notation deref := expr_ast.deref.
  Notation assign := expr_ast.assign.
End expr.

Module has_type.
  Inductive t : NatMap.t type.t -> list type.t -> expr.t -> type.t -> Prop :=
  | var : forall S G x ty,
      List.nth_error G x = Some ty ->
      t S G (expr.var x) ty
  | tt : forall S G,
      t S G expr.tt type.bool
  | ff : forall S G,
      t S G expr.ff type.bool
  | abs : forall S G e ty1 ty2,
      t S (ty1 :: G) e ty2 ->
      t S G (expr.abs e) (type.arrow ty1 ty2)
  | app : forall S G e1 e2 ty1 ty2,
      t S G e1 (type.arrow ty1 ty2) ->
      t S G e2 ty1 ->
      t S G (expr.app e1 e2) ty2
  | If : forall S G e1 e2 e3 ty,
      t S G e1 type.bool ->
      t S G e2 ty ->
      t S G e3 ty ->
      t S G (expr.If e1 e2 e3) ty
  | addr : forall S G a ty,
      NatMap.get a S = Some ty ->
      t S G (expr.addr a) ty
  | ref : forall S G e ty,
      t S G e ty ->
      t S G (expr.ref e) (type.ref ty)
  | deref : forall S G e ty,
      t S G e (type.ref ty) ->
      t S G (expr.deref e) ty
  | assign : forall S G e1 e2 ty,
      t S G e1 (type.ref ty) ->
      t S G e2 ty ->
      t S G (expr.assign e1 e2) type.bool
  .

  Lemma wf :
    forall S G e ty,
      t S G e ty ->
      expr.wf (List.length G) e.
  Proof.
    induction 1; simpl in *; intuition.
    pose proof nth_error_Some G x. intuition congruence.
  Qed.

  Lemma shift :
    forall S G e ty,
      t S G e ty ->
      forall G1 G2 G',
        G1 ++ G2 = G ->
        t S (G1 ++ G' ++ G2) (expr.shift (List.length G1) (List.length G') e) ty.
  Proof.
    induction 1; intros G1 G2 G' E; subst G; simpl; try solve [econstructor; eauto].
    - constructor.
      do_ltb.
      + now rewrite nth_error_app1 in * by assumption.
      + rewrite !nth_error_app2 in * by lia.
        now do_app2_minus.
    - cbn [expr.shift].
      constructor.
      change (ty1 :: G1 ++ G' ++ G2) with ((ty1 :: G1) ++ G' ++ G2).
      now apply IHt.
  Qed.

  Lemma shift' :
    forall S G e ty G',
      t S G e ty ->
      t S (G' ++ G) (expr.shift 0 (List.length G') e) ty.
  Proof.
    intros.
    now apply shift with (G := G) (G1 := []).
  Qed.

  Lemma shift_cons :
    forall S G e ty ty0,
      t S G e ty ->
      t S (ty0 :: G) (expr.shift 0 1 e) ty.
  Proof.
    intros.
    now apply shift' with (G' := [ty0]).
  Qed.

  Lemma subst :
    forall S G e ty,
      t S G e ty ->
      forall G' rho,
        List.Forall2 (t S G') rho G ->
        t S G' (expr.subst rho e) ty.
  Proof.
    induction 1; intros G' rho F; cbn [expr.subst]; try solve [econstructor; eauto].
    - destruct (Forall2_nth_error2 F H) as [z [Hz Ht]].
      unfold expr.t in *.
      simpl.
      now rewrite Hz.
    - constructor.
      apply IHt.
      constructor.
      + now constructor.
      + apply Forall2_map_l.
        apply Forall2_from_forall.
        * now erewrite Forall2_length by eauto.
        * intros.
          apply shift_cons.
          eapply (Forall2_nth_error F); eauto.
  Qed.
End has_type.

Module value.
  Inductive t : expr.t -> Prop :=
  | tt : t expr.tt
  | ff : t expr.ff
  | abs : forall e, t (expr.abs e)
  | addr : forall a, t (expr.addr a)
  .
End value.

Module step.
  Inductive t : NatMap.t expr.t * expr.t -> NatMap.t expr.t * expr.t -> Prop :=
  | beta : forall h e1 e2,
      value.t e2 ->
      t (h, expr.app (expr.abs e1) e2)
        (h, expr.subst [e2] e1)
  | app1 : forall h h' e1 e1' e2,
      t (h, e1) (h', e1') ->
      t (h, expr.app e1 e2) (h', expr.app e1' e2)
  | app2  : forall h h' e1 e2 e2',
      value.t e1 ->
      t (h, e2) (h', e2') ->
      t (h, expr.app e1 e2) (h', expr.app e1 e2')
  | IfT : forall h e2 e3,
      t (h, expr.If expr.tt e2 e3) (h, e2)
  | IfF : forall h e2 e3,
      t (h, expr.If expr.ff e2 e3) (h, e3)
  | If : forall h h' e1 e1' e2 e3,
      t (h, e1) (h', e1') ->
      t (h, expr.If e1 e2 e3) (h', expr.If e1' e2 e3)
  | alloc : forall h a v,
      NatMap.get a h = None ->
      value.t v ->
      t (h, expr.ref v) (NatMap.set a v h, expr.addr a)
  | ref : forall h h' e e',
      t (h, e) (h', e') ->
      t (h, expr.ref e) (h', expr.ref e')
  | deref_beta :
      forall h a v,
        NatMap.get a h = Some v ->
        t (h, expr.deref (expr.addr a)) (h, v)
  | deref : forall h h' e e',
      t (h, e) (h', e') ->
      t (h, expr.deref e) (h', expr.deref e')
  | assign_beta :
      forall h a v,
        NatMap.get a h <> None ->
        value.t v ->
        t (h, expr.assign (expr.addr a) v) (NatMap.set a v h, expr.tt)
  | assign1 : forall h h' e1 e1' e2,
      t (h, e1) (h', e1') ->
      t (h, expr.assign e1 e2) (h', expr.assign e1' e2)
  | assign2 : forall h h' v e2 e2',
        value.t v ->
        t (h, e2) (h', e2') ->
        t (h, expr.assign v e2) (h', expr.assign v e2')
  .
  Global Hint Constructors t : core.

  Definition star : _ -> _ -> Prop := clos_refl_trans_n1 _ t.

  Lemma step_l :
    forall e1 e2 e3,
      step.t e1 e2 ->
      step.star e2 e3 ->
      step.star e1 e3.
  Proof.
    intros e1 e2 e3 S Star.
    apply clos_rt_rtn1.
    apply clos_rtn1_rt in Star.
    eapply rt_trans; eauto using rt_step.
  Qed.

  Lemma star_app1 :
    forall h h' e1 e1' e2,
      star (h, e1) (h', e1') ->
      star (h, expr.app e1 e2) (h', expr.app e1' e2).
  Proof.
    intros h h' e1 e1' e2 Star.
    remember (h, e1) as c.
    remember (h', e1') as c'.
    revert h h' e1 e1' Heqc Heqc' e2.
    induction Star; intros h h' e1 e1' Heqc Heqc' e2; subst.
    - invc Heqc'. constructor.
    - destruct y as [h0 e0].
      econstructor; [|apply IHStar].
      all: eauto.
  Qed.

  Lemma star_app2 :
    forall h h' e1 e2 e2',
      value.t e1 ->
      star (h, e2) (h', e2') ->
      star (h, expr.app e1 e2) (h', expr.app e1 e2').
  Proof.
    intros h h' e1 e2 e2' Val1 Star.
    remember (h, e2) as c.
    remember (h', e2') as c'.
    revert h h' e2 e2' Heqc Heqc' e1 Val1.
    induction Star; intros h h' e2 e2' Heqc Heqc' e1 Val1; subst.
    - invc Heqc'. constructor.
    - destruct y as [h0 e0].
      econstructor; [apply app2 | apply IHStar]; eauto.
  Qed.

  Lemma star_If :
    forall h h' e1 e1' e2 e3,
      star (h, e1) (h', e1') ->
      star (h, expr.If e1 e2 e3) (h', expr.If e1' e2 e3).
  Proof.
    intros h h' e1 e1' e2 e3 Star.
    remember (h, e1) as c.
    remember (h', e1') as c'.
    revert h h' e1 e1' Heqc Heqc' e2 e3.
    induction Star; intros h h' e1 e1' Heqc Heqc' e2 e3; subst.
    - invc Heqc'. constructor.
    - destruct y as [h0 e0].
      econstructor; [apply If|apply IHStar]; eauto.
  Qed.

  Lemma star_trans :
    forall e1 e2 e3,
      star e1 e2 ->
      star e2 e3 ->
      star e1 e3.
  Proof.
    intros e1 e2 e3 S1 S2.
    apply clos_rtn1_rt in S1.
    apply clos_rtn1_rt in S2.
    apply clos_rt_rtn1.
    eauto using rt_trans.
  Qed.

  Lemma star_refl :
    forall e,
      star e e.
  Proof.
    constructor.
  Qed.

  Global Hint Resolve star_app2 star_app1 star_refl : core.

  Lemma value :
    forall v,
      value.t v ->
      forall h h' e',
        step.t (h, v) (h', e') ->
        False.
  Proof.
    induction 1; intros h h' e' Step; inversion Step; subst.
  Qed.

  Lemma star_value :
    forall h h' v e',
      value.t v ->
      step.star (h, v) (h', e') ->
      e' = v.
  Proof.
    intros h h' v e' Val Star.
    apply clos_rtn1_rt in Star.
    apply clos_rt_rt1n in Star.
    inversion Star; subst; auto.
    destruct y as [h0 e0].
    exfalso; eauto using value.
  Qed.

(*
  Lemma det :
    forall e1 e2 e2',
      t e1 e2 ->
      t e1 e2' ->
      e2 = e2'.
  Proof.
    intros e1 e2 e2' Step.
    revert e2'.
    induction Step; intros e2'' Step'; invc Step'; auto;
      try match goal with
          | [ H : _ |- _ ] => solve [invc H]
          end;
      try solve [exfalso; eauto using value];
      f_equal; auto.
  Qed.

  Lemma star_step_det :
    forall e1 e2 e2',
      star e1 e2 ->
      t e1 e2' ->
      e1 = e2 \/ star e2' e2.
  Proof.
    intros e1 e2 e2' Star Step.
    apply clos_rtn1_rt in Star.
    apply clos_rt_rt1n in Star.
    invc Star; auto.
    right.
    assert (y = e2') by eauto using det. subst y.
    apply clos_rt_rtn1.
    apply clos_rt1n_rt.
    auto.
  Qed.

  Lemma star_det :
    forall e1 e2 e2',
      star e1 e2 ->
      star e1 e2' ->
      star e2 e2' \/ star e2' e2.
  Proof.
    intros e1 e2 e2' Star Star'.
    revert e2' Star'.
    induction Star; intros e2' Star'.
    - auto.
    - specialize (IHStar _ Star'). clear Star'.
      intuition.
      + pose proof star_step_det _ _ _ H0 H.
        intuition.
        subst. right. econstructor. eauto. constructor.
      + right. econstructor. eauto. auto.
  Qed.

  Lemma star_det_value :
    forall e v v',
      step.star e v ->
      step.star e v' ->
      value.t v ->
      value.t v' ->
      v = v'.
  Proof.
    intros e v v' Star Star' Val Val'.
    pose proof star_det _ _ _ Star Star'; clear Star Star'.
    destruct H as [H|H];
      eapply star_value in H; eauto.
  Qed.
*)
End step.