From iris.program_logic Require Export language ectx_language ectxi_language.
From iris_examples.logrel.prelude Require Export base.
From iris.algebra Require Export ofe.
From stdpp Require Import gmap.

Module F_mu_ref_conc.
  Definition loc := positive.

  Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive binop := Add | Sub | Mult | Eq | Le | Lt.

  Instance binop_dec_eq (op op' : binop) : Decision (op = op').
  Proof. solve_decision. Defined.

  Inductive expr :=
  | Var (x : var)
  | Rec (e : {bind 2 of expr})
  | App (e1 e2 : expr)
  | Lam (e : {bind expr})
  | LetIn (e1 : expr) (e2 : {bind expr})
  | Seq (e1 e2 : expr)
  (* Base Types *)
  | Unit
  | Nat (n : nat)
  | Bool (b : bool)
  | BinOp (op : binop) (e1 e2 : expr)
  (* If then else *)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Concurrency *)
  | Fork (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  (* Compare and swap used for fine-grained concurrency *)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  (* Notation for bool and nat *)
  Notation "#♭ b" := (Bool b) (at level 20).
  Notation "#n n" := (Nat n) (at level 20).

  Instance expr_dec_eq (e e' : expr) : Decision (e = e').
  Proof. solve_decision. Defined.

  Inductive val :=
  | RecV (e : {bind 1 of expr})
  | LamV (e : {bind expr})
  | TLamV (e : {bind 1 of expr})
  | UnitV
  | NatV (n : nat)
  | BoolV (b : bool)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | FoldV (v : val)
  | LocV (l : loc).

  (* Notation for bool and nat *)
  Notation "'#♭v' b" := (BoolV b) (at level 20).
  Notation "'#nv' n" := (NatV n) (at level 20).

  Fixpoint binop_eval (op : binop) : nat → nat → val :=
    match op with
    | Add => λ a b, #nv(a + b)
    | Sub => λ a b, #nv(a - b)
    | Mult => λ a b, #nv(a * b)
    | Eq => λ a b, if (eq_nat_dec a b) then #♭v true else #♭v false
    | Le => λ a b, if (le_dec a b) then #♭v true else #♭v false
    | Lt => λ a b, if (lt_dec a b) then #♭v true else #♭v false
    end.

  Instance val_dec_eq (v v' : val) : Decision (v = v').
  Proof. solve_decision. Defined.

  Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | RecV e => Rec e
    | LamV e => Lam e
    | TLamV e => TLam e
    | UnitV => Unit
    | NatV v => Nat v
    | BoolV v => Bool v
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | FoldV v => Fold (of_val v)
    | LocV l => Loc l
    end.

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Rec e => Some (RecV e)
    | Lam e => Some (LamV e)
    | TLam e => Some (TLamV e)
    | Unit => Some UnitV
    | Nat n => Some (NatV n)
    | Bool b => Some (BoolV b)
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Fold e => v ← to_val e; Some (FoldV v)
    | Loc l => Some (LocV l)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | LetInCtx (e2 : expr)
  | SeqCtx (e2 : expr)
  | TAppCtx
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | BinOpLCtx (op : binop) (e2 : expr)
  | BinOpRCtx (op : binop) (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | IfCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val)
  | CasLCtx (e1 : expr)  (e2 : expr)
  | CasMCtx (v0 : val) (e2 : expr)
  | CasRCtx (v0 : val) (v1 : val).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | LetInCtx e2 => LetIn e e2
    | SeqCtx e2 => Seq e e2
    | TAppCtx => TApp e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | BinOpLCtx op e2 => BinOp op e e2
    | BinOpRCtx op v1 => BinOp op (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | IfCtx e1 e2 => If e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    | CasLCtx e1 e2 => CAS e e1 e2
    | CasMCtx v0 e2 => CAS (of_val v0) e e2
    | CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
    end.

  Definition state : Type := gmap loc val.

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Rec e1) e2) σ [] e1.[(Rec e1), e2/] σ []
  (* Lam-β *)
  | LamBetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  (* LetIn-β *)
  | LetInBetaS e1 e2 v2 σ :
      to_val e1 = Some v2 →
      head_step (LetIn e1 e2) σ [] e2.[e1/] σ []
  (* Seq-β *)
  | SeqBetaS e1 e2 v2 σ :
      to_val e1 = Some v2 →
      head_step (Seq e1 e2) σ [] e2 σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
    (* nat bin op *)
  | BinOpS op a b σ :
      head_step (BinOp op (#n a) (#n b)) σ [] (of_val (binop_eval op a b)) σ []
  (* If then else *)
  | IfFalse e1 e2 σ :
      head_step (If (#♭ false) e1 e2) σ [] e2 σ []
  | IfTrue e1 e2 σ :
      head_step (If (#♭ true) e1 e2) σ [] e1 σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ [] e σ []
  (* Polymorphic Types *)
  | TBeta e σ :
      head_step (TApp (TLam e)) σ [] e σ []
  (* Concurrency *)
  | ForkS e σ:
      head_step (Fork e) σ [] Unit σ [e]
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ [] (Loc l) (<[l:=v]>σ) []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Loc l)) σ [] (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Loc l) e) σ [] Unit (<[l:=v]>σ) []
  (* Compare and swap *)
  | CasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some vl → vl ≠ v1 →
     head_step (CAS (Loc l) e1 e2) σ [] (#♭ false) σ []
  | CasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some v1 →
     head_step (CAS (Loc l) e1 e2) σ [] (#♭ true) (<[l:=v2]>σ) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κs e2 σ2 ef :
    head_step e1 σ1 κs e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κs e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κs e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom (gset loc) σ) in
    to_val e = Some v → head_step (Alloc e) σ [] (Loc l) (<[l:=v]>σ) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.

  Lemma val_head_stuck e1 σ1 κs e2 σ2 efs : head_step e1 σ1 κs e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.

  Canonical Structure stateO := leibnizO state.
  Canonical Structure valO := leibnizO val.
  Canonical Structure exprO := leibnizO expr.
End F_mu_ref_conc.

Canonical Structure F_mu_ref_conc_ectxi_lang :=
  EctxiLanguage F_mu_ref_conc.lang_mixin.
Canonical Structure F_mu_ref_conc_ectx_lang :=
  EctxLanguageOfEctxi F_mu_ref_conc_ectxi_lang.
Canonical Structure F_mu_ref_conc_lang :=
  LanguageOfEctx F_mu_ref_conc_ectx_lang.

Export F_mu_ref_conc.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | CAS e1 e2 e3 => is_Some (to_val e1) ∧ is_Some (to_val e2)
                   ∧ is_Some (to_val e3)
  | _ => False
  end.
Local Hint Resolve language.val_irreducible.
Local Hint Resolve to_of_val.
Local Hint Unfold language.irreducible.
Global Instance is_atomic_correct s e : is_atomic e → Atomic s e.
Proof.
  intros Ha; apply strongly_atomic_atomic,  ectx_language_atomic.
  - destruct 1; simpl in *; try tauto; eauto.
  - intros K e' -> Hval%eq_None_not_Some.
    induction K using rev_ind; first done.
    simpl in Ha; rewrite fill_app in Ha; simpl in Ha.
    destruct Hval. apply (fill_val K e'); simpl in *.
    destruct x; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Hint Extern 0 (Atomic _ _) => solve_atomic.
Hint Extern 0 (Atomic _ _) => solve_atomic : typeclass_instances.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import bedrock2.Array.
Require Import bedrock2.Scalars.
Require Import bedrock2.Syntax.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Datatypes.List.
Require Import coqutil.Datatypes.PropSet.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Equivalence.
Require Import Crypto.Bedrock.Field.Translation.Proofs.EquivalenceProperties.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Flatten.
Require Import Crypto.Bedrock.Field.Translation.Proofs.UsedVarnames.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Translation.Flatten.
Require Import Crypto.Bedrock.Field.Translation.LoadStoreList.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Import ListNotations.

Import AbstractInterpretation.Compilers.
Import API.Compilers.
Import Types.Notations.

Section LoadStoreList.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.

  Local Existing Instance rep.Z.

  (* states that access sizes are within machine integer width *)
  Fixpoint base_access_sizes_good {t}
    : base_access_sizes (listZ:=rep.listZ_mem) t -> Prop :=
    match t with
    | base.type.prod a b =>
      fun s => base_access_sizes_good (fst s)
               /\ base_access_sizes_good (snd s)
    | base_listZ =>
      fun s =>
        (Z.of_nat (Memory.bytes_per
                     (width:=width) s) * 8 <= width)%Z
    | _ => fun _ => True
    end.
  Definition access_sizes_good {t}
    : access_sizes (listZ:=rep.listZ_mem) t -> Prop :=
    match t with
    | type.base _ => base_access_sizes_good
    | _ => fun _ => True
    end.
  Fixpoint access_sizes_good_args {t}
    : type.for_each_lhs_of_arrow
        (access_sizes (listZ:=rep.listZ_mem)) t -> Prop :=
    match t with
    | type.base _ => fun _ : unit => True
    | type.arrow _ _ =>
      fun s => access_sizes_good (fst s) /\ access_sizes_good_args (snd s)
    end.

  Lemma access_sizes_good_in_range size :
    base_access_sizes_good (t:=base_listZ) size ->
    (2 ^ (Z.of_nat (Memory.bytes_per
                      (width:=width) size) * 8)
     <= 2 ^ width)%Z.
  Proof.
    cbv [base_access_sizes_good]; intros.
    apply Z.pow_le_mono_r; lia.
  Qed.

  (* states that each list Z is within its access size *)
  Fixpoint within_base_access_sizes {t}
    : base.interp t ->
      base_access_sizes (listZ:=rep.listZ_mem) t -> Prop :=
      match t with
      | base.type.prod a b =>
        fun x s =>
          within_base_access_sizes (fst x) (fst s) /\
          within_base_access_sizes (snd x) (snd s)
      | base_listZ =>
        fun x s =>
          let bytes :=
              Z.of_nat (Memory.bytes_per (width:=width) s) in
          Forall (fun z => 0 <= z < 2 ^ (bytes * 8))%Z x
      | _ => fun _ _ => True
      end.

  Fixpoint within_access_sizes_args {t}
    : type.for_each_lhs_of_arrow API.interp_type t ->
      type.for_each_lhs_of_arrow
        (access_sizes (listZ:=rep.listZ_mem)) t -> Prop :=
    match t with
    | type.base _ => fun _ _ => True
    | type.arrow (type.base s) _ =>
      fun x s =>
        within_base_access_sizes (fst x) (fst s) /\
        within_access_sizes_args (snd x) (snd s)
    | _ => fun _ _ => False
    end.

  (* separation-logic relation that says space exists in memory for lists
     (other values are ignored) *)
  Fixpoint lists_reserved {t}
    : base_listonly nat t ->
      base_rtype (listZ:=rep.listZ_mem) t ->
      base_access_sizes (listZ:=rep.listZ_mem) t ->
      locals ->
      mem ->
      Prop :=
    match t as t0 return
          base_listonly nat t0 -> base_rtype t0 ->
          base_access_sizes (listZ:=rep.listZ_mem) t0 -> _ with
    | base.type.prod a b =>
      fun x y s locals =>
        sep (lists_reserved (fst x) (fst y) (fst s) locals)
            (lists_reserved (snd x) (snd y) (snd s) locals)
    | base_listZ =>
      fun n loc sz locals =>
        (Lift1Prop.ex1
           (fun oldvalues : list Z =>
              sep (emp (length oldvalues = n))
                  (rep.equiv (rep:=rep.listZ_mem)
                              oldvalues loc sz locals)))
    | base_Z => fun _ _ _ _ => emp True
    |  _ => fun _ _ _ _ => emp False
    end.

  Fixpoint list_lengths_from_value {t}
    : base.interp t -> base_listonly nat t :=
    match t as t0 return base.interp t0 -> base_listonly nat t0 with
    | base.type.prod a b =>
      fun x : base.interp a * base.interp b =>
        (list_lengths_from_value (fst x),
         list_lengths_from_value (snd x))
    | base_listZ => fun x : list Z => length x
    | _ => fun _ => tt
    end.

  Fixpoint list_lengths_from_args {t}
    : type.for_each_lhs_of_arrow API.interp_type t ->
      type.for_each_lhs_of_arrow list_lengths t :=
    match t with
    | type.base b => fun _ => tt
    | type.arrow (type.base a) b =>
      fun x =>
        (list_lengths_from_value (fst x), list_lengths_from_args (snd x))
    | type.arrow a b =>
      fun x => (tt, list_lengths_from_args (snd x))
    end.

  Definition lists_reserved_with_initial_context {t}
             (lengths : base_listonly nat (type.final_codomain t))
             (argnames : type.for_each_lhs_of_arrow
                           (ltype (listZ:=rep.listZ_mem)) t)
             (retnames : base_ltype (type.final_codomain t))
             (retsizes : base_access_sizes (type.final_codomain t))
             (flat_args : list word)
    : mem -> Prop :=
    let outptrs :=
        flatten_listonly_base_ltype (fst (extract_listnames retnames)) in
    match map.of_list_zip
            (outptrs ++ (flatten_argnames argnames))
            flat_args with
    | Some init_locals =>
      lists_reserved
        lengths (base_rtype_of_ltype retnames) retsizes init_locals
    | None => emp True
    end.

  Lemma lists_reserved_0 {listZ:rep.rep base_listZ} start sizes :
    forall (locals:locals),
    Lift1Prop.iff1
      (lists_reserved (t:=base_listZ) 0%nat start sizes locals)
      (emp (exists x, locally_equivalent_base (t:=base_Z) x start locals)).
  Proof.
    cbv [lists_reserved].
    split; intros;
      repeat match goal with
             | _ => progress (sepsimpl; subst)
             | _ => progress cbn [locally_equivalent_base
                                    equivalent_base rep.equiv rep.Z] in *
             | H : Datatypes.length _ = 0%nat |- _ =>
               apply length0_nil in H; subst
             | H : rep.equiv _ _ _ _ _ |- _ => apply equiv_nil_iff1 in H
             | |- Lift1Prop.ex1 _ _ => eexists
             | |- exists _, _ => eexists
             | |- _ /\ _ => split
             | |- rep.equiv [] _ _ _ _ => apply equiv_nil_iff1
             | _ => solve [eauto using List.length_nil]
             | _ => eexists; split; solve [eauto]
             end.
  Qed.

  Lemma lists_reserved_only_differ_undef t :
    forall lengths locs s locals locals' vset,
      map.only_differ locals vset locals' ->
      map.undef_on locals vset ->
      Lift1Prop.impl1
        (lists_reserved (t:=t) lengths locs s locals)
        (lists_reserved lengths locs s locals').
  Proof.
    induction t; cbn [lists_reserved];
      break_match; intros; try reflexivity; [ | ].
    { rewrite IHt1, IHt2; try reflexivity; eauto. }
    { repeat intro; sepsimpl; eexists; sepsimpl; eauto.
      eapply equiv_listZ_only_differ_undef_mem; eauto. }
  Qed.

  Lemma equivalent_extract_listnames {t} :
    forall (x : base.interp t)
           (names : base_ltype t)
           (locals : locals)
           (sizes : base_access_sizes t)
           (R : mem -> Prop),
    Lift1Prop.iff1
      (sep (equivalent_base x (base_rtype_of_ltype names) sizes locals) R)
      (sep (equivalent_listexcl
              x (map_listexcl (fun t => base_rtype_of_ltype (listZ:=rep.listZ_mem)(t:=t))
                              (snd (extract_listnames names))) sizes locals)
           (sep (equivalent_listonly
                   x (map_listonly
                        (base_rtype_of_ltype)
                        (fst (extract_listnames names))) sizes locals) R)).
  Proof.
    induction t;
      cbn [fst snd equivalent_base extract_listnames
               base_rtype_of_ltype rep.rtype_of_ltype
               equivalent_listexcl map_listexcl
               equivalent_listonly map_listonly];
      break_match; intros;
        try match goal with
              |- context [emp False] =>
              split; intros; sepsimpl
            end; [ solve [cancel] | | ].
    { rewrite sep_assoc. (* needed for rewrites for some reason *)
      rewrite IHt1. rewrite IHt2.
      rewrite !sep_assoc.
      cancel.
      (* TODO : this should go by associativity/commutativity; is there a better
      way than manually selecting indices? *)
      cancel_seps_at_indices 0 0; [ reflexivity | ].
      cancel_seps_at_indices 0 1; [ reflexivity | ].
      cancel_seps_at_indices 0 0; [ reflexivity | ].
      reflexivity. }
    { cancel. reflexivity. }
  Qed.

  Lemma load_list_item_correct
        (size : access_size)
        (name : base_ltype (listZ:=rep.listZ_mem) base_listZ)
        i l :
    forall mem locals R,
      (i < length l)%nat ->
      base_access_sizes_good (t:=base_listZ) size ->
      sep (rep.equiv (t:=base_listZ)
                     l (base_rtype_of_ltype name) size locals) R mem ->
      WeakestPrecondition.dexpr
        mem locals
        (load_list_item (width:=width) size (expr.var name) i)
        (word.of_Z (hd 0%Z (skipn i l))).
  Proof.
    cbv [load_list_item];
      cbn [rep.equiv rep.listZ_mem rep.Z base_rtype_of_ltype
                     rep.rtype_of_ltype rep.listZ_mem ]; intros.
    cbn [WeakestPrecondition.dexpr
           WeakestPrecondition.expr WeakestPrecondition.expr_body] in *.
    sepsimpl; subst.
    match goal with
    | H : context[array] |- _ =>
      eapply Proper_sep_iff1 in H;
        [ | symmetry; apply array_index_nat_inbounds
                        with (n:=i) (default:=0%Z);
            rewrite !map_length in *; lia
          | reflexivity]
    end.
    match goal with
    | H : context[array] |- _ =>
      rewrite !word.ring_morph_mul, !word.of_Z_unsigned in H;
        rewrite <-!word.ring_morph_mul in H
    end.
    straightline.
    eapply Proper_get; [ repeat intro |  eassumption ].
    match goal with H : word.unsigned _ = word.unsigned _ |- _ =>
                    apply word.unsigned_inj in H
    end.
    subst. rewrite Nat2Z.inj_mul.
    eexists; split.
    { cbv [Memory.load].
      erewrite load_Z_of_sep; [ reflexivity | ].
      ecancel_assumption. }
    { unfold truncate_Z.
      rewrite Z.land_ones by auto with zarith.
      rewrite Z.mod_small; [ reflexivity | ].
      rewrite <-hd_skipn_nth_default.
      match goal with H : base_access_sizes_good _ |- _ =>
                      apply access_sizes_good_in_range in H end.
      apply Forall_nth_default; auto with zarith. }
  Qed.

  Lemma load_list_correct rem l :
    forall (i nextn : nat)
           (name : base_ltype (listZ:=rep.listZ_mem) base_listZ)
           tr
           (sizes : base_access_sizes
                      (listZ:=rep.listZ_mem) base_listZ)
           (locals : locals)
           (mem : mem)
           (functions : list _)
           (R : _ -> Prop),
      (forall (n : nat) (H : nextn <= n), name <> varname_gen n) ->
      base_access_sizes_good sizes ->
      length l = i + rem ->
      sep (rep.equiv (t:=base_listZ)
                     l (base_rtype_of_ltype name) sizes locals) R mem ->
      (* load_list returns # vars used, variable names, cmd *)
      let out := load_list (width:=width) (varname_gen:=varname_gen) sizes (expr.var name) i rem nextn in
      let nvars := fst (fst out) in
      let names' : base_ltype (listZ:=rep.listZ_local) base_listZ
          := snd (fst out) in
      WeakestPrecondition.cmd
        (WeakestPrecondition.call functions)
        (snd out)
        tr mem locals
        (fun tr' mem' locals' =>
           tr = tr' /\
           mem = mem' /\
           Interface.map.only_differ
             locals (used_varnames (varname_gen:=varname_gen) nextn nvars) locals' /\
           (forall n,
               (nextn + nvars <= n)%nat ->
               ~ varname_set_base names' (varname_gen n)) /\
           locally_equivalent_base
             (t:=base_listZ) (skipn i l)
             (base_rtype_of_ltype names') locals').
  Proof.
    induction rem; cbn [fst snd load_list]; intros.
    { straightline.
      cbv [locally_equivalent_base].
      cbn [rep.Z rep.listZ_local fold_right map
                 equivalent_base rep.equiv
                 base_rtype_of_ltype rep.rtype_of_ltype
                 varname_set rep.varname_set].
        repeat split.
      { eapply only_differ_zero. }
      { intros. cbv [empty_set]. tauto. }
      { rewrite skipn_all by lia. econstructor. } }
    { cbn [WeakestPrecondition.cmd WeakestPrecondition.cmd_body].
      eexists; split; cbv [dlet.dlet].
      { eapply load_list_item_correct; try eassumption.
        cbn [Datatypes.length]; lia. }
      eapply Proper_cmd; [ solve [apply Proper_call] | | ].
      2:{
        eapply IHrem; eauto with lia.
        eapply Proper_sep_iff1; [ | reflexivity | eassumption ].
        eapply equiv_listZ_only_differ_mem_iff1;
          eauto using @only_differ_put with typeclass_instances.
        cbn [varname_set rep.varname_set rep.listZ_mem rep.Z].
        apply disjoint_singleton_singleton; eauto using string_dec. }
      repeat intro.
      cbv beta in *; cleanup; subst.
      repeat match goal with |- _ /\ _ => split end;
        eauto using only_differ_succ.
      { cbn [varname_set_base
               rep.varname_set rep.listZ_local rep.Z fold_right] in *.
        intros.
        apply not_union_iff; split; eauto with lia.
        cbv [singleton_set].
        rewrite varname_gen_unique; lia. }
      { cbv [locally_equivalent] in *.
        cbn [map base_rtype_of_ltype
                 Compilers.base_interp
                 rep.rtype_of_ltype rep.listZ_local
                 equivalent rep.equiv ] in *.
        rewrite skipn_nth_default with (d:=0%Z) by lia.
        eapply Forall2_cons; eauto.
        eapply (equiv_Z_only_differ_iff1 (listZ:=rep.listZ_mem)); eauto.
        { eapply only_differ_sym; eassumption. }
        { eapply disjoint_used_varnames_singleton.
          lia. }
        { assert (2 ^ (Z.of_nat (Memory.bytes_per (width:=width) sizes) * 8)
                  <= 2 ^ width)%Z
            by (cbv [base_access_sizes_good] in *;
                apply Z.pow_le_mono_r; lia).
          cbn [rep.equiv rep.listZ_mem rep.Z] in *.
          sepsimpl_hyps.
          match goal with H : word.unsigned _ = word.unsigned _ |- _ =>
                          apply word.unsigned_inj in H
          end.
          subst. eexists.
          split;[reflexivity|].
          split.
          { rewrite <-word.unsigned_of_Z_0, map_nth_default_always.
            reflexivity. }
          { eexists; split; [ | reflexivity ].
            rewrite map.get_put_same, hd_skipn_nth_default.
            rewrite <-word.unsigned_of_Z_0.
            rewrite skipn_map, hd_map.
            rewrite !word.of_Z_unsigned.
            reflexivity. } } } }
  Qed.

  Lemma load_all_lists_correct {t} :
    forall (argnames : base_ltype t)
           (argsizes : base_access_sizes t)
           (args : base.interp t)
           (functions : list _)
           tr
           (locals : locals)
           (mem : mem)
           (nextn : nat)
           (R : _ -> Prop),
        (* lengths of any lists in the arguments *)
        let arglengths := list_lengths_from_value args in
        (* look up variables in argnames *)
        let argvalues := base_rtype_of_ltype argnames in
        (* argnames don't contain variables we could later overwrite *)
        (forall n,
            (nextn <= n)%nat ->
            ~ varname_set_base argnames (varname_gen n)) ->
        (* argument sizes are <= integer width *)
        base_access_sizes_good argsizes ->
        (* argument values are equivalent *)
        sep (equivalent_base args argvalues argsizes locals) R mem ->
        (* load_all_lists returns triple : # fresh variables used,
           new argnames with local lists, and cmd *)
        let out := load_all_lists nextn argnames arglengths argsizes in
        let nvars := fst (fst out) in
        (* extract loaded argument values *)
        let argnames' := snd (fst out) in
        let argvalues' := base_rtype_of_ltype argnames' in
        (* translated function produces equivalent results *)
        WeakestPrecondition.cmd
          (WeakestPrecondition.call functions)
          (snd out)
          tr mem locals
          (fun tr' mem' locals' =>
             tr = tr' /\
             mem = mem' /\
             Interface.map.only_differ
               locals (used_varnames (varname_gen:=varname_gen) nextn nvars) locals' /\
             (forall n,
                 (nextn + nvars <= n)%nat ->
                 ~ varname_set_base argnames' (varname_gen n)) /\
             locally_equivalent_base args argvalues' locals').
  Proof.
    (* TODO: lots of repeated steps in this proof; automate *)
    induction t;
      cbn [fst snd map load_all_lists varname_set
               locally_equivalent_base equivalent_base rep.equiv
               flatten_base_ltype equivalent_flat_base
               base_access_sizes_good
               base_rtype_of_ltype rep.varname_set rep.Z
          ]; break_match; intros; sepsimpl; [ | | ].
    { (* base_Z *)
      repeat straightline. cbv [emp].
      repeat match goal with
               | |- Lift1Prop.ex1 _ _ => eexists
               | |- _ /\ _ => split end;
        eauto using only_differ_zero with lia. }
    { (* product *)
      straightline.
      eapply Proper_cmd; [ solve [apply Proper_call] | | ].
      2:{ eapply IHt1; eauto.
          { intros.
            match goal with
            | H : _ |- _ =>
              setoid_rewrite not_union_iff in H;
                apply H; eauto
            end. }
          { use_sep_assumption; cancel.
            cancel_seps_at_indices 0%nat 0%nat; trivial.
            ecancel_done. } }
      repeat intro. cleanup; subst.
      eapply Proper_cmd; [ solve [apply Proper_call] | | ].
      2:{ eapply IHt2; eauto.
          { intros.
            match goal with
            | H : _ |- _ =>
              setoid_rewrite not_union_iff in H;
                apply H; lia
            end. }
          { cbn [base_rtype_of_ltype fst snd] in *.
            eapply Proper_sep_iff1; [ | reflexivity | ].
            { eapply equivalent_only_differ_iff1;
                eauto using equiv_listZ_only_differ_mem, @only_differ_sym with typeclass_instances.
              eapply disjoint_used_varnames_lt.
              match goal with
              | H : _ |- _ =>
                setoid_rewrite not_union_iff in H;
                  apply H; eauto
              end. }
            use_sep_assumption; cancel.
            cancel_seps_at_indices 1%nat 0%nat; trivial.
            ecancel_done. } }
      cbn [list_lengths_from_value fst snd] in *.
      repeat intro. cleanup; subst.
      repeat match goal with |- _ /\ _ => split end;
        eauto using only_differ_step.
      { intros; apply not_union_iff; split;
          match goal with H : _ |- _ => apply H; lia end. }
      { cbv [locally_equivalent locally_equivalent_args] in *.
        cbn [equivalent_args fst rtype_of_ltype].
        apply sep_empty_iff; split; eauto.
        eapply equivalent_only_differ_iff1;
          eauto using equiv_listZ_only_differ_local, @only_differ_sym with typeclass_instances.
        intros.
        eapply disjoint_used_varnames_lt.
        cleanup. subst.
        match goal with H : _ |- _ => apply H; lia end. } }
  { (* base_listZ *)
    clear IHt.
     cbn [flatten_base_rtype base_rtype_of_ltype] in *.
    eapply Proper_cmd;
      [ solve [apply Proper_call]
      | | eapply load_list_correct; eauto; reflexivity ].
    repeat intro. cleanup; subst.
    repeat match goal with |- _ /\ _ => split end;
      eauto using only_differ_step. }
  Qed.

  Lemma load_arguments_correct {t} :
    forall (argnames : type.for_each_lhs_of_arrow ltype t)
           (argsizes : type.for_each_lhs_of_arrow access_sizes t)
           (args : type.for_each_lhs_of_arrow API.interp_type t)
           (functions : list _)
           tr
           (locals : locals)
           (mem : mem)
           (nextn : nat),
        (* lengths of any lists in the arguments *)
        let arglengths := list_lengths_from_args args in
        (* look up variables in argnames *)
        let argvalues :=
            type.map_for_each_lhs_of_arrow rtype_of_ltype argnames in
        (* argnames don't contain variables we could later overwrite *)
        (forall n,
            (nextn <= n)%nat ->
            ~ varname_set_args argnames (varname_gen n)) ->
        (* argument sizes are <= width *)
        access_sizes_good_args argsizes ->
        (* argument values are equivalent *)
        equivalent_args args argvalues argsizes locals mem ->
        (* load_arguments returns triple : # fresh variables used,
           new argnames with local lists, and cmd *)
        let out := load_arguments nextn argnames arglengths argsizes in
        let nvars := fst (fst out) in
        (* extract loaded argument values *)
        let argnames' := snd (fst out) in
        let argvalues' :=
            type.map_for_each_lhs_of_arrow rtype_of_ltype argnames' in
        (* translated function produces equivalent results *)
        WeakestPrecondition.cmd
          (WeakestPrecondition.call functions)
          (snd out)
          tr mem locals
          (fun tr' mem' locals' =>
             tr = tr' /\
             mem = mem' /\
             Interface.map.only_differ
               locals (used_varnames (varname_gen:=varname_gen) nextn nvars) locals' /\
             (forall n,
                 (nextn + nvars <= n)%nat ->
                 ~ varname_set_args argnames' (varname_gen n)) /\
             locally_equivalent_args args argvalues' locals').
  Proof.
    cbv zeta.
    induction t;
      destruct argnames;
      cbn [fst snd load_arguments access_sizes_good_args
               list_lengths_from_args varname_set_args
               type.for_each_lhs_of_arrow equivalent_args
               type.map_for_each_lhs_of_arrow flatten_args
               ]; break_match; cbn [fst snd]; intros.
    { (* base type *)
      repeat straightline.
      repeat match goal with
             | |- _ /\ _ => split end;
        eauto using only_differ_zero; reflexivity. }
    { (* arrow (base _) _ *)
      cleanup. straightline.
      eapply Proper_cmd.
      3:{
        eapply load_all_lists_correct; eauto; [ ].
        intros.
        match goal with
        | H : _ |- _ =>
          setoid_rewrite not_union_iff in H;
            apply H; eauto
        end. }
      { apply Proper_call. }
      { repeat intro; cleanup; subst.
        eapply Proper_cmd; [ solve [apply Proper_call] | | ].
        2:{
          eapply IHt2; eauto.
        { intros.
          match goal with
            | H : _ |- _ =>
          setoid_rewrite not_union_iff in H;
            apply H; lia
          end. }
        { eapply equivalent_args_only_differ;
            eauto using only_differ_sym with equiv; [ ].
          intros.
          eapply disjoint_used_varnames_lt.
          cleanup. subst.
          match goal with
            | H : _ |- _ =>
          setoid_rewrite not_union_iff in H;
            apply H; eauto
          end. } }
        { repeat intro. cleanup. subst.
          repeat match goal with |- _ /\ _ => split end;
            eauto using only_differ_step.
          { intros; apply not_union_iff; split;
              match goal with H : _ |- _ => apply H; lia end. }
          { cbv [locally_equivalent locally_equivalent_args] in *.
            cbn [equivalent_args fst rtype_of_ltype].
            split; [ | solve [eauto] ].
            exists (emp True). sepsimpl; eauto.
            eapply equivalent_only_differ;
              eauto using only_differ_sym with equiv; [ ].
            eapply disjoint_used_varnames_lt.
            intros; cleanup. subst.
            eauto with lia. } } } }
    { (* arrow (arrow _ _) _ *)
      sepsimpl. }
  Qed.

  Lemma store_list_correct :
    forall (size : access_size)
           (start : string)
           (functions : list _)
           (value_names2 value_names1 : list string)
           (rets1 rets2 rets : base.interp base_listZ)
           (i : nat)
           tr
           (locals : locals)
           (m : mem)
           (R : _ -> Prop),
      let retlengths :=
          list_lengths_from_value (t:=base_listZ) rets2 in
      let loc := expr.var start in
      let nbytes := Memory.bytes_per (width:=width) size in
      let offset := expr.literal (Z.of_nat (nbytes * i)) in
      let loc' := expr.op bopname.add loc offset in
      let values1 := map expr.var value_names1 in
      let values2 := map expr.var value_names2 in
      rets = rets1 ++ rets2 ->
      length rets1 = length value_names1 ->
      length rets2 = length value_names2 ->
      length value_names1 = i ->
      (* bounds are OK *)
      Forall (fun x =>
                0 <= x < 2 ^ (Z.of_nat nbytes * 8))%Z rets2 ->
      (* yet-to-be-stored values *)
      locally_equivalent_base
        (listZ:=rep.listZ_local) rets2 values2 locals ->
      base_access_sizes_good (t:=base_listZ) size ->
      (* already-stored values *)
      sep (map:=mem)
          (sep (map:=mem)
               (rep.equiv (rep:=rep.listZ_mem)
                          rets1 (expr.var start) size locals)
               (lists_reserved retlengths loc' size locals)) R m ->
      WeakestPrecondition.cmd
        (WeakestPrecondition.call functions)
        (store_list (width:=width) size (expr.var start) values2 i) tr m locals
        (fun tr' mem' locals' =>
           tr = tr' /\
           locals = locals' /\
           sep (map:=mem)
               (rep.equiv (rep:=rep.listZ_mem)
                          rets (expr.var start) size locals') R mem').
  Proof.
    cbv zeta.
    induction value_names2 as [|n0 ?]; destruct rets2 as [|r0 rets2];
      cbn [store_list Datatypes.length base_access_sizes_good
                      locally_equivalent_base equivalent_base
                      rep.equiv rep.listZ_local rep.Z rep.listZ_mem];
      intros; subst; try lia; sepsimpl.
    { repeat split; try reflexivity.
      repeat match goal with
             | _ => progress sepsimpl
             | H : _ |- _ =>
               rewrite List.firstn_all, List.skipn_all_exact in H
             | _ => rewrite app_nil_r
             | |- Lift1Prop.ex1 _ _ => eexists
             | |- _ /\ _ => split
             | _ => eassumption
             end.
      match goal with
        H : sep _ _ _ |- _ =>
        eapply Proper_sep_iff1 in H;
          [ | rewrite ?(lists_reserved_0 (listZ:=rep.listZ_local));
              reflexivity .. ]
      end.
      sepsimpl.
      ecancel_assumption. }
    { repeat match goal with
             | H : _ |- _ => rewrite word.of_Z_unsigned in H end.
      subst; eexists; split.
      { cbn [WeakestPrecondition.dexpr
               WeakestPrecondition.expr
               WeakestPrecondition.expr_body] in *.
        eapply Proper_get; [ | eassumption ].
        repeat intro; subst.
        reflexivity. }
      cbn [map] in *.
      match goal with
      | H : Forall2 _ (_ :: _) (_ :: _) |- _ => inversion H; subst; clear H
      end.
      sepsimpl.
      eexists; split.
      { cbn [WeakestPrecondition.dexpr
               WeakestPrecondition.expr
               WeakestPrecondition.expr_body] in *.
        eassumption. }
      cbn [lists_reserved
             list_lengths_from_value
             equivalent
             rep.equiv rep.Z rep.listZ_mem] in *.
      sepsimpl.
      match goal with
        H : Datatypes.length ?x = Datatypes.length (_ :: _) |- _ =>
        destruct x; cbn [Datatypes.length] in H; [ lia | ]
      end.
      cbn [map array Semantics.interp_binop] in *.

      (* we now have a Z in context that should be equivalent to the offsetted
         location; destruct WeakestPrecondition.dexpr to expose that equivalence *)
      lazymatch goal with
        H : WeakestPrecondition.dexpr _ _ (expr.op _ _ _) ?v |- _ =>
          cbn [WeakestPrecondition.dexpr
                 WeakestPrecondition.expr
                 WeakestPrecondition.expr_body
                 Semantics.interp_binop] in H;
          cbv [dlet.dlet WeakestPrecondition.literal
                         WeakestPrecondition.get] in H;
          rewrite ?word.of_Z_unsigned in H;
          cleanup; subst
      end.
      match goal with
      | H1 : (WeakestPrecondition.dexpr _ ?l (expr.var ?x) ?v1),
             H2 : (map.get ?l ?x = Some ?v2) |- _ =>
        replace v2 with v1 in *
          by (cbn [WeakestPrecondition.dexpr
                     WeakestPrecondition.expr
                     WeakestPrecondition.expr_body] in H1;
              cbv [WeakestPrecondition.get] in H1;
              cleanup; congruence)
      end.
      repeat match goal with
             | H: word.unsigned _ = word.unsigned _ |- _ =>
               apply word.unsigned_inj in H; subst
             end.
      repeat match goal with
             | H : map word.unsigned ?x = _ :: _ |- _ =>
               destruct x; cbn [map] in H;
                 [ congruence | inversion H; clear H ]
             end.
      cbn [map array] in *.
      eapply store_Z_of_sep; [ ecancel_assumption | ].
      intros. sepsimpl.
      repeat match goal with
             | H : Forall _ (_ :: _) |- _ => inversion H; subst; clear H
             end.

      eapply Proper_cmd; [ solve [apply Proper_call] | repeat intro | ].
      2:{
        let s :=
            lazymatch goal with
              H : map.get locals0 start = Some ?x |- _ => x end in
        let H := lazymatch goal with
                 | H : sep _ _ ?m |- context [?m] => H end in
        let r1 :=
            lazymatch type of H with
                context [array _ _ s ?xs] => xs end in
        let r2 :=
            lazymatch type of H with
                context [array _ _ (word.add _ _) ?xs] => xs end in
        let r :=
            lazymatch type of H with
              context [truncated_scalar _ _ ?x] => x end in
        apply IHvalue_names2 with
            (rets1:= r1 ++ [r])
            (rets2:=rets2) (R:=R)
            (value_names1:=value_names1 ++ [n0]);
        rewrite ?app_length; cbn [length]; eauto; try lia; [ ].
        { intros.
          (* look at goal and plug in evars very carefully *)
          sepsimpl.
          match goal with H: ?P (expr.var start) ?x |- _ =>
                          exists x end.
          sepsimpl; [ solve [eauto using Forall_snoc] .. | ].
          match goal with
            |- context [map word.unsigned _ =
                        map word.unsigned ?xs ++ [word.unsigned ?x] ] =>
            exists (xs ++ [x])
          end.
          sepsimpl; [ rewrite map_app; reflexivity
                    | solve [eauto using Forall_snoc] | ].
          eexists; sepsimpl; [ reflexivity | solve [eauto] | ].
          match goal with
            H : sep _ _ ?m |- context [?m] =>
            match type of H with
              context [array _ _ (word.add ?a ?b) ?x] =>
              exists x;
                sepsimpl; [solve [auto] .. | ];
                  exists (word.add a b)
            end
          end.
          sepsimpl; [ ].
          eexists; sepsimpl; [ reflexivity | solve [eauto] | ].
          eexists; sepsimpl; [ reflexivity | | ].
          { eexists; split; [ eassumption | ].
            cbn [WeakestPrecondition.dexpr
                   WeakestPrecondition.expr
                   WeakestPrecondition.expr_body
                   Semantics.interp_binop].
            cbv [WeakestPrecondition.literal dlet.dlet].
            match goal with
            | |- context[word.add ?x (word.of_Z ?y)] =>
              progress match x with
                       | word.of_Z _ => idtac
                       | word.add _ _ => idtac
                       | _ => rewrite <-(word.of_Z_unsigned x)
                       end
            end.
            rewrite <-!word.ring_morph_add.
            f_equal. clear; lia. }
          { match goal with
              H : context [array _ _ (word.add (word.add _ _) _) _] |- _ =>
              refine (Lift1Prop.subrelation_iff1_impl1 _ _ _ _ _ H); clear H
            end.
            rewrite map_app, array_append. cbn [map array].
            cbn [Compilers.base_interp] in *. (* simplifies implicit types *)
            match goal with
            | |- Lift1Prop.iff1 ?L ?R =>
              let la := match L with
                          context [truncated_scalar _ ?la] => la end in
              let ra := match R with
                          context [truncated_scalar _ ?ra] => ra end in
              replace ra with la
                by (apply word.unsigned_inj;
                    rewrite !word.unsigned_add, !word.unsigned_of_Z;
                    cbv [word.wrap]; Modulo.pull_Zmod; f_equal; lia)
            end.
            cancel. } } }
      cbv beta in *; cleanup; subst.
      repeat match goal with |- _ /\ _ => split end;
        eauto.
      rewrite app_cons_app_app.
      eassumption. }
  Qed.

  Lemma store_return_values_correct {t} init_locals :
    forall (retnames_local : base_ltype t)
           (retnames_mem : base_ltype t)
           (retsizes : base_access_sizes t)
           (vset : set string)
           (rets : base.interp t)
           (functions : list _)
           tr
           (locals : locals)
           (mem : mem)
           (R : _ -> Prop),
      let out := store_return_values retnames_local retnames_mem retsizes in
      let retlengths := list_lengths_from_value rets in
      sep (lists_reserved retlengths
                          (base_rtype_of_ltype retnames_mem)
                          retsizes init_locals) R mem ->
      map.undef_on
        init_locals
        (union vset (varname_set_listexcl retnames_mem)) ->
      map.only_differ init_locals vset locals ->
      (* rets are stored in local retnames *)
      locally_equivalent_base
        rets (base_rtype_of_ltype retnames_local) locals ->
      (* retnames are disjoint *)
      disjoint (varname_set_base retnames_local)
               (varname_set_base retnames_mem) ->
      (* retnames don't contain duplicates *)
      NoDup (flatten_base_ltype retnames_mem) ->
      (* rets bounds obey access sizes *)
      within_base_access_sizes rets retsizes ->
      (* access sizes not larger than integer width *)
      base_access_sizes_good retsizes ->
      (* translated function produces equivalent results *)
      WeakestPrecondition.cmd
        (WeakestPrecondition.call functions)
        (snd out)
        tr mem locals
        (fun tr' mem' locals' =>
           tr = tr' /\
           retlengths = fst out /\
           map.only_differ
             locals (varname_set_listexcl retnames_mem) locals' /\
           sep (equivalent_base
                  rets (base_rtype_of_ltype retnames_mem) retsizes locals')
               R mem').
  Proof.
    cbv zeta.
    induction t;
      cbn [fst snd store_return_values lists_reserved
               locally_equivalent_base equivalent_base
               varname_set_base varname_set_listexcl
               base_rtype_of_ltype rep.rtype_of_ltype
               rep.equiv rep.varname_set rep.Z
               base_access_sizes_good within_base_access_sizes
               flatten_base_ltype list_lengths_from_value
          ]; break_match; intros; sepsimpl; [ | | ].
    { (* base_Z *)
      repeat straightline.
      eexists; split; [eassumption|].
      cbv [dlet.dlet]; split; [reflexivity|].
      split; [reflexivity|].
      split;
        [ solve [eauto using @only_differ_sym, @only_differ_put with typeclass_instances] | ].
      sepsimpl. eexists; sepsimpl; try eassumption; [ ].
      cbv [WeakestPrecondition.dexpr
             WeakestPrecondition.expr
             WeakestPrecondition.expr_body
             WeakestPrecondition.get] in *.
      cleanup; subst.
      rewrite map.get_put_same.
      eexists; split; reflexivity. }
    { (* prod *)
      repeat straightline.
      match goal with H : _ |- _ =>
                      pose proof H;
                      apply NoDup_app_iff in H; cleanup end.
      repeat match goal with
             | _ => progress cleanup
             | H : disjoint (union _ _) _ |- _ =>
               apply disjoint_union_l_iff in H
             | H : disjoint _ (union _ _) |- _ =>
               apply disjoint_union_r_iff in H
             | H : map.undef_on _ (union _ _) |- _ =>
               apply undef_on_union_iff in H
             end.
      eapply Proper_cmd;
        [ solve [apply Proper_call] | repeat intro
          | eapply IHt1; try ecancel_assumption;
            try (apply undef_on_union_iff; split);
            solve [eauto] ].
      cbv beta in *. cleanup; subst.
      eapply Proper_cmd;
        [ solve [apply Proper_call] | repeat intro | ].
      2:{ eapply IHt2 with
              (vset:=union vset (varname_set_listexcl (fst retnames_mem)));
          try ecancel_assumption; eauto.
          { apply undef_on_union_iff; split; eauto.
            apply undef_on_union_iff; split; eauto. }
          { rewrite union_comm.
            eapply only_differ_trans; eauto. }
          { cbv [locally_equivalent].
            eapply equivalent_only_differ; eauto with equiv.
            apply disjoint_sym.
            eapply subset_disjoint_r;
              eauto using varname_set_listexcl_subset. } }
      cbv beta in *. cleanup; subst.
      repeat match goal with H : list_lengths_from_value _ = _ |- _ =>
                             rewrite H end.
      repeat match goal with |- _ /\ _ => split end;
        eauto 10 using @only_differ_sym, @only_differ_trans with typeclass_instances.
      use_sep_assumption. cancel.
      (* TODO: why doesn't cancel handle the below? *)
      cancel_seps_at_indices 0 1; [ reflexivity | ].
      eapply equivalent_only_differ_iff1; eauto with equiv.
      eapply disjoint_sym.
      eapply subset_disjoint_r;
        eauto using varname_set_listexcl_subset; [ ].
      rewrite !varname_set_flatten.
      eapply NoDup_disjoint; eauto using string_dec. }
    { (* base_listZ *)
      repeat straightline.
      repeat match goal with p := _ |- _ => subst p end.
      repeat match goal with
             | H : map.undef_on _ (union _ _) |- _ =>
               apply undef_on_union_iff in H
             end.
      cbn [rep.Z rep.listZ_mem rep.equiv rep.rtype_of_ltype] in *.
      sepsimpl.
      eapply Proper_cmd;
        [ solve [apply Proper_call] | repeat intro | ].
      2:{
        eapply store_list_correct with
            (rets:=rets) (rets1:=[]) (rets2:=rets)
            (value_names1:=nil); auto using List.length_nil; [ | ].
        { cbn [rep.equiv rep.rtype_of_ltype rep.listZ_local] in *.
          eapply Forall.eq_length_Forall2, Forall.Forall2_map_r_iff.
          eauto. }
        { apply sep_assoc.
          eapply Proper_sep_iff1;
            [ apply equiv_nil_iff1 | reflexivity | ].
          sepsimpl. eexists.
          apply sep_ex1_l.
          eexists; sepsimpl;
            [ | eapply expr_only_differ_undef; solve [eauto] | ];
            [ reflexivity | ].
          cbn [lists_reserved equivalent rep.equiv rep.listZ_mem rep.Z].
          sepsimpl. eexists.
          sepsimpl; eauto.
          eexists; sepsimpl; try ecancel_assumption; eauto.
          cbn [WeakestPrecondition.dexpr
                 WeakestPrecondition.expr
                 WeakestPrecondition.expr_body] in *.
          eexists; sepsimpl; try eassumption; [ ].
          eexists; sepsimpl; try eassumption; [ ].
          eapply WP_get_only_differ_undef; eauto.
          eapply Proper_get; [ repeat intro | eassumption ].
          cbn [Semantics.interp_binop].
          cbv [WeakestPrecondition.literal dlet.dlet].
          subst.
          apply word.unsigned_inj.
          rewrite word.unsigned_add, word.unsigned_of_Z.
          rewrite Nat2Z.inj_mul. change (Z.of_nat 0) with 0%Z.
          autorewrite with zsimplify_fast.
          cbv [word.wrap]. rewrite word.wrap_unsigned.
          reflexivity. } }
      cbv beta in *. cleanup; subst.
      cbn [rep.rtype_of_ltype rep.listZ_local rep.Z] in *.
      match goal with
      | H : rep.equiv ?x ?y _ _ _ |- _ =>
        assert  (length x = length y)
        by (eapply Forall.eq_length_Forall2; apply H)
      end.
      rewrite !map_length in *.
      intuition trivial.
      eapply only_differ_sym, only_differ_empty. }
  Qed.
End LoadStoreList.


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

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

Module Export S := PackageSynthesis P.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj34eqsynthconj1 : forall  (lv0 : natural), (@eq natural (Succ lv0) (Succ (plus Zero lv0))).
Admitted.
QuickChick conj34eqsynthconj1.


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

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

Module Export S := PackageSynthesis P.


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

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

Module Export S := PackageSynthesis P.


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file implements finite set as unordered lists without duplicates
removed. This implementation forms a monad. *)
From stdpp Require Export collections list.
Set Default Proof Using "Type".

Record listset A := Listset { listset_car: list A }.
Arguments listset_car {_} _ : assert.
Arguments Listset {_} _ : assert.

Section listset.
Context {A : Type}.

Global Instance listset_elem_of: ElemOf A (listset A) := λ x l, x ∈ listset_car l.
Global Instance listset_empty: Empty (listset A) := Listset [].
Global Instance listset_singleton: Singleton A (listset A) := λ x, Listset [x].
Global Instance listset_union: Union (listset A) := λ l k,
  let (l') := l in let (k') := k in Listset (l' ++ k').
Global Opaque listset_singleton listset_empty.

Global Instance listset_simple_collection : SimpleCollection A (listset A).
Proof.
  split.
  - by apply not_elem_of_nil.
  - by apply elem_of_list_singleton.
  - intros [?] [?]. apply elem_of_app.
Qed.
Lemma listset_empty_alt X : X ≡ ∅ ↔ listset_car X = [].
Proof.
  destruct X as [l]; split; [|by intros; simplify_eq/=].
  rewrite elem_of_equiv_empty; intros Hl.
  destruct l as [|x l]; [done|]. feed inversion (Hl x). left.
Qed.
Global Instance listset_empty_dec (X : listset A) : Decision (X ≡ ∅).
Proof.
 refine (cast_if (decide (listset_car X = [])));
  abstract (by rewrite listset_empty_alt).
Defined.

Context `{!EqDecision A}.

Global Instance listset_intersection: Intersection (listset A) := λ l k,
  let (l') := l in let (k') := k in Listset (list_intersection l' k').
Global Instance listset_difference: Difference (listset A) := λ l k,
  let (l') := l in let (k') := k in Listset (list_difference l' k').

Instance listset_collection: Collection A (listset A).
Proof.
  split.
  - apply _.
  - intros [?] [?]. apply elem_of_list_intersection.
  - intros [?] [?]. apply elem_of_list_difference.
Qed.
Global Instance listset_elements: Elements A (listset A) :=
  remove_dups ∘ listset_car.
Global Instance listset_fin_collection : FinCollection A (listset A).
Proof.
  split.
  - apply _.
  - intros. apply elem_of_remove_dups.
  - intros. apply NoDup_remove_dups.
Qed.
End listset.

Instance listset_ret: MRet listset := λ A x, {[ x ]}.
Instance listset_fmap: FMap listset := λ A B f l,
  let (l') := l in Listset (f <$> l').
Instance listset_bind: MBind listset := λ A B f l,
  let (l') := l in Listset (mbind (listset_car ∘ f) l').
Instance listset_join: MJoin listset := λ A, mbind id.

Instance listset_collection_monad : CollectionMonad listset.
Proof.
  split.
  - intros. apply _.
  - intros ??? [?] ?. apply elem_of_list_bind.
  - intros. apply elem_of_list_ret.
  - intros ??? [?]. apply elem_of_list_fmap.
  - intros ? [?] ?. unfold mjoin, listset_join, elem_of, listset_elem_of.
    simpl. by rewrite elem_of_list_bind.
Qed.


From Coq Require Import
     List
     Program
     Decidable
     Classical_Prop.

Import ListNotations.

From Hammer Require Import
     Tactics.

Section defn.
  Context {V : Type}.

  Definition t: Type := list V * option V * list V.

  Definition to_list (z : t) : list V :=
    match z with
    | (l, None, r) => rev l ++ r
    | (l, Some e, r) => rev l ++ (e :: r)
    end.

  Definition mov_l (z : t) : t :=
    match z with
    | ([], Some e, r)       => ([], None, e :: r)
    | ([], None, r)         => ([], None, r)
    | (l :: rest, Some e, r) => (rest, Some l, e :: r)
    | (l :: rest, None, r)   => (rest, Some l, r)
    end.

  Definition mov_r (z : t) : t :=
    match z with
    | (l, Some e, [])       => (e :: l, None, [])
    | (l, None, [])         => (l, None, [])
    | (l, Some e, r :: rest) => (e :: l, Some r, rest)
    | (l, None, r :: rest)   => (l, Some r, rest)
    end.

  Lemma mov_l_r l m r :
    let z := (l, Some m, r) in
    mov_r (mov_l z) = z.
  Proof.
    intros z. subst z.
    now destruct l as [|e l].
  Qed.

  Lemma mov_r_l l m r :
    let z := (l, Some m, r) in
    mov_l (mov_r z) = z.
  Proof.
    intros z. subst z.
    now destruct r as [|e r].
  Qed.

  Lemma mov_l_to_list (z : t) : to_list (mov_l z) = to_list z.
  Proof.
    destruct z as [[[|e_l l] [e|]] [|e_r r]];
      simpl;
      try rewrite <- app_assoc;
      reflexivity.
  Qed.

  Lemma mov_r_to_list (z : t) : to_list (mov_r z) = to_list z.
  Proof.
    destruct z as [[[|e_l l] [e|]] [|e_r r]];
      simpl;
      try rewrite <- app_assoc;
      reflexivity.
  Qed.

  Definition get (z : t) : option V :=
    match z with
    | (_, v, _) => v
    end.

  Definition get_l (z : t) : list V :=
    match z with
    | (l, _, _) => l
    end.

  Definition get_r (z : t) : list V :=
    match z with
    | (_, _, r) => r
    end.

  Definition del (z : t) : t :=
    match z with
    | (l, _, r) => (l, None, r)
    end.

  Inductive left_eq : t -> t -> Prop :=
  | left_eq0 : forall l m r,
      left_eq (l, Some m, r) (l, Some m, r)
  | left_eq1 : forall l m r e l' m' r',
      left_eq (l, Some m, r) (l', Some m', e :: r') ->
      left_eq (l, Some m, r) (m' :: l', Some e, r')
  | left_eq2 : forall l m r l' m' r',
      left_eq (l, Some m, r) (l', Some m', r') ->
      left_eq (l, Some m, r) (m' :: l', None, r').

  Definition left_of (a b : t) : Prop :=
    left_eq a (mov_l b).

  Section tests.
    Goal forall l1 l2 m r, let z := ([l1; l2], Some m, r) in left_eq (mov_l (mov_l z)) z.
    Proof. intros. simpl. repeat constructor. Qed.

    Goal forall l1 l2 m r, let z := ([l1; l2], Some m, r) in left_of (mov_l z) z.
    Proof. intros. simpl. repeat constructor. Qed.
  End tests.

  Inductive right_eq : t -> t -> Prop :=
  | right_eq0 : forall l m r,
      right_eq (l, Some m, r) (l, Some m, r)
  | right_eq1 : forall l m r e l' m' r',
      right_eq (l, Some m, r) (e :: l', Some m', r') ->
      right_eq (l, Some m, r) (l', Some e, m' :: r')
  | right_eq2 : forall l m r l' m' r',
      right_eq (l, Some m, r) (l', Some m', r') ->
      right_eq (l, Some m, r) (l', None, m' :: r').

  Lemma left_eq_mov_l e l m r l' m' r' :
    left_eq (e :: l, Some m, r) (l', Some m', r') ->
    left_eq (l, Some e, m :: r) (l', Some m', r').
  Proof.
    intros H.
    generalize dependent l.
    generalize dependent m.
    generalize dependent r.
    generalize dependent e.
    generalize dependent m'.
    generalize dependent r'.
    induction l'; intros; sauto.
  Qed.

  Lemma right_eq_mov_r e l m r l' m' r' :
    right_eq (l, Some m, e :: r) (l', Some m', r') ->
    right_eq (m :: l, Some e, r) (l', Some m', r').
  Proof.
    intros H.
    generalize dependent l.
    generalize dependent m.
    generalize dependent r.
    generalize dependent e.
    generalize dependent m'.
    generalize dependent l'.
    induction r'; intros; sauto.
  Qed.

  Lemma right_eq_left_eq_equiv z1 z2 :
    (* This property only holds when the zipper points at non-empty
    element. This is easy to understand: our inductive definitions of
    [right_eq] and [left_eq] are deliberately crafted in a way that
    forbids appearance of zippers pointing at [None] on the left side
    of the equation. Hence swapping positions of the arguments will
    lead to terms that cannot be created. Hence we weaken this lemma
    by the below premises, and it works: *)
    (exists v1, get z1 = Some v1) ->
    (exists v2, get z2 = Some v2) ->
    right_eq z1 z2 <-> left_eq z2 z1.
  Proof with subst; simpl in *.
    intros H1 H2.
    split; intros H.
    - induction H.
      + constructor.
      + apply IHright_eq in H1.
        2:{ exists m'. reflexivity. }
        inversion H1; subst.
        * constructor. constructor.
        * apply left_eq_mov_l. now constructor.
      + exfalso. now destruct H2.
    - induction H.
      + constructor.
      + apply IHleft_eq in H2.
        2:{ exists m'. reflexivity. }
        inversion H2; subst.
        * constructor. constructor.
        * apply right_eq_mov_r. now constructor.
      + exfalso. now destruct H1.
  Qed.

  Definition right_of (z1 z2 : t) : Prop :=
    right_eq z1 (mov_r z2).

  Definition Forall (P : V -> Prop) (z : t) : Prop :=
    match z with
    | (l, None, r) => List.Forall P l /\ List.Forall P r
    | (l, Some v, r) => P v /\ List.Forall P l /\ List.Forall P r
    end.

  Definition optional_filter (P : V -> bool) (v : option V) : option V :=
    match v with
    | Some v =>
      match P v with
      | true => Some v
      | false => None
      end
    | None => None
    end.

  Definition filter (P : V -> bool) (z : t) : t :=
    match z with
    | (l, v, r) => (List.filter P l, optional_filter P v, List.filter P r)
    end.

  Definition of_list (l : list V) : t :=
    match l with
    | [] => ([], None, [])
    | e :: rest => ([], Some e, rest)
    end.

  Definition zipper_of (z : t) (l : list V) : Prop :=
    right_eq z (of_list l).

  Lemma left_eq_to_list z1 z2 :
    left_eq z1 z2 ->
    to_list z1 = to_list z2.
  Proof with auto.
    intros H.
    induction H.
    - reflexivity.
    - cbn in *. now rewrite <-app_assoc.
    - cbn in *. now rewrite <-app_assoc.
  Qed.

  Lemma left_of_dec z1 z2 :
    to_list z1 = to_list z2 ->
     z1 = z2 \/ left_of z1 z2 \/ left_of z2 z1.
  Proof.
    intros H. unfold to_list in H.
    destruct z1 as [[l1 m1] r1]. destruct z2 as [[l2 m2] r2].
  Admitted.

  Lemma left_eq_self z : zipper_of z (to_list z).
  Admitted.
End defn.

Declare Scope zipper_scope.
Delimit Scope zipper_scope with zipper.
Infix "<z" := (left_of)(at level 90) : zipper_scope.
Infix "<=z" := (left_eq)(at level 90) : zipper_scope.
Infix ">z" := (right_of)(at level 90) : zipper_scope.
Infix ">=z" := (right_eq)(at level 90) : zipper_scope.

Global Arguments t : clear implicits.
Hint Constructors left_eq : slot.

Section tests.
  Open Scope zipper_scope.

  Let foo := ([2; 1], Some 3, [4]).

  Goal ([], Some 1, [2; 3; 4]) <z foo.
    repeat constructor.
  Qed.

  Goal ([1], Some 2, [3; 4]) <=z foo.
    repeat constructor.
  Qed.

  Goal forall z, z <=z foo ->
            get z = Some 3 \/
            get z = Some 2 \/
            get z = Some 1.
  Proof with subst; cbn in *.
    intros z Hz. subst foo.
    inversion Hz...
    - auto.
    - inversion H1...
      + auto.
      + inversion H0...
        auto.
  Qed.

  Goal forall z, z <=z ([3; 2; 1], None, [4]) ->
            get z = Some 3 \/
            get z = Some 2 \/
            get z = Some 1.
  Proof with subst; cbn in *.
    intros z Hz. subst foo.
    inversion Hz...
    inversion H1...
    - auto.
    - inversion H0...
      + auto.
      + inversion H2...
        auto.
  Qed.

  Goal forall z, z >z foo -> get z = Some 4.
  Proof with subst; cbn in *.
    intros z Hz. subst foo.
    inversion Hz...
    - reflexivity.
  Qed.

  Goal not(([3; 2; 1], Some 4, []) <z foo).
    intros H. subst foo.
    cbv in H.
    inversion H; subst; cbv in *.
    inversion H1.
  Qed.

  Goal zipper_of ([], Some 1, [2; 3]) [1; 2; 3].
    repeat constructor.
  Qed.

  Goal zipper_of ([1], Some 2, [3]) [1; 2; 3].
    repeat constructor.
  Qed.

  Goal zipper_of ([2; 1], Some 3, []) [1; 2; 3].
    repeat constructor.
  Qed.
End tests.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Defs.Env.
Require Import Defs.Set.
Require Import Defs.Substs.

(*** Simplification *)
Theorem embed_Sch_mono : forall dty,
    emb_Sch (DS_Mono dty) = S_Mono (emb_Ty dty).
Proof. reflexivity. Qed.
#[export] Hint Rewrite embed_Sch_mono : core.

(*** Inj *)
Theorem emb_Ty_inj : forall (dty1 dty2 : DTy),
    emb_Ty dty1 = emb_Ty dty2
  -> dty1 = dty2.
Proof.
  induction dty1; destruct dty2; crush.
  erewrite IHdty1_1. erewrite IHdty1_2. crush. crush. crush.
Qed.

Theorem emb_Sch_inj : forall (dsch1 dsch2 : DSch),
    emb_Sch dsch1 = emb_Sch dsch2
  -> dsch1 = dsch2.
Proof.
  induction dsch1; destruct dsch2; crush. apply emb_Ty_inj in H. crush.
  forwards: IHdsch1. eassumption. crush.
Qed.

(*** Embed & open *)
Lemma embed_Ty_open_comm_rec : forall (dty1 dty2 : DTy) (n : nat),
   emb_Ty (open_DTy_wrt_DTy_rec n dty2 dty1) = open_Ty_wrt_Ty_rec n (emb_Ty dty2) (emb_Ty dty1).
Proof. intros. induction dty1; crush. ltdec; ifdec; crush. Qed.

Theorem embed_Ty_open_comm : forall (dty1 dty2 : DTy),
   emb_Ty (open_DTy_wrt_DTy dty1 dty2) = open_Ty_wrt_Ty (emb_Ty dty1) (emb_Ty dty2).
Proof. unfold open_DTy_wrt_DTy. unfold open_Ty_wrt_Ty. eauto using embed_Ty_open_comm_rec. Qed.

Theorem embed_Sch_open_comm : forall (dsch : DSch) (dty : DTy),
   emb_Sch (open_DSch_wrt_DTy dsch dty) = open_Sch_wrt_Ty (emb_Sch dsch) (emb_Ty dty).
Proof.
  intros. unfold open_DSch_wrt_DTy. unfold open_Sch_wrt_Ty. generalize 0.
  induction dsch; intros.
  - simpl. rewrite embed_Ty_open_comm_rec. reflexivity.
  - crush.
Qed.

(*** emb_auto *)
Lemma emb_auto_forall : forall (sch : Sch) (dsch : DSch),
    S_Forall sch = emb_Sch dsch
    -> exists dsch', dsch = DS_Forall dsch'
             /\ sch = emb_Sch dsch'.
Proof. destruct dsch; crush. eauto. Qed.

Lemma emb_auto_forall' : forall (sch1 sch2 : Sch),
    S_Forall sch1 = S_Forall sch2
  -> sch1 = sch2.
Proof. inversion 1. auto. Qed.

Lemma emb_auto_mono : forall (ty : Ty) (dsch : DSch),
    S_Mono ty = emb_Sch dsch
  -> exists dty, dsch = DS_Mono dty
          /\ ty = emb_Ty dty.
Proof. destruct dsch; crush. eauto. Qed.

Lemma emb_auto_sk_n : forall (n : nat) (dty : DTy),
    T_SkVar_b n = emb_Ty dty
  -> dty = DT_SkVar_b n.
Proof. destruct dty; crush. Qed.

Lemma emb_auto_sk_f : forall (skA : skvar) (dty : DTy),
    T_SkVar_f skA = emb_Ty dty
  -> dty = DT_SkVar_f skA.
Proof. destruct dty; crush. Qed.

Lemma emb_auto_ex : forall (exA : exvar) (dty : DTy),
    T_ExVar exA = emb_Ty dty
  -> False.
Proof. destruct dty; crush. Qed.

Lemma emb_auto_unit : forall (dty : DTy),
    T_Unit = emb_Ty dty
  -> dty = DT_Unit.
Proof. destruct dty; crush. Qed.

Lemma emb_auto_fun : forall (ty1 ty2 : Ty) (dty : DTy),
    T_Fun ty1 ty2 = emb_Ty dty
  -> exists dty1 dty2, dty = DT_Fun dty1 dty2
               /\ ty1 = emb_Ty dty1
               /\ ty2 = emb_Ty dty2.
Proof. destruct dty; crush. eauto. Qed.

Theorem embed_Sch_Forall : forall dsch,
    emb_Sch (DS_Forall dsch) = S_Forall (emb_Sch dsch).
Proof. reflexivity. Qed.
#[export] Hint Rewrite embed_Sch_Forall : dsub_simpl.

Theorem emb_auto_DSub_app_Forall : forall dsub sch1 sch2,
    DSub_app sch1 dsub = S_Forall sch2
  -> exists sch1', sch1 = S_Forall sch1'
           /\ DSub_app sch1' dsub = sch2.
Proof.
  introv EMB. destruct sch1.
  - crush.
  - exists sch1. crush.
Qed.

Theorem embed_mono_inversion : forall (ty : Ty) (dty : DTy),
    S_Mono ty = S_Mono (emb_Ty dty)
  -> ty = emb_Ty dty.
Proof. inversion 1. reflexivity. Qed.

Ltac emb_auto' :=
  let sch   := fresh "sch" in
  let dsch' := fresh "dsch" in
  let dty'  := fresh "dty"  in
  let dty1  := fresh "dty1" in
  let dty2  := fresh "dty2" in
  let EQ    := fresh "EQ"   in
  let EMB'  := fresh "EMB"  in
  let EMB1  := fresh "EMB1" in
  let EMB2  := fresh "EMB2" in
  repeat match goal with
    | [ H: DS_Mono _ = DS_Mono _  |- _ ] =>
        symmetry in H; inverts H
    | [ H: S_Mono ?ty = S_Mono (emb_Ty ?dty)  |- _ ] =>
        apply embed_mono_inversion in H
    | [ H: S_Forall ?sch1 = S_Forall ?sch2 |- _ ] =>
        apply (emb_auto_forall' sch1 sch2) in H
    | [ H: S_Forall ?sch = emb_Sch ?dsch |- _ ] =>
        apply (emb_auto_forall sch dsch) in H; destruct H as [dsch' [EQ EMB']]
    | [ H: S_Mono ?ty = emb_Sch ?dsch |- _ ] =>
        apply (emb_auto_mono ty dsch) in H; destruct H as [dty' [EQ EMB']]
    | [ H: T_SkVar_b ?n = emb_Ty ?dty |- _ ] =>
        apply (emb_auto_sk_n n dty) in H
    | [ H: T_SkVar_f ?skA = emb_Ty ?dty |- _ ] =>
        apply (emb_auto_sk_f skA dty) in H
    | [ H: T_ExVar ?exA = emb_Ty ?dty |- _ ] =>
        apply (emb_auto_ex exA dty) in H
    | [ H: T_Unit = emb_Ty ?dty |- _ ] =>
        apply (emb_auto_unit dty) in H
    | [ H: T_Fun ?ty1 ?ty2 = emb_Ty ?dty |- _ ] =>
        apply (emb_auto_fun ty1 ty2 dty) in H; destruct H as [dty1 [dty2 [EQ [EMB1 EMB2]]]]
    | [ H: DSub_app ?sch1 ?dsub = S_Forall ?sch2 |- _ ] =>
        apply (emb_auto_DSub_app_Forall dsub sch1 sch2) in H; destruct H as [sch [EQ EMB']]
    | [ H: DSub_app _ _ = _ |- _ ] =>
        autorewrite with dsub_simpl in H
    | [ H: DSub_app_t _ _ = _ |- _ ] =>
        autorewrite with dsub_simpl in H
    end.

Ltac emb_auto := emb_auto'; subst.
Ltac emb_auto'' := repeat emb_auto.

(*** free vars embed *)
(* free_exvars_Ty*)
Theorem embedded_Ty_does_not_contain_exvars : forall (dty : DTy) (exA : exvar),
    exA \notin free_exvars_Ty (emb_Ty dty).
Proof. induction dty; crush. indestr; eauto. Qed.
#[export] Hint Resolve embedded_Ty_does_not_contain_exvars : core.

Theorem embedded_Sch_does_not_contain_exvars : forall (dsch : DSch) (exA : exvar),
    exA \notin free_exvars_Sch (emb_Sch dsch).
Proof. induction dsch; crush. forwards NIT: embedded_Ty_does_not_contain_exvars. crush. apply NIT. eauto. Qed.
#[export] Hint Resolve embedded_Sch_does_not_contain_exvars : core.

(* free_skvars_Ty*)
Theorem free_skvars_Ty_embed_Ty : forall (dty : DTy),
    free_skvars_Ty (emb_Ty dty) = free_dskvars_DTy dty.
Proof. introv. induction dty; crush. Qed.

Lemma free_skvars_Sch_embed_Sch : forall (dsch : DSch),
    free_skvars_Sch (emb_Sch dsch) = free_dskvars_DSch dsch.
Proof. introv. DSch_DTy_ind dsch; crush. Qed.

(*** embed/subst *)
Theorem subst_exvar_Ty_embed_idempotent : forall (dty : DTy) (ty__in : Ty) (exA : exvar),
    subst_exvar_Ty ty__in exA (emb_Ty dty) = emb_Ty dty.
Proof. eauto using subst_exvar_Ty_not_in_Ty_idempotent. Qed.
#[export] Hint Rewrite subst_exvar_Ty_embed_idempotent : core.

Theorem subst_exvar_Sch_embed_idempotent : forall (dsch : DSch) (ty__in : Ty) (exA : exvar),
    subst_exvar_Sch ty__in exA (emb_Sch dsch) = emb_Sch dsch.
Proof. eauto using subst_exvar_Sch_not_in_Sch_idempotent. Qed.
#[export] Hint Rewrite subst_exvar_Sch_embed_idempotent : core.

Theorem embed_Sch_subst_dskvar_DSch : forall dty dskA dsch,
    emb_Sch (subst_dskvar_DSch dty dskA dsch) = subst_skvar_Sch (emb_Ty dty) dskA (emb_Sch dsch).
Proof.
  introv. DSch_DTy_ind dsch. 1,3,4,5: crush.
  - rewr. simpl. ifdec; crush.
Qed.