(* Test vectors from <https://tools.ietf.org/html/rfc7748#section-5.2>,
   with hex values converted to decimal using python like this:
   > int.from_bytes(binascii.unhexlify('deadbeef'), 'little') *)
Require Import Coq.NArith.BinNatDef.
Require Import Coq.ZArith.BinIntDef.
Require Import Coq.PArith.BinPosDef.
Require Import Spec.ModularArithmetic Spec.MxDH Crypto.Util.Decidable.
Definition F := F (2^255 - 19).
Definition a : F := F.of_Z _ 486662.
Definition a24 : F := ((a - F.of_Z _ 2) / F.of_Z _ 4)%F.
Definition cswap {T} (swap:bool) (a b:T) := if swap then (b, a) else (a, b).
Definition monty s : F -> F := @MxDH.montladder F F.zero F.one F.add F.sub F.mul F.inv a24 cswap 255 (BinNat.N.testbit_nat s).

Example one_basepoint : F.to_Z (monty 1 (F.of_Z _ 9)) = 9%Z.
Proof. vm_decide_no_check. Qed.

Example testvector_one : F.to_Z (monty
   31029842492115040904895560451863089656472772604678260265531221036453811406496%N
   (F.of_Z _ 34426434033919594451155107781188821651316167215306631574996226621102155684838%Z)) = 37325765543539916631701301279660700968428932651319597985674090122993663859395%Z.
Proof. vm_decide_no_check. Qed.

Example testvector_two : F.to_Z (monty
   35156891815674817266734212754503633747128614016119564763269015315466259359304%N
   (F.of_Z _ 8883857351183929894090759386610649319417338800022198945255395922347792736741%Z)) = 39566196721700740701373067725336211924689549479508623342842086701180565506965%Z.
Proof. vm_decide_no_check. Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Environments for metatheory                                             *
* Adapted for xp var path environments, Upsilon.
**************************************************************************)

(* Questions:
  I could have generalized env to be (V : Type) (A : ValueType) but I didn't
 want to mess up automation on envs until I really understand it.

 Also I may need a different signature to get variables, not just variable paths
  out at different points.

  2 theorems failing but overloaded LTac which is not ideal.

  The theorems that fail are about freshness, which is to be expected, as I
 have no idea what freshness issues we really need to solve on this context.

*)

Set Implicit Arguments.

Require Import TLC.LibTactics TLC.LibOption TLC.LibList TLC.LibProd TLC.LibLogic TLC.LibReflect.
Require Export TLC.LibVar.
Require Export LibVarPath.

Module LVPE.

(* ********************************************************************** *)
(** * Definition of environments and their basic operations *)

(** To avoid definitions being unfolded by [simpl] in an uncontrollable
    manner, we use a module signature to enforce abstraction *)

(* ---------------------------------------------------------------------- *)
(** ** Abstract definitions *)

Generalizable Variable A.

Definition varpathenv (A:Type) := list (varpath * A).
Definition varpaths := fset varpath.

Module Type VarPathEnvOpsSig.

Section Definitions.
Variable A B : Type.

Parameter empty : varpathenv A.
Parameter empty_def : empty = nil.

Parameter single : varpath -> A -> varpathenv A.
Parameter single_def :
  single = fun x v => (x,v)::nil.

Parameter concat : varpathenv A -> varpathenv A -> varpathenv A.
Parameter concat_def :
  concat = fun E F => F ++ E.

Parameter singles : list varpath -> list A -> varpathenv A.
Parameter singles_def :
  singles = fun xs vs =>
    fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).

Parameter keys : varpathenv A -> list varpath.
Parameter keys_def :
  keys = map fst.

Parameter values : varpathenv A -> list A.
Parameter values_def :
  values = map snd.

Parameter fold_vars : (A -> varpaths) -> varpathenv A -> varpaths.
Parameter fold_vars_defs :
  fold_vars = fun fv E =>
    fold_right (fun v acc => fv v \u acc) \{} (values E).

Parameter dom : varpathenv A -> varpaths.
Parameter dom_def :
  dom = fold_right (fun p E => \{fst p} \u E) \{}.

Parameter dom' : varpathenv A -> vars.
Parameter dom'_def :
  dom' = fold_right (fun p E => \{fst (fst p)} \u E) \{}.

Parameter map : (A -> B) -> varpathenv A -> varpathenv B.
Parameter map_def :
  map = fun f E =>
    LibList.map (fun p => (fst p, f (snd p))) E.

Parameter map_keys : (varpath -> varpath) -> varpathenv A -> varpathenv A.
Parameter map_keys_def :
  map_keys = fun f E =>
    LibList.map (fun p => (f (fst p), snd p)) E.

Parameter get : varpath -> varpathenv A -> option A.
Fixpoint get_impl (k : varpath) (E : varpathenv A) {struct E} : option A :=
  match E with
  | nil => None
  | (x,v) :: E' => If k = x then Some v else get_impl k E'
  end.
Parameter get_def :
  get = get_impl.

End Definitions.

Implicit Arguments empty [A].

End VarPathEnvOpsSig.

(* ---------------------------------------------------------------------- *)
(** ** Concrete definitions *)

Module Export V : VarPathEnvOpsSig.

Section Concrete.
Variable A B : Type.

Definition empty : varpathenv A := nil.
Lemma empty_def : empty = nil.
Proof using. reflexivity. Qed.

Definition single x v : varpathenv A := (x,v)::nil.
Lemma single_def :
  single = fun x v => (x,v)::nil.
Proof using. reflexivity. Qed.

Definition concat (E F : varpathenv A) := F ++ E.
Lemma concat_def :
  concat = fun E F => F ++ E.
Proof using. reflexivity. Qed.

Definition singles (xs : list varpath) (vs : list A) : varpathenv A :=
  fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).
Lemma singles_def :
  singles = fun xs vs =>
   fold_right (fun p acc => concat acc (single (fst p) (snd p))) empty (combine xs vs).
Proof using. reflexivity. Qed.

Definition keys : varpathenv A -> list varpath :=
  map fst.
Lemma keys_def :
  keys = map fst.
Proof using. reflexivity. Qed.

Definition values : varpathenv A -> list A :=
  map snd.
Lemma values_def :
  values = map snd.
Proof using. reflexivity. Qed.

Definition fold_vars (fv : A -> varpaths) (E : varpathenv A) :=
  fold_right (fun v acc => fv v \u acc) \{} (values E).
Lemma fold_vars_defs :
  fold_vars = fun fv E => fold_right (fun v acc => fv v \u acc) \{} (values E).
Proof using. reflexivity. Qed.

Definition map (f:A->B) (E:varpathenv A) :=
  LibList.map (fun p => (fst p, f (snd p))) E.
Lemma map_def :
  map = fun f E => LibList.map (fun p => (fst p, f (snd p))) E.
Proof using. reflexivity. Qed.

Definition map_keys (f:varpath->varpath) (E:varpathenv A) :=
  LibList.map (fun p => (f (fst p), snd p)) E.
Lemma map_keys_def :
  map_keys = fun f E => LibList.map (fun p => (f (fst p), snd p)) E.
Proof using. reflexivity. Qed.

Definition dom : varpathenv A -> varpaths :=
  fold_right (fun p E => \{fst p} \u E) \{}.
Lemma dom_def :
  dom = fold_right (fun p E => \{fst p} \u E) \{}.
Proof using. reflexivity. Qed.

Definition dom' : varpathenv A -> vars :=
  fold_right (fun p E => \{fst (fst p)} \u E) \{}.
Lemma dom'_def :
  dom' = fold_right (fun p E => \{fst (fst p)} \u E) \{}.
Proof using. reflexivity. Qed.

Fixpoint get_impl (k : varpath) (E : varpathenv A) {struct E} : option A :=
  match E with
  | nil => None
  | (x,v) :: E' => If k = x then Some v else get_impl k E'
  end.
Definition get := get_impl.
Lemma get_def :
  get = get_impl.
Proof using. reflexivity. Qed.

End Concrete.

Implicit Arguments empty [A].

End V.

(* ---------------------------------------------------------------------- *)
(** ** Notations *)
Module LibVarPathEnvNotations.

(** [x ~p a] is the notation for a singleton environment mapping x to a. *)

Notation "x '~p' a" := (single x a)
  (at level 7, left associativity) : env_scope.

(** [xs ~p* vs] is the notation for [single_iter xs vs]. *)

Notation "xs '~p*' vs" := (singles xs vs)
  (at level 27, left associativity) : env_scope.

(** [E p& F] is the notation for concatenation of E and F. *)

Notation "E '&p' F" := (concat E F)
  (at level 28, left associativity) : env_scope.

(** [x p# E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#p' E" := (x \notin (dom E)) (at level 67) : env_scope.

Bind Scope env_scope with varpathenv.
Delimit Scope env_scope with varpathenv.
Open Scope env_scope.
End LibVarPathEnvNotations.
Import LibVarPathEnvNotations.

(* ---------------------------------------------------------------------- *)
(** ** Additional definitions *)

Section MoreDefinitions.
Variable A : Type.
Implicit Types E F : varpathenv A.

(** Well-formed environments contains no duplicate bindings. *)

Inductive okp : varpathenv A -> Prop :=
  | okp_empty :
      okp empty
  | okp_push : forall E x v,
      okp E -> x #p E -> okp (E &p x ~p v).

(** An environment contains a binding from x to a iff the most recent
  binding on x is mapped to a *)

Definition binds x v E :=
  get x E = Some v.

(** Read the value associated to a bound variable *)

Definition get_or_arbitrary `{Inhab A} x (E:varpathenv A) :=
  unsome (get x E).

(** Inclusion of an environment in another one. *)

Definition extends E F :=
  forall x v, binds x v E -> binds x v F.

(** Gathering free variables contained in the keys of an environment *)

Definition fv_in_keys (fv: varpath ->vars) (E:varpathenv A) :=
  fold_right (fun v L => (fv v) \u L) \{} (keys E).

(** Gathering free variables contained in the values of an environment *)

Definition fv_in_values (fv:A->vars) (E:varpathenv A) :=
  fold_right (fun v L => (fv v) \u L) \{} (values E).

End MoreDefinitions.

(* ---------------------------------------------------------------------- *)
(** ** Basic Properties *)

Hint Rewrite empty_def single_def concat_def singles_def keys_def values_def
  dom_def map_def map_keys_def get_def : env_defs.

Ltac rew_env_defs := autorewrite with env_defs in *.

Section Properties.

Variable A B : Type.
Implicit Types k x : varpath.
Implicit Types v : A.
Implicit Types E F G : varpathenv A.
Implicit Types f : A -> B.
Implicit Types r : varpath -> varpath.

Lemma cons_to_push : forall x v E,
  (x, v) :: E = E &p x ~p v.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma env_ind : forall (P : varpathenv A -> Prop),
  (P empty) ->
  (forall E x v, P E -> P (E &p x ~p v)) ->
  (forall E, P E).
Proof using.
  rew_env_defs. induction E as [|(x,v)].
  auto. forwards*: H0 IHE.
Qed.

Lemma map_empty : forall f,
  map f empty = empty.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_single : forall f x v,
  map f (x ~p v) = (x ~p (f v)).
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_concat : forall f E F,
  map f (E &p F) = (map f E) &p (map f F).
Proof using.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list~.
  rew_list. fequals.
Qed.
Lemma map_push : forall f x v E,
  map f (E &p x ~p v) = (map f E) &p (x ~p (f v)).
Proof using. intros. rewrite map_concat, map_single. auto. Qed.

Lemma map_keys_empty : forall r,
  map_keys r (@empty A) = empty.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_keys_single : forall r x v,
  map_keys r (x ~p v) = ((r x) ~p v).
Proof using. intros. rew_env_defs. auto. Qed.
Lemma map_keys_concat : forall r E F,
  map_keys r (E &p F) = map_keys r E &p map_keys r F.
Proof using.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list~.
  rew_list. fequals.
Qed.
Lemma map_keys_push : forall r x v E,
  map_keys r (E &p x ~p v) = map_keys r E &p ((r x) ~p v).
Proof using. intros. rewrite map_keys_concat, map_keys_single. auto. Qed.

Lemma get_empty : forall k,
  get k (@empty A) = None.
Proof using. intros. rew_env_defs. auto. Qed.
Lemma get_single : forall k x v,
  get k (x ~p v) = If k = x
                    then Some v
                    else None.
Proof using. intros. rew_env_defs. unfold get_impl. auto. Qed.
Lemma get_concat : forall k E F,
  get k (E &p F) = match get k F with
                  | None => get k E
                  | Some v => Some v
                  end.
Proof using.
  intros. rew_env_defs. induction F as [|(x,v)].
  auto.
  simpl. case_if~.
Qed.

Lemma dom_empty :
  dom (@empty A) = \{}.
Proof using. rew_env_defs. auto. Qed.
Lemma dom_single : forall x v,
  dom (x ~p v) = \{x}.
Proof using.
  intros. rew_env_defs.
  rew_list. rewrite~ union_empty_r.
Qed.
Lemma dom_concat : forall E F,
  dom (E &p F) = dom E \u dom F.
Proof using.
  intros. rew_env_defs.
  gen E. induction F as [|(x,v)]; intros.
  rew_list. rewrite~ union_empty_r.
  rew_app. rewrite fold_right_cons. rewrite IHF.
   rewrite~ union_comm_assoc.
Qed.
Lemma dom_push : forall x v E,
  dom (E &p x ~p v) = \{x} \u dom E.
Proof using.
  intros. rewrite dom_concat. rewrite dom_single.
  rewrite~ union_comm.
Qed.

End Properties.

Section SinglesProperties.
Variable A B : Type.
Implicit Types x : varpath.
Implicit Types v : A.
Implicit Types xs : list varpath.
Implicit Types vs : list A.
Implicit Types E F : varpathenv A.

Lemma singles_nil :
  nil ~p* nil = (@empty A).
Proof using. intros. rew_env_defs. auto. Qed.

Lemma singles_cons : forall x v xs vs,
  (x::xs) ~p* (v::vs) = (xs ~p* vs) &p (x ~p v).
Proof using. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma singles_one : forall x v,
  (x::nil) ~p* (v::nil) = (x ~p v).
Proof using. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma singles_two : forall x1 x2 v1 v2,
  (x1::x2::nil) ~p* (v1::v2::nil) = (x2 ~p v2 &p x1 ~p v1).
Proof using. intros. rew_env_defs. simpl. rew_env_defs. fequals. Qed.

Lemma keys_singles : forall xs vs,
  length xs = length vs ->
  keys (xs ~p* vs) = xs.
Proof using.
  intros. rew_env_defs. gen vs. induction xs; introv E.
  rew_list~.
  destruct vs. false. simpl. rew_env_defs. rew_list. fequals.
   rew_list in E. applys IHxs. inverts E. auto.
Qed.

Lemma values_singles : forall xs vs,
  length xs = length vs ->
  values (xs ~p* vs) = vs.
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  auto.
  rew_list in E. simpl. rew_env_defs. rew_list. fequals.
   applys IHxs. inverts E. auto.
Qed.

Lemma dom_singles : forall xs vs,
  length xs = length vs ->
  dom (xs ~p* vs) = from_list xs.
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  simpl. rewrite~ from_list_nil.
  simpl. rew_env_defs. rew_list. rewrite from_list_cons. fequals.
   applys IHxs. inverts~ E.
Qed.

Lemma map_singles : forall (f : A -> B) xs vs,
  length xs = length vs ->
  map f (xs ~p* vs) = xs ~p* (LibList.map f vs).
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma map_keys_singles : forall f xs vs,
  length xs = length vs ->
  map_keys f (xs ~p* vs) = (LibList.map f xs) ~p* vs.
Proof using.
  intros. rew_env_defs. gen vs.
  induction xs; destruct vs; introv E; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma concat_singles : forall xs1 xs2 vs1 vs2,
  length xs1 = length vs1 ->
  length xs2 = length vs2 ->
  (xs2 ~p* vs2) &p (xs1 ~p* vs1) = (xs1 ++ xs2) ~p* (vs1 ++ vs2).
Proof using.
  introv E1 E2. rew_env_defs. gen vs1.
  induction xs1; destruct vs1; intros; tryfalse.
  rew_list~.
  rew_list. simpl. rew_list. fequals~.
Qed.

Lemma singles_keys_values : forall E,
  E = (keys E) ~p* (values E).
Proof using.
  intros. rew_env_defs. induction E as [|[x v] E'].
  auto.
  rew_list. simpl. rew_env_defs. rew_list. fequals.
Qed.

End SinglesProperties.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

Section StructProperties.

Variable A : Type.
Implicit Types x : varpath.
Implicit Types v : A.
Implicit Types E F : varpathenv A.

Lemma env_case : forall E,
  E = empty \/ exists x v E', E = E' &p x ~p v.
Proof using. intros. induction E using env_ind; autos*. Qed.

Lemma concat_empty_r : forall E,
  E &p empty = E.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma concat_empty_l : forall E,
  empty &p E = E.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma concat_assoc : forall E F G,
  E &p (F &p G) = (E &p F) &p G.
Proof using. intros. rew_env_defs. rew_app~. Qed.

Lemma empty_single_inv : forall x v,
  empty = x ~p v -> False.
Proof using. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_concat_inv : forall E F,
  empty = E &p F -> empty = E /\ empty = F.
Proof using. introv H. rew_env_defs. forwards*: nil_eq_app_inv H. Qed.

Lemma empty_push_inv : forall E x v,
  empty = E &p x ~p v -> False.
Proof using. introv H. rew_env_defs. inverts H. Qed.

Lemma empty_middle_inv : forall E F x v,
  empty = E &p x ~p v &p F -> False.
Proof using. introv H. rew_env_defs. forwards* [_ ?]: nil_eq_app_inv H. false. Qed.

Lemma eq_single_inv : forall x1 x2 v1 v2,
  x1 ~p v1 = x2 ~p v2 ->
  x1 = x2 /\ v1 = v2.
Proof using. introv H. rew_env_defs. inverts~ H. Qed.

Lemma eq_push_inv : forall x1 x2 v1 v2 E1 E2,
  E1 &p x1 ~p v1 = E2 &p x2 ~p v2 ->
  x1 = x2 /\ v1 = v2 /\ E1 = E2.
Proof using. introv H. rew_env_defs. inverts~ H. Qed.

End StructProperties.

(* ---------------------------------------------------------------------- *)
(** ** More properties *)
Section MoreProperties.

Variable A : Type.
Implicit Types x : varpath.
Implicit Types v : A.
Implicit Types E F : varpathenv A.

Lemma dom_map : forall (B:Type) (f:A->B) E,
  dom (map f E) = dom E.
Proof using.
  induction E using env_ind.
  rewrite map_empty. do 2 rewrite dom_empty. auto.
  rewrite map_concat. rewrite map_single.
  rewrite_all dom_concat. rewrite_all dom_single. congruence.
Qed.

Lemma concat_assoc_map_push : forall f E F x v,
  E &p (map f (F &p x ~p v)) = (E &p map f F) &p x ~p (f v).
Proof using.
  intros. rewrite map_concat. rewrite map_single.
  rewrite~ concat_assoc.
Qed.

Lemma get_push : forall k x v E,
  get k (E &p x ~p v) =
    If k = x
      then Some v
      else get k E.
Proof using.
  intros. rewrite get_concat. rewrite get_single. case_if~.
Qed.

Ltac simpl_dom :=
  rewrite_all dom_push in *;
  rewrite_all dom_empty in *.

Lemma get_some : forall x E,
  x \in dom E -> exists v, get x E = Some v.
(* i.e.  [x \in dom E -> exists v, binds x v E] *)
Proof using. (* beautify *)
  unfold binds.
  introv H. rew_env_defs. induction E as [|[y v] E'].
  rew_list in H. rewrite* in_empty in H.
  unfold get_impl. case_if.
    eauto.
    rew_list in H. rewrite in_union in H. destruct H as [H|H].
     rewrite in_singleton in H. simpls. false.
     forwards* [v' ?]: IHE'.
Qed.

Lemma get_some_inv : forall x v E,
  get x E = Some v -> x \in dom E.
(* i.e.  [binds x v E -> x \in dom E] *)
Proof using. (* beautify *)
  unfold binds.
  introv H. rew_env_defs. unfolds get_impl. induction E as [|[y v'] E'].
  false.
  rew_list. rewrite in_union. simpl. case_if.
    inverts H. subst. left. rewrite~ in_singleton.
    forwards*: IHE'.
Qed.

Lemma get_none : forall x E,
  x #p E -> get x E = None.
Proof using.
  induction E using env_ind; introv In.
  rewrite~ get_empty.
  rewrite~ get_push. case_if.
    simpl_dom. subst.
(* BUG: admitted until LibGenEnv works.
    notin_false. simpl_dom. auto.
Qed.
 *)
Admitted.

Lemma get_none_inv : forall x E,
  get x E = None -> x #p E.
Proof using.
  induction E using env_ind; introv Eq.
  simpl_dom. auto.
  rewrite get_push in Eq. case_if~.
   simpl_dom. auto.
(* BUG: admitted until LibGenEnv works. *)
Admitted.

End MoreProperties.

Lemma binds_get_or_arbitrary : forall `{Inhab A} x v (E:varpathenv A),
  binds x v E -> get_or_arbitrary x E = v.
Proof using. introv M. unfold get_or_arbitrary. rewrite~ M. Qed.

Definition indom_dec A (E:varpathenv A) x :=
  match get x E with None => false | Some _ => true end.

Global Instance indom_decidable : forall A (E:varpathenv A) x,
  Decidable (x \in dom E).
Proof using.
  intros. applys decidable_make (indom_dec E x).
  unfold indom_dec. cases (get x E) as C.
    lets: (get_some_inv C). rewrite~ isTrue_true.
    lets: (get_none_inv C). rewrite~ isTrue_false.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Hints and rewriting tactics *)

Hint Constructors okp.

Hint Rewrite dom_empty dom_single dom_concat : rew_env_dom.
Hint Rewrite map_empty map_single map_concat : rew_env_map.
Hint Rewrite map_keys_empty map_keys_single
 map_keys_concat : rew_env_map_keys.
Hint Rewrite get_empty get_single get_concat : rew_evn_get.

Hint Rewrite concat_empty_r concat_empty_l concat_assoc : rew_env_concat.

Tactic Notation "rew_env_concat" :=
  autorewrite with rew_env_concat.
Tactic Notation "rew_env_concat" "in" hyp(H) :=
  autorewrite with rew_env_concat in H.
Tactic Notation "rew_env_concat" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_env_concat).
  (* autorewrite with rew_env_concat in *. *)

Ltac simpl_dom :=
  rewrite_all dom_map in *;
  rewrite_all dom_push in *;
  rewrite_all dom_concat in *;
  rewrite_all dom_single in *;
  rewrite_all dom_empty in *.

Hint Extern 1 (_ #p _) => simpl_dom; notin_solve.

(* ---------------------------------------------------------------------- *)
(** ** Properties of well-formedness and freshness *)

Section OkpProperties.

Variable A B : Type.
Implicit Types k x : varpath.
Implicit Types v : A.
Implicit Types E F : varpathenv A.

Lemma okp_push_inv : forall E x v,
  okp (E &p x ~p v) -> okp E /\ x #p E.
Proof using.
  intros. inverts H as H1 H2.
  false (empty_push_inv H1).
  destructs 3 (eq_push_inv H). subst~.
Qed.

Lemma okp_push_inv_okp : forall E x v,
  okp (E &p x ~p v) -> okp E.
Proof using. introv H. destruct* (okp_push_inv H). Qed.

Lemma okp_concat_inv : forall E F,
  okp (E &p F) -> okp E /\ okp F.
Proof using.
  induction F using env_ind; rew_env_concat; introv Okp. auto.
  destruct (okp_push_inv Okp).
  destruct IHF.
  auto.
(* BUG: admitted until LibGenEnv works. *)
(*
Qed.
*)
Admitted.

Lemma okp_concat_inv_l : forall E F,
  okp (E &p F) -> okp E.
Proof using. introv H. lets*: okp_concat_inv H. Qed.

Lemma okp_concat_inv_r : forall E F,
  okp (E &p F) -> okp F.
Proof using. introv H. lets*: okp_concat_inv H. Qed.

Lemma okp_middle_change : forall E F x v1 v2,
  okp (E &p x ~p v1 &p F) -> okp (E &p x ~p v2 &p F).
Proof using.
  induction F using env_ind; introv; rew_env_concat; introv Okp.
  destruct* (okp_push_inv Okp).
  destruct* (okp_push_inv Okp).
Qed.

Lemma okp_middle_inv : forall E F x v,
  okp (E &p x ~p v &p F) -> x #p E /\ x #p F.
Proof using.
  induction F using env_ind; introv; rew_env_concat; intros Okp;
   destruct (okp_push_inv Okp).
  split~.
  forwards~ [? ?]: IHF H.
(* BUG: admitted until LibGenEnv works. *)
Admitted.

Lemma okp_middle_inv_l : forall E F x v,
  okp (E &p x ~p v &p F) -> x #p E.
Proof using. introv H. forwards~ [? _]: okp_middle_inv H. Qed.

Lemma okp_middle_inv_r : forall E F x v,
  okp (E &p x ~p v &p F) -> x #p F.
Proof using. introv H. forwards~ [_ ?]: okp_middle_inv H. Qed.

Lemma okp_remove : forall F E G,
  okp (E &p F &p G) -> okp (E &p G).
Proof using.
  induction G using env_ind; rew_env_concat; introv Okp.
  lets*: okp_concat_inv Okp.
  lets*: okp_push_inv Okp.
(* BUG: admitted until LibGenEnv works. *)
Admitted.

Lemma okp_map : forall E (f : A -> B),
  okp E -> okp (map f E).
Proof using.
  induction E using env_ind; introv;
   autorewrite with rew_env_map; rew_env_concat; intros Okp.
  auto. destruct* (okp_push_inv Okp).
Qed.

Lemma okp_concat_map: forall E F (f : A -> A),
  okp (E &p F) -> okp (E &p map f F).
Proof using.
  induction F using env_ind; introv;
   autorewrite with rew_env_map; rew_env_concat; intros Okp.
  auto. destruct* (okp_push_inv Okp).
(* BUG: admitted until LibGenEnv works. *)
Admitted.

Fixpoint freshp (L : varpaths) (n : nat) (xs : list varpath) {struct xs} : Prop :=
  match xs, n with
  | nil, O => True
  | x::xs', S n' => x \notin L /\ freshp (L \u \{x}) n' xs'
  | _,_ => False
  end.

Hint Extern 1 (freshp _ _ _) => simpl.

Lemma okp_singles : forall n E xs (vs:list A),
  freshp (dom E) n xs ->
  length xs = length vs ->
  okp E ->
  okp (E &p xs ~p* vs).
Proof using.
  introv F EQ O. gen E n vs.
  induction xs; destruct vs; destruct n; intros; tryfalse.
  rewrite singles_nil. rewrite~ concat_empty_r.
  rew_length in EQ. inverts EQ.
(*
   simpl in F. destruct F as [Fr F']. lets [? M]: (fresh_union_r F').
   rewrite singles_cons. rewrite concat_assoc. applys okp_push.
     applys~p IHxs n.
     simpl_dom. rewrite~ dom_singles. lets~: fresh_single_notin M.
Qed.
 *)
Admitted.

(* LATER: not used
Lemma singles_okp : forall xs vs E,
  okp E ->
  fresh (dom E) (length xs) xs ->
  okp (E &p xs ~p* vs).
Proof using. ...
  induction xs; simpl; intros. auto.
  destruct H0. destruct Us; simpls. auto.
  rewrite iter_push_cons. rewrite* <- concat_assoc.
*)

(* LATER: not used;
   missing a precondition unless nil~p*vs returns nil
Lemma okp_concat_singles : forall n xs vs E,
  okp E ->
  fresh (dom E) n xs ->
  okp (E &p xs ~p* vs).
Proof using.
  intros. rew_env_defs. gen vs n E.
  induction xs; introv Okp Fr; destruct n; tryfalse.
  auto.
  destruct vs. simpl.
  rew_list in Fr. destruct Fr as [F Fr'].
  applys_to Fr notin_union_r...
Qed.
*)

(* LATER: not used
  Lemma okp_concat : forall E F,
    okp E -> okp F -> disjoint (dom E) (dom F) ->
    okp (E &p F).
*)

End OkpProperties.

Implicit Arguments okp_push_inv [A E x v].
Implicit Arguments okp_concat_inv [A E F].
Implicit Arguments okp_remove [A F E G].
Implicit Arguments okp_map [A E f].
Implicit Arguments okp_middle_inv_l [A E F x v].
Implicit Arguments okp_middle_inv_r [A E F x v].
Implicit Arguments okp_middle_inv [A E F x v].

(** Automation *)

Hint Resolve okp_middle_inv_l okp_map okp_concat_map okp_singles.

Hint Extern 1 (okp (?E &p ?G)) =>
  match goal with H: okp (E &p ?F &p G) |- _ =>
    apply (okp_remove H) end.

Hint Extern 1 (okp (?E)) =>
  match goal with H: okp (E &p _ ~p _) |- _ =>
    apply (okp_push_inv_okp H) end.

Hint Extern 1 (okp (?E)) =>
  match goal with H: okp (E &p _) |- _ =>
    apply (okp_concat_inv_l H) end.

Hint Extern 1 (okp (?E)) =>
  match goal with H: okp (_ &p E) |- _ =>
    apply (okp_concat_inv_r H) end.

(* not used
Hint Extern 1 (okp (_ &p ?xs ~p* ?vs)) =>
  match goal with H: fresh _ ?n xs |- _ =>
  match type of vs with list ?A =>
    apply (@okp_concat_singles A n)
  end end.
*)

(* ---------------------------------------------------------------------- *)
(** ** Properties of the binds relation *)

Section BindsProperties.
Variable A B : Type.
Implicit Types E F : varpathenv A.
Implicit Types x : varpath.
Implicit Types v : A.

Lemma binds_get : forall x v E,
  binds x v E -> get x E = Some v.
Proof using. auto. Qed.

(** Constructor forms *)

Lemma binds_empty_inv : forall x v,
  binds x v empty -> False.
Proof using.
  unfold binds. introv H. rewrite get_empty in H. false.
Qed.

Lemma binds_single_eq : forall x v,
  binds x v (x ~p v).
Proof using.
  intros. unfold binds. rewrite get_single. case_if~.
Qed.

Lemma binds_single_inv : forall x1 x2 v1 v2,
  binds x1 v1 (x2 ~p v2) ->
  x1 = x2 /\ v1 = v2.
Proof using.
  unfold binds. introv H. rewrite get_single in H.
  case_if; inversions~ H.
Qed.

Lemma binds_push_inv : forall x1 v1 x2 v2 E,
  binds x1 v1 (E &p x2 ~p v2) ->
     (x1 = x2 /\ v1 = v2)
  \/ (x1 <> x2 /\ binds x1 v1 E).
Proof using.
  introv H. unfolds binds. rewrite get_push in H. case_if.
  inverts~ H. auto.
Qed.

Lemma binds_push_eq : forall x v E,
  binds x v (E &p x ~p v).
Proof using. intros. unfolds binds. rewrite get_push. case_if~. Qed.

Lemma binds_push_eq_inv : forall x v1 v2 E,
  binds x v1 (E &p x ~p v2) -> v1 = v2.
Proof using.
  introv H. forwards [|]: binds_push_inv H. autos*. intros [? _]. false.
Qed.

Lemma binds_push_neq_inv : forall x1 x2 v1 v2 E,
  binds x1 v1 (E &p x2 ~p v2) -> x1 <> x2 -> binds x1 v1 E.
Proof using.
  introv H. forwards [|]: binds_push_inv H.
  intros [? ?] ?. false. autos*.
Qed.

Lemma binds_tail : forall x v E,
  binds x v (E &p x ~p v).
Proof using. intros. unfold binds. rewrite get_push. cases_if~. Qed.

Lemma binds_push_neq : forall x1 x2 v1 v2 E,
  binds x1 v1 E -> x1 <> x2 -> binds x1 v1 (E &p x2 ~p v2).
Proof using.
  introv H N. unfolds binds. rewrite get_push. case_if~.
Qed.

Lemma binds_concat_inv : forall x v E1 E2,
  binds x v (E1 &p E2) ->
     (binds x v E2)
  \/ (x #p E2 /\ binds x v E1).
Proof using.
  introv H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   forwards [[? ?]|[? M]]: binds_push_inv H.
     subst. left. apply binds_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ binds_push_neq.
       right~.
(*
Qed.
 *)
Admitted.

Lemma binds_map : forall x v (f : A -> B) E,
  binds x v E -> binds x (f v) (map f E).
Proof using.
  introv H. unfolds binds. rew_env_defs.
  induction E as [|[x' v'] E']; simpls.
  false.
  cases_if~. inverts~ H.
Qed.

(** Basic forms *)

Lemma binds_func : forall x v1 v2 E,
  binds x v1 E -> binds x v2 E -> v1 = v2.
Proof using.
  introv H1 H2. unfolds binds.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H1. false.
  rewrite get_push in H1,H2. case_if~.
   inverts H1. inverts~ H2.
Qed.

Lemma binds_fresh_inv : forall x v E,
  binds x v E -> x #p E -> False.
Proof using.
  introv H F. unfolds binds.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H. false.
  rewrite get_push in H. (*
case_if~. subst.
   simpl_dom; notin_false.
Qed.
                          *)
Admitted.

(** Derived forms *)

Lemma binds_single_eq_inv : forall x v1 v2,
  binds x v1 (x ~p v2) ->
  v1 = v2.
Proof using.
  introv H. unfolds binds. rewrite get_single in H.
  case_if. inverts~ H.
Qed.

Lemma binds_concat_left : forall x v E1 E2,
  binds x v E1 ->
  x #p E2 ->
  binds x v (E1 &p E2).
Proof using.
  introv H F. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc. (*
applys~ binds_push_neq.
   simpl_dom. auto.
Qed.
                         *)
Admitted.

Lemma binds_concat_left_okp : forall x v E1 E2,
  okp (E1 &p E2) ->
  binds x v E1 ->
  binds x v (E1 &p E2).
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc in O|-*. lets [_ ?]: okp_push_inv O.
  applys~ binds_push_neq. intro_subst. (*
applys~ binds_fresh_inv H.
Qed.
                                        *)
Admitted.

Lemma binds_concat_left_inv : forall x v E1 E2,
  binds x v (E1 &p E2) ->
  x #p E2 ->
  binds x v E1.
Proof using.
  introv H F. lets~ [M|[? ?]]: binds_concat_inv H.
    false. applys~ binds_fresh_inv M.
Qed.

Lemma binds_concat_right : forall x v E1 E2,
  binds x v E2 ->
  binds x v (E1 &p E2).
Proof using.
  introv H. induction E2 using env_ind.
  false. applys* binds_empty_inv.
  rewrite concat_assoc. lets [[? ?]|[? ?]]: binds_push_inv H.
    subst. applys binds_tail.
    applys~ binds_push_neq.
Qed.

Lemma binds_concat_right_inv : forall x v E1 E2,
  binds x v (E1 &p E2) ->
  x #p E1 ->
  binds x v E2.
Proof using.
  introv H F. lets~ [?|[? M]]: binds_concat_inv H.
    false. applys~ binds_fresh_inv M.
Qed.

Lemma binds_middle_eq : forall x E1 E2 v,
  x #p E2 ->
  binds x v (E1 &p x ~p v &p E2).
Proof using.
  introv F. applys~ binds_concat_left. applys binds_tail.
Qed.

(** Metatheory proof forms *)

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the binds_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma binds_weaken : forall x a E F G,
  binds x a (E &p G) -> okp (E &p F &p G) ->
  binds x a (E &p F &p G).
Proof using.
  introv H O. lets [?|[? ?]]: binds_concat_inv H.
    applys~ binds_concat_right.
    applys~ binds_concat_left. applys~ binds_concat_left_okp.
Qed.

Lemma binds_remove : forall E2 E1 E3 x v,
  binds x v (E1 &p E2 &p E3) ->
  x #p E2 ->
  binds x v (E1 &p E3).
Proof using.
  introv H F. lets [?|[? M]]: binds_concat_inv H.
    applys~ binds_concat_right.
    forwards~: binds_concat_left_inv M. applys~ binds_concat_left.
Qed.

Lemma binds_subst : forall x2 v2 x1 v1 E1 E2,
  binds x1 v1 (E1 &p x2 ~p v2 &p E2) ->
  x1 <> x2 ->
  binds x1 v1 (E1 &p E2).
Proof using. introv H N. applys~ binds_remove H.
(*

Qed.
 *)
Admitted.

Lemma binds_middle_eq_inv : forall x E1 E2 v1 v2,
  binds x v1 (E1 &p x ~p v2 &p E2) ->
  okp (E1 &p x ~p v2 &p E2) ->
  v1 = v2.
Proof using.
  introv H O. lets [? ?]: okp_middle_inv O.
  forwards~ M: binds_concat_left_inv H.
  applys~ binds_push_eq_inv M.
Qed.

Lemma binds_middle_inv : forall x1 v1 x2 v2 E1 E2,
  binds x1 v1 (E1 &p x2 ~p v2 &p E2) ->
     (binds x1 v1 E2)
  \/ (x1 #p E2 /\ x1 = x2 /\ v1 = v2)
  \/ (x1 #p E2 /\ x1 <> x2 /\ binds x1 v1 E1).
Proof using.
  introv H. lets [?|[? M]]: (binds_concat_inv H).
    left~.
    right. lets [N|[? N]]: (binds_concat_inv M).
      lets [? ?]: (binds_single_inv N). subst~.
      right. simpl_dom. split~.
(*

Qed.
 *)
Admitted.

Lemma binds_not_middle_inv : forall x v E1 E2 E3,
  binds x v (E1 &p E2 &p E3) ->
  x #p E2 ->
     (binds x v E3)
  \/ (x #p E3 /\ binds x v E1).
Proof using.
  introv H F. lets [?|[? M]]: (binds_concat_inv H).
    left~.
    right. forwards~ N: (binds_concat_left_inv M).
Qed.

Lemma fv_in_values_binds : forall y fv x v E,
  binds x v E -> y \notin fv_in_values fv E -> y \notin fv v.
Proof using.
  unfold fv_in_values. introv H.
  induction E using env_ind; introv M.
  false. applys* binds_empty_inv.
  rewrite values_def in M,IHE.
  rewrite concat_def, single_def in M. rew_list in M. simpl in M.
  lets [[? ?]|[? ?]]: (binds_push_inv H);  subst~.
Qed.

(* unused -- requires a precondition on f
Lemma binds_keys : forall x v f E,
  binds x v E -> binds (f x) v (map_keys f E).
Proof using.
Qed.
*)

(* unused
Lemma binds_concat_inv_okp : forall x v E1 E2,
  okp (E1 &p E2) ->
  binds x v (E1 &p E2) ->
     (x #p E2 /\ binds x v E1)
  \/ (x #p E1 /\ binds x v E2).
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in O,H.
   forwards [[? ?]|[? M]]: binds_push_inv H.
     subst. left. apply conj_dup_r.
     split.
       apply binds_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ binds_push_neq.
       right~....
Qed.
*)

End BindsProperties.
(* ---------------------------------------------------------------------- *)
(** ** Tactics *)

Hint Resolve binds_push_eq binds_push_neq
  binds_map binds_concat_left binds_concat_right.

Tactic Notation "binds_mid" :=
  match goal with H: binds ?x ?v1 (_ &p ?x ~p ?v2 &p _) |- _ =>
    asserts: (v1 = v2); [ apply (binds_middle_eq_inv H) | subst; clear H ]
  end.
Tactic Notation "binds_mid" "~" :=
  binds_mid; auto_tilde.
Tactic Notation "binds_mid" "*" :=
  binds_mid; auto_star.

Tactic Notation "binds_push" constr(H) :=
  match type of H with binds ?x1 ?v1 (_ &p ?x2 ~p ?v2) =>
    destruct (binds_push_inv H) as [[? ?]|[? ?]]; [ subst x2 v2 | ]
  end.
Tactic Notation "binds_push" "~" constr(H) :=
  binds_push H; auto_tilde.
Tactic Notation "binds_push" "*" constr(H) :=
  binds_push H; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Properties of environment inclusion *)

Section ExtendsProperties.
Variable A : Type.
Implicit Types x : varpath.
Implicit Types v : A.
Implicit Types E F : varpathenv A.

Lemma extends_refl : forall E,
  extends E E.
Proof using. intros_all~. Qed.

Lemma extends_push : forall E x v,
  x #p E -> extends E (E &p x ~p v).
Proof using.
  introv Fr. intros x' v' B. unfolds binds.
  rewrite get_push. case_if~.
  lets: get_none Fr. false.
Qed.

Lemma extends_concat_l : forall E F,
  extends F (E &p F).
Proof using.
  introv B. unfolds binds.
  rewrite get_concat. rewrite~ B.
Qed.

Lemma extends_concat_r : forall E F,
  disjoint (dom E) (dom F) ->
  extends E (E &p F).
Proof using.
  introv D B. unfolds binds.
  lets: get_some_inv A B.
  forwards M: get_none A x F.
    applys~ disjoint_in_notin D.
  rewrite get_concat. rewrite~ M.
Qed.

(* not used
Lemma extends_push_reoccur : forall E x v,
  binds x v E -> extends E (E &p x ~p v).
*)

End ExtendsProperties.

Hint Resolve extends_refl extends_push.

(* ********************************************************************** *)
(** ** Tactics for case analysis on binding relations *)

(** [binds_get H as EQ] produces from an hypothesis [H] of
  the form [binds x a (E &p x ~p b &p F)] the equality [EQ: a = b]. *)

Ltac binds_get_nosubst_base H EQ :=
  match type of H with
  | binds ?x ?v1 (?E1 &p ?x ~p ?v2 &p ?E2) =>
    forwards EQ: (@binds_middle_eq_inv _ x E1 E2 v1 v2 H); [ auto | ]
  (* | binds ?x1 ?v1 (?E1 &p ?x2 ~p ?v2 &p ?E2) =>
     forwards EQ: (@binds_middle_inv _ x1 v1 x2 v2 E1 E2); [ | auto ] *)
  end.

Tactic Notation "binds_get_nosubst" constr(H) "as" ident(EQ) :=
  binds_get_nosubst_base H EQ.
Tactic Notation "binds_get_nosubst" constr(H) :=
  let EQ := fresh "EQ" in binds_get_nosubst H as EQ.

(** [binds_get H] expects an hypothesis [H] of the form
  [binds x a (E &p x ~p b &p F)] and substitute [a] for [b] in the goal. *)

Ltac binds_get H :=
  let EQ := fresh in binds_get_nosubst H as EQ;
  try match type of EQ with
  | ?f _ = ?f _ => inversions EQ
  | ?x = ?y => subst x end.

(** [binds_single H] derives from an hypothesis [H] of the form
  [binds x a (y ~p b)] the equalities [x = y] and [a = b], then
  it substitutes [x] for [y] in the goal or deduce a contradiction
  if [x <> y] can be found in the context. *)

Ltac binds_single H :=
  match type of H with binds ?x ?a (?y ~p ?b) =>
    let EQ := fresh "EQ" in
    destruct (binds_single_inv H) as [? EQ];
    try discriminate; try subst y;
    try match goal with N: ?x <> ?x |- _ =>
      false; apply N; reflexivity end end.

(** [binds_case H as B1 B2] derives from an hypothesis [H] of the form
  [binds x a (E &p F)] two subcases: [B1: binds x a E] (with a freshness
  condition [x #p F]) and [B2: binds x a F]. *)

Lemma binds_concat_inv' : forall A, forall x (v:A) E1 E2,
  binds x v (E1 &p E2) ->
     (x #p E2 /\ binds x v E1)
  \/ (binds x v E2).
Proof using. intros. forwards K: binds_concat_inv A H. destruct* K. Qed.

Tactic Notation "binds_case" constr(H) "as" ident(B1) ident(B2) :=
   let Fr := fresh "Fr" in
   destruct (binds_concat_inv' H) as [[Fr B1] | B2].

(** [binds_case H] makes a case analysis on an hypothesis [H] of the form
  [binds x a E] where E can be constructed using concatenation and
  singletons. It calls [binds_single] when reaching a singleton. *)

Ltac binds_cases H :=
  let go B := clear H;
    first [ binds_single B | binds_cases B | idtac ] in
  let B1 := fresh "B" in let B2 := fresh "B" in
  binds_case H as B1 B2; (*fix_env;*) [ go B1 | go B2 ].
  (* TODO: add support for binds_empty_inv *)

(* LATER: improve the above tactic using pattern matching
Ltac binds_cases_base H :=
  match H with
  | binds _ _ empty => false (binds_empty_inv H)
  | binds _ _ (_ &p _) =>
     let H1 := fresh "B" in
     destruct (binds_concat_inv H) as [H1|H1];
     clear H; binds_cases_base H1
  | binds _ _ (_ ~p _) =>
  | _ => idtac
  end.
*)
End LVPE.


Require Import Classical Equiv EquivFacts Msg NonEquiv Sty Tac TL TLFacts Var
  Wf WfFacts.

Lemma NSequiv_not_Tl_bisim :
  forall S S' eta c c',
  Wf S ->
  Wf S' ->
  NSequiv S S' ->
  ~ Tl_bisim (tl eta S c) (tl eta S' c').
Proof.
  introv Hwf Hwf' Hnsequiv. induction Hnsequiv; introv Hcontra; try solve
    [ inverts2 Hcontra; false
    | inverts2 Hcontra; eapply IHHnsequiv; eauto with wf
    ].
  - erewrite tl_mu_subst in Hcontra.
    * eapply IHHnsequiv; eauto with wf.
    * auto with wf.
  - erewrite tl_mu_subst in Hcontra.
    * eapply IHHnsequiv; eauto with wf.
    * auto with wf.
  - destruct S; destruct S'; simpl in *; solve
      [inverts2 Hcontra | false | auto with wf].
Unshelve.
  all: auto with wf.
Qed.

Theorem trace_bisim_equivalence_alt :
  forall S S' eta
  (Swf : Wf S)
  (S'wf : Wf S'),
  Tl_bisim (tl eta S (Wf_Contractive Swf)) (tl eta S' (Wf_Contractive S'wf)) ->
  Sequiv S S'.
Proof.
  intros S S' eta Swf Swf'. apply contrapositive.
  rewrite <- NSequiv_iff_not_Sequiv; trivial. apply NSequiv_not_Tl_bisim; auto.
Qed.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export dynamic_semantics.
Require Export semantics_util.
Require Export terms_util2.
Require Export list_util.

(**

   In the dynamic semantics of terms we derived terms without
   knowing that they're actually derivable.  Here we prove that
   they're actually derivable.

   Definitions and lemmas from this file are used in US lemmas proofs.

   Also, this file needs some cleaning up because it contains some old
   definitions that are not used anymore.

 *)

Definition DumKVar : KVariable := variable "".
Definition DumVR : (KVariable * R) := (DumKVar, DumR).
Definition S2R :=  state -> R.

Lemma partial_derive_st_test_2 :
  forall f v s,
    partial_derive f [v,v] s
    = Derive_n
        (fun r => f (upd_state s v r))
        2
        (s v).
Proof.
  introv; simpl.
  apply Derive_ext; introv.
  rewrite upd_state_same.
  apply Derive_ext; introv.
  rewrite upd_state_twice; auto.
Qed.

Lemma partial_derive_st_test_3 :
  forall f v s,
    partial_derive f [v,v,v] s
    = Derive_n
        (fun r => f (upd_state s v r))
        3
        (s v).
Proof.
  introv; simpl.
  apply Derive_ext; introv.
  rewrite upd_state_same.
  apply Derive_ext; introv.
  rewrite upd_state_same.
  rewrite upd_state_twice; auto.
  apply Derive_ext; introv.
  rewrite upd_state_twice; auto.
Qed.

Lemma partial_derive_st_const :
  forall c l st,
    (0 < List.length l)%nat -> partial_derive (fun _ => c) l st = 0%R.
Proof.
  induction l; introv h; simpl in *; try omega.
  destruct (deq_nat (List.length l) 0); subst.
  { destruct l; simpl in *; ginv.
    rewrite Derive_const; auto. }
  { rewrite (Derive_ext _ (fun _ => 0%R));
      try (introv; apply IHl; omega).
    apply Derive_const. }
Qed.

Lemma partial_derive_st_const0 :
  forall (l : list KAssignable) (st : state),
    partial_derive (fun _ : state => 0%R) l st = 0%R.
Proof.
  destruct l; introv.
  { simpl; auto. }
  { apply partial_derive_st_const; simpl; omega. }
Qed.

Lemma partial_derive_st_plus :
  forall l st L R,
    (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k L)
    -> (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k R)
    -> partial_derive (fun s => (L s + R s)%R) l st
       = (partial_derive L l st
          + partial_derive R l st)%R.
Proof.
  induction l; introv dL dR; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_plus; auto.
  { apply (dL (List.length l)); auto. }
  { apply (dR (List.length l)); auto. }
Qed.

Lemma partial_derive_st_plus_sublist :
  forall l st L R,
    (forall v k, sublist (v :: k) l -> ex_partial_derive L v k)
    -> (forall v k, sublist (v :: k) l -> ex_partial_derive R v k)
    -> partial_derive (fun s => (L s + R s)%R) l st
       = (partial_derive L l st
          + partial_derive R l st)%R.
Proof.
  induction l; introv dL dR; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].

  rewrite Derive_plus; auto.

  { apply dL.
    apply sublist_refl. }

  { apply dR.
    apply sublist_refl. }
Qed.

Lemma ex_nth_partial_derive_st_big_sum :
   forall (vs : list KAssignable) n (F : state -> KAssignable -> R),
    (forall v k, (k <= n)%nat -> List.In v vs -> ex_nth_partial_derive_st k (fun s => F s v))
    -> ex_nth_partial_derive_st n (fun s => big_sum vs (F s)).
Proof.
  induction vs; simpl; introv imp len; unfold ex_partial_derive_st_l.

  { destruct (deq_nat n 0) as [d|d]; subst; simpl in *.

    {
      destruct l; allsimpl; ginv.
      apply @ex_derive_const.
    }

    {
      eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_const;omega|].
      apply @ex_derive_const.
    }
  }

  {
    eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_plus|].

    { introv w; auto.
      apply imp; auto; try omega. }

    { introv w1.
      apply IHvs; introv w2 w3.
      apply imp; auto; try omega. }

    { apply @ex_derive_plus.
      { apply (imp a (List.length l)); auto; try omega. }
      { apply (IHvs (List.length l)); auto.
        introv h1 h2; apply imp; tcsp; try omega. }
    }
  }
Qed.

Definition DumKAssign : KAssignable := KAssignVar (variable "").

Definition lastv (l : list KAssignable) : KAssignable :=
  last l DumKAssign.

Lemma lastv_snoc :
  forall v l,
    lastv (snoc l v) = v.
Proof.
  unfold lastv; induction l; simpl; auto.
  rewrite IHl.
  destruct l; simpl; auto.
Qed.
Hint Rewrite lastv_snoc : core.

Lemma partial_derive_st_S :
  forall f l st,
    (0 < List.length l)%nat
    -> partial_derive f l st
       = partial_derive
           (fun s =>
              Derive
                (fun x => f (upd_state s (lastv l) x))
                (s (lastv l)))
           (removelast l)
           st.
Proof.
  induction l as [l ind] using list_ind_len; introv len.
  destruct (snoc_cases l) as [h|h]; exrepnd; subst; simpl in *; try omega.
  autorewrite with core in *.
  destruct k as [|v l]; simpl in *; auto.
  apply Derive_ext; introv.
  rewrite ind; autorewrite with core; try omega; auto.
Qed.

Lemma length_removelast :
  forall {T} (l : list T), List.length (removelast l) = Nat.pred (List.length l).
Proof.
  induction l; simpl; auto.
  destruct l; simpl; auto.
Qed.

Lemma ex_nth_partial_derive_st_add_Derive :
  forall n F v,
    ex_nth_partial_derive_st (S n) F
    -> ex_nth_partial_derive_st
         n
         (fun s => Derive (fun x => F (upd_state s v x)) (s v)).
Proof.
  introv d len.
  pose proof (d st (snoc l v) v0) as q.
  autorewrite with core in *.
  autodimp q hyp.
  eapply ex_derive_ext in q;
    [|introv;apply partial_derive_st_S;autorewrite with core;omega].
  simpl in q.
  eapply ex_derive_ext;[clear q|exact q].
  introv; simpl.
  autorewrite with core in *; auto.
Qed.

Lemma ex_all_partial_derive_st_add_Derive :
  forall F v,
    ex_all_partial_derive_st F
    -> ex_all_partial_derive_st
         (fun s => Derive (fun x => F (upd_state s v x)) (s v)).
Proof.
  introv d len.
  apply (ex_nth_partial_derive_st_add_Derive n); auto.
Qed.

Lemma upd_state_var_eq :
  forall s v r a,
    upd_state_var s v r a
    = if KAssignable_dec a (KAssignVar v)
      then r
      else s a.
Proof.
  sp.
Qed.

Lemma upd_state_var_eq2 :
  forall s v r w,
    upd_state_var s v r (KAssignVar w)
    = if KVariable_dec w v
      then r
      else s (KAssignVar w).
Proof.
  introv; rewrite upd_state_var_eq; repeat (dest_cases w); subst; tcsp.
Qed.

(* Can we do without function extensionality here?
   Use lists instead of functions? *)
Lemma upd_state_swap :
  forall st a1 r1 a2 r2,
    upd_state (upd_state st a1 r1) a2 r2
    = if KAssignable_dec a1 a2
      then upd_state st a2 r2
      else upd_state (upd_state st a2 r2) a1 r1.
Proof.
  introv.
  unfold upd_state.
  apply functional_extensionality; introv.
  destruct (KAssignable_dec x a2) as [d1|d1]; subst; tcsp;
    destruct (KAssignable_dec a1 a2) as [d2|d2]; subst; tcsp;
      try (destruct (KAssignable_dec a2 a2) as [d3|d3]; subst; tcsp);
      try (destruct (KAssignable_dec a2 a1) as [d4|d4]; subst; tcsp);
      try (destruct (KAssignable_dec x a1) as [d5|d5]; subst; tcsp);
      try (destruct (KAssignable_dec x a2) as [d6|d6]; subst; tcsp).
Qed.

Lemma upd_state_var_swap :
  forall st a1 r1 a2 r2,
    upd_state_var (upd_state_var st a1 r1) a2 r2
    = if KVariable_dec a1 a2
      then upd_state_var st a2 r2
      else upd_state_var (upd_state_var st a2 r2) a1 r1.
Proof.
  introv.
  unfold upd_state_var.
  rewrite upd_state_swap.
  destruct (KVariable_dec a1 a2) as [d1|d1];
    destruct (KAssignable_dec (KAssignVar a1) (KAssignVar a2)) as [d2|d2];
    subst; tcsp.
  inversion d2; tcsp.
Qed.

Lemma upd_state_eq2 :
  forall s v r w,
    upd_state s v r w
    = if KAssignable_dec w v
      then r
      else s w.
Proof.
  introv; unfold upd_state; auto.
Qed.

Lemma partial_derive_st_ext2 :
  forall f g l v w,
    (forall a, v a = w a)
    -> (forall s1 s2, (forall a, s1 a = s2 a) -> f s1 = g s2)
    -> partial_derive f l v = partial_derive g l w.
Proof.
  induction l; introv exts imp; simpl; auto.
  rewrite exts.
  apply Derive_ext; introv.
  apply IHl; auto.
  introv.
  unfold upd_state; dest_cases w.
Qed.

Lemma partial_derive_st_add_upd :
  forall F l st v r,
    ~ (List.In v l)
    -> partial_derive F l (upd_state st v r)
       = partial_derive (fun s => F (upd_state s v r)) l st.
Proof.
  induction l; introv h; simpl in *; auto.
  apply not_or in h; repnd.
  rewrite (upd_state_eq2 st v r a).
  dest_cases w.
  apply Derive_ext; introv; simpl.
  rewrite upd_state_swap.
  dest_cases w.
Qed.

Lemma partial_derive_st_add_upd2 :
  forall F l s v,
    ~ List.In v l
    -> partial_derive F l (upd_state s v (s v))
       = partial_derive (fun s => F (upd_state s v (s v))) l s.
Proof.
  induction l; introv h; simpl in *; auto.
  apply not_or in h; repnd.
  rewrite (upd_state_eq2 s v (s v) a); dest_cases w; GC.
  apply Derive_ext; introv; simpl.
  rewrite upd_state_swap.
  dest_cases w; subst.
  pose proof (IHl (upd_state s a t) v) as q; autodimp q hyp.
  rewrite upd_state_eq2 in q; dest_cases w.
Qed.

Lemma ex_nth_partial_derive_st_ext :
  forall n F G,
    (forall s, F s = G s)
    -> ex_nth_partial_derive_st n F
    -> ex_nth_partial_derive_st n G.
Proof.
  introv imp d len; simpl.
  eapply ex_derive_ext;[|apply d;exact len].
  simpl; introv.
  apply partial_derive_st_ext; auto.
Qed.

      (*
Lemma ex_nth_partial_derive_st_add_upd :
  forall n F v,
    ex_nth_partial_derive_st n F
    -> ex_nth_partial_derive_st n (fun s => F (upd_state_var s v (s (KAssignVar v)))).
Proof.
  introv d len; simpl.

  destruct (in_dec KVariable_dec v l) as [d1|d1].

  {
    (* v in l *)

  }

  {

    (* not (v in l) *)

    eapply ex_derive_ext;[introv;apply partial_derive_st_add_upd2;auto|]; simpl.
    eapply ex_derive_ext;[introv;rewrite upd_state_var_swap;reflexivity|]; simpl.
    dest_cases w; subst; simpl.
    { eapply ex_derive_ext;[introv;rewrite (upd_state_var_same st v t);reflexivity|]; simpl.
      apply d; auto. }
    { eapply ex_derive_ext;[introv;rewrite (upd_state_var_eq2 st v0 t v);dest_cases w|]; simpl.
      pose proof (d (upd_state_var st v (st (KAssignVar v))) l v0) as q; simpl in q.
      rewrite upd_state_var_eq2 in q; dest_cases w; GC.
      apply q; auto.
    }

Lemma partial_derive_st_upd_in :
  forall l F st v,
    List.In v l
    -> partial_derive_st (fun s => F (upd_state_var s v (s (KAssignVar v)))) l st
       = 0.
Proof.
  induction l; introv h; simpl in *; auto; tcsp; repndors; subst.

  {

Lemma partial_derive_st_upd_same :
  forall F v r s l,
    partial_derive_st
      (fun s => F (upd_state_var s v (s (KAssignVar v))))
      l
      (upd_state_var s v r)
    = partial_derive_st
        (fun s => F (upd_state_var s v r))
        l
        s.
Proof.
  induction l; introv; simpl; auto.

  {
    rewrite upd_state_var_same.
    rewrite upd_state_var_twice; auto.
  }

  {
    apply Derive_ext; introv.
    rewrite upd_state_var_swap.
    dest_cases w.
  }
Qed.
Hint Rewrite partial_derive_st_upd_same : core.
    erewrite Derive_ext;
      [|introv;rewrite partial_derive_st_upd_same;reflexivity].
    apply Derive_const.
  }

  {
    match goal with
    | [ H : _ = _ |- _ ] => apply inj_pair2_eq_dec in H
    end; subst; tcsp; try (apply deq_nat).
    erewrite Derive_ext;
      [|introv;apply IHl;auto].
    apply Derive_const.
  }
Qed.

    eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_upd_in;auto|].
    apply ex_derive_const.
  }

  {
    eapply ex_derive_ext;[introv;apply partial_derive_st_add_upd;auto|].
    eapply ex_derive_ext;[introv;rewrite upd_state_var_swap;reflexivity|].
    dest_cases w; subst.
    { apply ex_derive_const. }
    { apply d.  }
  }
Qed.
       *)

Lemma length_removelast_cons :
  forall {T} (v : T) l,
    List.length (removelast (v :: l)) = List.length l.
Proof.
  induction l; simpl in *; auto.
  rewrite <- IHl.
  destruct l; simpl; auto.
Qed.
Hint Rewrite @length_removelast_cons.

Lemma ex_nth_partial_derive_st_mult :
  forall (L R : state -> R) n,
    (forall k, (k <= n)%nat -> ex_nth_partial_derive_st k L)
    -> (forall k, (k <= n)%nat -> ex_nth_partial_derive_st k R)
    -> ex_nth_partial_derive_st n (fun st => (L st * R st)%R).
Proof.
  introv dL dR; simpl.
  revert L R dL dR.
  induction n as [n IHn] using comp_ind; introv dL dR len.
  destruct n.

  {
    destruct l; simpl in *; ginv.
    apply ex_derive_mult.
    { apply (dL 0%nat (le_n 0) st []); simpl; auto. }
    { apply (dR 0%nat (le_n 0) st []); simpl; auto. }
  }

  {
    eapply ex_derive_ext;
      [introv;symmetry;apply partial_derive_st_S;omega
      |].
    simpl.

    eapply ex_derive_ext; simpl;
      [introv; symmetry;
       apply partial_derive_st_ext;
       introv;apply Derive_mult
      |].

    { apply (dL 0%nat (Peano.le_0_n _) s []); tcsp. }
    { apply (dR 0%nat (Peano.le_0_n _) s []); tcsp. }

    {
      simpl.
      eapply ex_derive_ext; simpl;
        [introv; symmetry;apply partial_derive_st_plus;simpl
        |];[| |].

      {
        introv h.
        rewrite length_removelast in h.
        apply IHn; clear IHn; try omega.
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dL; try omega. }
        { introv w; simpl.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dR; try omega. }
      }

      {
        introv h; simpl.
        rewrite length_removelast in h.
        apply IHn; clear IHn; try omega.
        { introv w.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dL; try omega. }
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dR; try omega. }
      }

      simpl.
      apply @ex_derive_plus; simpl.

      {
        destruct l as [|k l]; simphyps; try omega; ginv.
        pose proof (IHn (List.length l)) as q; autodimp q hyp.
        apply (q (fun s =>
                    Derive
                      (fun x0 =>
                         L (upd_state s (lastv (k :: l)) x0))
                      (s (lastv (k :: l))))
                 (fun s =>
                    R
                      (upd_state s (lastv (k :: l))
                                 (s (lastv (k :: l))))));
          autorewrite with core in *; auto.
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dL; try omega. }
        { introv w.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dR; try omega. }
      }

      {
        destruct l as [|k l]; simphyps; try omega; ginv.
        pose proof (IHn (List.length l)) as q; autodimp q hyp.
        apply (q (fun s =>
                    L (upd_state s (lastv (k :: l))
                                 (s (lastv (k :: l)))))
                 (fun s =>
                    Derive
                      (fun x0 =>
                         R (upd_state s (lastv (k :: l)) x0))
                      (s (lastv (k :: l)))));
          autorewrite with core in *; auto.
        { introv w.
          eapply ex_nth_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|].
          apply dL; try omega. }
        { introv w; apply ex_nth_partial_derive_st_add_Derive; auto.
          apply dR; try omega. }
      }
    }
  }
Qed.

Lemma ex_all_partial_derive_st_read :
  forall x, ex_all_partial_derive_st (fun S => S x).
Proof.
  introv; introv.
  induction n; introv len; unfold ex_partial_derive_st_l.

  { destruct l; simpl in *; ginv.
    unfold upd_state_var, upd_state.
    dest_cases w; subst;
      [apply @ex_derive_id|apply @ex_derive_const].
  }

  { eapply ex_derive_ext;
      [introv;symmetry;apply partial_derive_st_S;omega|].
    simpl.
    unfold upd_state_var, upd_state at 1.
    dest_cases w; subst.

    { eapply ex_derive_ext;
        [introv;symmetry;apply partial_derive_st_ext;introv;apply Derive_id|].
      simpl.
      destruct (deq_nat n 0); subst; simpl.
      { repeat (destruct l; simpl in *; ginv).
        apply @ex_derive_const. }
      eapply ex_derive_ext;
        [introv;symmetry;apply partial_derive_st_const;rewrite length_removelast;omega|].
      apply @ex_derive_const.
    }

    { eapply ex_derive_ext;
        [introv; symmetry;apply partial_derive_st_ext;introv;apply Derive_const|].
      simpl.
      destruct (deq_nat n 0); subst; simpl.
      { repeat (destruct l; simpl in *; ginv).
        apply @ex_derive_const. }
      eapply ex_derive_ext;
        [introv;symmetry;apply partial_derive_st_const;rewrite length_removelast;omega|].
      apply @ex_derive_const.
    }
  }
Qed.

Lemma partial_derive_st_KAssignVar_prop1 :
  forall F l st v,
    ~ List.In v l
    -> partial_derive (fun s => Derive (F s) (s v)) l st
       = partial_derive (fun s => Derive (F s) (st v)) l st.
Proof.
  induction l; introv nin; simpl in *; auto.
  apply not_or in nin; repnd.
  apply Derive_ext; introv.
  rewrite (IHl (upd_state st a t) v); auto; clear IHl.
  apply partial_derive_st_ext; introv.
  rewrite upd_state_eq2.
  dest_cases w.
Qed.

Lemma ex_all_partial_derive_st_differential :
  forall vs T,
    ex_all_partial_derive_st T
    -> ex_all_partial_derive_st
         (fun v : state =>
            big_sum
              vs
              (fun x : KAssignable =>
                 (v (KD x)
                  *
                  Derive (fun X => T (upd_state v x X)) (v x)))%R).
Proof.
  introv dT; introv.
  apply ex_nth_partial_derive_st_big_sum; introv w i.

  apply ex_nth_partial_derive_st_mult.

  {
    introv lk.
    apply ex_all_partial_derive_st_read.
  }

  introv lk len; simpl.
  pose proof (dT (S k0) st (snoc l v) v0) as h; simpl in h.
  autorewrite with core in *; autodimp h hyp;[].
  eapply ex_derive_ext in h;
    [|introv;apply partial_derive_st_S; autorewrite with core; try omega].
  simpl in *; autorewrite with core in *.
  auto.
Qed.

Lemma ex_all_partial_derive_st_constant :
  forall c, ex_all_partial_derive_st (fun _ => c).
Proof.
  introv len; unfold ex_partial_derive_st_l; simpl.
  destruct l.
  { simpl; apply @ex_derive_const. }
  { apply (@ex_derive_ext
             Hierarchy.R_AbsRing
             Hierarchy.R_NormedModule
             (fun _ => 0%R)).
    { introv.
      rewrite partial_derive_st_const; simpl; try omega; auto. }
    { simpl; apply @ex_derive_const. }
  }
Qed.

Lemma ex_all_partial_derive_st_plus :
  forall (L R : state -> R),
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st R
    -> ex_all_partial_derive_st (fun st => (L st + R st)%R).
Proof.
  introv d1 d2 len; simpl in *.
  eapply ex_derive_ext;
    [introv;symmetry;apply partial_derive_st_plus; auto|].
  apply @ex_derive_plus;[apply (d1 n)|apply (d2 n)];auto.
Qed.

(*
   This shows that [ex_partial_derive_st_func] might not be that bogus after all.
 *)
Lemma ex_partial_derive_st_func_plus_vector : ex_partial_derive_st_func plus_vector.
Proof.
  introv d; introv.
  unfold plus_vector; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_all_partial_derive_st (fun s : state => G s t)) ->
                   ex_all_partial_derive_st
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => (G s h + G s h0)%R
                        | @Vector.cons _ _ _ _ => 0%R
                        end))).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp;[repeat constructor|].

  apply ex_all_partial_derive_st_plus; auto.
Qed.

Lemma ex_partial_derive_st_l_pt_plus :
  forall (L R : state -> R) v l,
    (forall w l', sublist (w :: l') (v :: l) -> ex_partial_derive L w l')
    -> (forall w l', sublist (w :: l') (v :: l) -> ex_partial_derive R w l')
    -> ex_partial_derive (fun st => (L st + R st)%R) v l.
Proof.
  introv d1 d2; introv; simpl in *.
  eapply ex_derive_ext;
    [introv;symmetry;apply partial_derive_st_plus_sublist; auto|].
  simpl.
  apply @ex_derive_plus; simpl;[apply d1|apply d2];apply sublist_refl.
Qed.

(*
  Similar to [ex_partial_derive_st_func_plus_vector].  We show that
  [ex_partial_derive_st_func] make at least sense for Rplus.
 *)
Lemma ex_partial_derive_st_func_sub_plus_vector :
  smooth_fun_T plus_vector.
Proof.
  introv d cond.
  unfold plus_vector; simpl.
  revert cond.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t w l',
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       sublist (w :: l') (v :: l) ->
                       ex_partial_derive (fun s : state => G s t) w l') ->
                   ex_partial_derive
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => (G s h + G s h0)%R
                        | @Vector.cons _ _ _ _ => 0%R
                        end) v l)).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.

  apply ex_partial_derive_st_l_pt_plus; auto; introv ss;
    [apply h1|apply h2]; auto; repeat constructor.
Qed.

(* This is a generalization of plus_vector *)
Definition bin2vec (f : R -> R -> R) : Vector.t R 2%nat -> R :=
  fun v : Vector.t R 2%nat =>
    match v with
    | Vector.cons x 1 (Vector.cons y 0 Vector.nil) => f x y
    | _ => R0
    end.

(* This is a generalization of ex_partial_derive_st_func_plus_vector *)
Lemma ex_partial_derive_st_func_bin2vec :
  forall f,
    (forall (L R : state -> R),
        ex_all_partial_derive_st L
        -> ex_all_partial_derive_st R
        -> ex_all_partial_derive_st (fun st => f (L st) (R st)))
    -> ex_partial_derive_st_func (bin2vec f).
Proof.
  introv cond d; introv.
  unfold bin2vec; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_all_partial_derive_st (fun s : state => G s t)) ->
                   ex_all_partial_derive_st
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => f (G s h) (G s h0)
                        | @Vector.cons _ _ _ _ => 0%R
                        end))).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp.
  repeat constructor.
Qed.

Lemma partial_derive_st_opp :
  forall l st L,
    (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k L)
    -> partial_derive (fun s => - (L s)) l st
       = - partial_derive L l st.
Proof.
  induction l; introv dL; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_opp; auto.
Qed.

Lemma partial_derive_st_opp_sublist :
  forall l st L,
    (forall v k, sublist (v :: k) l -> ex_partial_derive L v k)
    -> partial_derive (fun s => - L s) l st
       = - partial_derive L l st.
Proof.
  induction l; introv dL; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_opp; auto.
Qed.

Lemma ex_all_partial_derive_st_neg :
  forall L,
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st (fun s => - (L s)).
Proof.
  introv dL len.
  eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_opp;auto|];[].
  apply @ex_derive_opp.
  apply (dL n); auto.
Qed.

Lemma partial_derive_st_minus :
  forall l st L R,
    (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k L)
    -> (forall k, (k <= List.length l)%nat -> ex_nth_partial_derive_st k R)
    -> partial_derive (fun s => (L s - R s)%R) l st
       = (partial_derive L l st
          - partial_derive R l st)%R.
Proof.
  induction l; introv dL dR; simpl in *; auto.
  erewrite Derive_ext;[|introv;apply IHl;auto].
  rewrite Derive_minus; auto;[apply (dL (List.length l))|apply (dR (List.length l))];try omega.
Qed.

Lemma ex_all_partial_derive_st_minus :
  forall L R,
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st R
    -> ex_all_partial_derive_st (fun s => (L s - R s)%R).
Proof.
  introv d1 d2 len; simpl in *.
  eapply ex_derive_ext;[introv;symmetry;apply partial_derive_st_minus; auto|].
  apply @ex_derive_minus;[apply (d1 n)|apply (d2 n)]; auto.
Qed.

Lemma ex_all_partial_derive_st_mult :
  forall (L R : state -> R),
    ex_all_partial_derive_st L
    -> ex_all_partial_derive_st R
    -> ex_all_partial_derive_st (fun st => (L st * R st)%R).
Proof.
  introv dL dR; introv; simpl.
  apply ex_nth_partial_derive_st_mult; introv w; auto.
Qed.

Lemma ex_derive_all_n_implies_ex_derive :
  forall F,
    ex_derive_all_n F
    -> ex_derive_all F.
Proof.
  introv h; introv.
  pose proof (h 1%nat pt) as w; auto.
Qed.

Lemma implies_ex_derive_all_n_Derive :
  forall F,
    ex_derive_all_n F
    -> ex_derive_all_n (Derive F).
Proof.
  introv h; introv.
  pose proof (h (S n) pt) as q.
  apply ex_derive_n_S_implies in q; auto.
  pose proof (h 1%nat pt) as w; auto.
Qed.

Lemma ex_derive_partial_derive_st_comp :
  forall (F : R -> R) (A : state -> R) st v l,
    ex_all_partial_derive_st A
    -> ex_derive_all_n F
    -> ex_derive_R
         (fun X =>
            partial_derive
              (fun s => F (A s))
              l
              (upd_state st v X))
         (st v).
Proof.
  introv.
  remember (List.length l) as n.
  revert F A st v l Heqn.
  induction n as [n IHn] using comp_ind; introv e dA dF; subst.
  destruct l as [|k l].

  {
    simpl.
    apply @ex_derive_comp.
    { apply ex_derive_all_n_implies_ex_derive in dF; apply dF. }
    apply (dA 0%nat st []); simpl; auto.
  }

  {
    eapply ex_derive_ext;
      [introv;symmetry;
       apply (partial_derive_st_S (fun s : state => F (A s)));
       simpl; try omega|].
    remember (k :: l) as L.
    simpl.

    eapply ex_derive_ext; simpl;
      [introv; symmetry;
       apply partial_derive_st_ext;
       introv;apply Derive_comp
      |].

    { apply ex_derive_all_n_implies_ex_derive in dF; apply dF. }

    { apply (dA 0%nat s []); simpl; auto. }

    {
      simpl.
      apply (ex_nth_partial_derive_st_mult _ _ (List.length (removelast L)));auto.
      { introv w; apply ex_nth_partial_derive_st_add_Derive; auto. }
      { introv w len.
        rewrite HeqL in w; autorewrite with core in *.
        apply (IHn k0);auto;[subst; simpl; try omega| |].

        { eapply ex_all_partial_derive_st_ext;
            [introv;symmetry;rewrite upd_state_ext;reflexivity|]; auto. }

        { apply implies_ex_derive_all_n_Derive; auto. }
      }
    }
  }
Qed.

Lemma ex_partial_derive_st_func_l_plus_vector : ex_partial_derive_st_func_l plus_vector.
Proof.
  introv d; introv.
  unfold plus_vector; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_partial_derive_st_l (fun s : state => G s t) st l v) ->
                   ex_partial_derive_st_l
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => (G s h + G s h0)%R
                        | @Vector.cons _ _ _ _ => 0%R
                        end) st l v)).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp;[repeat constructor|].

  pose proof (ex_all_partial_derive_st_plus (fun s => G s x) (fun s => G s y)) as h.
  repeat (autodimp h hyp);[| |eapply h; eauto].

Abort.

Lemma ex_all_partial_derive_st_funcOf :
  forall f m (args : Vector.t Term m) (I : interpretation),
    (forall t I,
        Vector.In t args
        -> ex_all_partial_derive_st (fun s => dynamic_semantics_term I s t))
    -> ex_all_partial_derive_st
         (fun s =>
            interp_fun_f
              m
              (I (SymbolFunction f m))
              (Vector.map (dynamic_semantics_term I s) args)).
Proof.
  introv ih.
  remember (I (SymbolFunction f m)) as pF; simpl in pF.
  destruct pF as [F sm]; simpl.
  clear dependent f.
  introv len; subst.
  apply sm; clear sm; try (exact (KTdot 0)); auto.
  introv i ss; introv; simpl in *.
  pose proof (ih t I i (length l') (upd_state s w pt) l' w eq_refl) as q.
  unfold ex_partial_derive_st_l in q; simpl in q.
  autorewrite with core in q.
  eapply ex_derive_ext;[|exact q];clear q; simpl; introv.
  autorewrite with core; auto.
Qed.

Lemma ex_all_partial_derive_st_dynamic_semantics_term :
  forall (t : Term) (I : interpretation),
    ex_all_partial_derive_st (fun s => dynamic_semantics_term I s t).
Proof.
  term_ind t Case; introv; simpl.

  { Case "KTdot".
    apply ex_all_partial_derive_st_constant.
  }

  { Case "KTfuncOf".
    apply ex_all_partial_derive_st_funcOf; auto.
  }

  { Case "KTnumber".
    apply ex_all_partial_derive_st_constant.
  }

  { Case "KTread".
    apply ex_all_partial_derive_st_read.
  }

  { Case "KTneg".
    apply ex_all_partial_derive_st_neg;auto.
  }

  { Case "KTplus".
    apply ex_all_partial_derive_st_plus;auto.
  }

  { Case "KTminus".
    apply ex_all_partial_derive_st_minus;auto.
  }

  { Case "KTtimes".
    apply ex_all_partial_derive_st_mult;auto.
  }

  { Case "KTdifferential".
    apply (ex_all_partial_derive_st_differential _ (fun s => dynamic_semantics_term I s t)); auto.
  }
Qed.
Hint Resolve ex_all_partial_derive_st_dynamic_semantics_term : core.

Lemma ex_partial_derive_st_pt_dynamic_semantics_term :
  forall (t : Term) (I : interpretation),
    ex_partial_derive_st_pt (fun s => dynamic_semantics_term I s t).
Proof.
  introv.
  apply ex_partial_derive_st_pt_eq_all; eauto 3 with core.
Qed.
Hint Resolve ex_partial_derive_st_pt_dynamic_semantics_term : core.


Require Import Utils.

Module Type CTXTYP.

Parameter Tp : Type->Type.

Parameter tpTp : forall G,Tp G->G->Type.
Implicit Arguments tpTp [G].
Coercion tpTp : Tp >-> Funclass.

Parameter tpMap : forall G G' (f:G'->G),Tp G->Tp G'.
Implicit Arguments tpMap [G G'].

Parameter tpMapEq : forall G G' (f:G'->G) (T:Tp G),(fun g=>T (f g)) = tpMap f T.
Implicit Arguments tpMapEq [G G'].

End CTXTYP.

Module Context (Import Typ : CTXTYP).

(* Semantic contexts *)

Inductive CtxS : Type->Type :=
	empCtxS : CtxS unit |
	extCtxS G : CtxS G->forall T:Tp G,CtxS (sigT T).
Implicit Arguments extCtxS [G].

Inductive Ctx : Type := ctx G (s:CtxS G).
Implicit Arguments ctx [G].

Definition ctxTp G := match G with ctx G _ => G end.
Coercion ctxTp : Ctx >-> Sortclass.

Definition ctxSc (G:Ctx) : CtxS G := match G with ctx _ s => s end.

Definition empCtx := ctx empCtxS.
Definition extCtx G T := ctx (extCtxS (ctxSc G) T).

Definition IsExtCtx G := match G with
	ctx _ empCtxS => False |
	ctx _ (extCtxS _ _ _) => True
end.

Definition ctxInit G := match G with
	ctx _ empCtxS => empCtx |
	ctx _ (extCtxS _ s _) => ctx s
end.

Definition ctxTop G : forall ne:IsExtCtx G,Tp (ctxInit G).
	destruct G.
	destruct s;simpl;intro.

	destruct ne.

	exact T.
Defined.
Implicit Arguments ctxTop [G].

Fixpoint ctxLenS G (s:CtxS G) := match s with
	empCtxS => O |
	extCtxS _ s _ => S (ctxLenS _ s)
end.
Implicit Arguments ctxLenS [G].

Definition ctxLen G := ctxLenS (ctxSc G).

Definition extCtxUnfold G : forall ne:IsExtCtx G,G = extCtx (ctxInit G) (ctxTop ne).
	destruct G.
	destruct s;simpl;intro.

	destruct ne.

	reflexivity.
Defined.
Implicit Arguments extCtxUnfold [G].

Definition extCtxInj G1 G2 : forall T1 T2 (e:extCtx G1 T1 = extCtx G2 T2),
existT Tp G1 T1 = existT Tp G2 T2.
	destruct G1 as (G1,s1).
	destruct G2 as (G2,s2).
	simpl.
	intros.
	generalize I.
	apply (tr (fun Gx=>forall ne:IsExtCtx Gx,_ = existT _ _ (ctxTop ne)) e).
	simpl.
	intro.
	reflexivity.
Defined.
Implicit Arguments extCtxInj [G1 G2 T1 T2].

(* Strongly typed de Bruijn indexes *)

(*
Inductive AtCtx : forall G:Ctx,nat->Tp G->Type :=
	topCtx G T : AtCtx (extCtx G T) O (tpMap (@projT1 _ _) T) |
	popCtx G n T : AtCtx G n T->forall T',AtCtx (extCtx G T') (S n) (tpMap (@projT1 _ _) T).
*)

Inductive PopCtx G (T':G->Type) P : Tp (sigT T')->Type :=
	mkPopCtx T : P T->PopCtx G T' P (tpMap (@projT1 _ _) T).
Implicit Arguments PopCtx [G].
Implicit Arguments mkPopCtx [G].

Fixpoint AtCtxS G (s:CtxS G) n := match s in CtxS G return forall T:Tp G,Type with
	empCtxS => fun T=>Empty_set |
	extCtxS _ s T' => match n with
		O => eq (tpMap (@projT1 _ _) T') |
		S n => PopCtx T' (AtCtxS _ s n)
	end
end.
Implicit Arguments AtCtxS [G].

Definition AtCtx G := AtCtxS (ctxSc G).

Definition topCtx G T : AtCtx (extCtx G T) O (tpMap (@projT1 _ _) T) := eq_refl _.

Definition popCtx G n T (a:AtCtx G n T) T' : AtCtx (extCtx G T') (S n) (tpMap (@projT1 _ _) T) :=
	mkPopCtx _ _ _ a.
Implicit Arguments popCtx [G n T].

Definition atCtxIndS (P:forall G n T,AtCtx G n T->Type)
	(top:forall G T,P _ _ _ (topCtx G T))
	(pop:forall G n T (a:AtCtx G n T) (IHa:P _ _ _ a) T',P _ _ _ (popCtx a T'))
: forall G (s:CtxS G) n T (a:AtCtx (ctx s) n T),P _ _ _ a.
	refine (fix atCtxIndS G s n := match s in CtxS G return forall T (a:AtCtx (ctx s) n T),P _ _ _ a with
		empCtxS => _ |
		extCtxS _ s _ => _
	end);clear G s;simpl;intro.

	intro.
	destruct a.

	destruct n;unfold AtCtx;simpl;intro;destruct a.
		exact (top (ctx s0) _).

		exact (pop _ _ _ _ (atCtxIndS _ _ _ _ _) _).
Defined.

Definition AtCtx_rect (P:forall G n T,AtCtx G n T->Type)
	(top:forall G T,P _ _ _ (topCtx G T))
	(pop:forall G n T (a:AtCtx G n T) (IHa:P _ _ _ a) T',P _ _ _ (popCtx a T'))
G := match G return forall n T (a:AtCtx G n T),P _ _ _ a with ctx _ s => atCtxIndS P top pop _ s end.
Implicit Arguments AtCtx_rect [G n T].

Inductive ExAtCtx G n : Type := exAtCtx T (a:AtCtx G n T).
Implicit Arguments exAtCtx [G n T].

Definition xa_T G n (xa:ExAtCtx G n) := match xa with exAtCtx T _ => T end.
Implicit Arguments xa_T [G n].

Definition xa_a G n (xa:ExAtCtx G n) : AtCtx G n (xa_T xa) := match xa with exAtCtx _ a => a end.
Implicit Arguments xa_a [G n].

Definition atCtxUniq G n T1 (a1:AtCtx G n T1) : forall T2 (a2:AtCtx G n T2),
exAtCtx a1 = exAtCtx a2.
	induction a1 as [| ? ? T1] using AtCtx_rect;intros.

	destruct a2.
	reflexivity.

	change (PopCtx T' (AtCtx G n) T2) in a2.
	destruct a2 as (T2,a2).
	exact (tr (fun xa=>_ = exAtCtx (popCtx (xa_a xa) T')) (IHa1 _ a2) (eq_refl _)).
Defined.
Implicit Arguments atCtxUniq [G n T1 T2].

Definition ctxProj G n T (a:AtCtx G n T) : forall g,T g.
	induction a using AtCtx_rect.

	apply (tr (fun X=>forall g,X g) (tpMapEq (@projT1 _ T) T)).
	exact (@projT2 _ _).

	apply (tr (fun X=>forall g,X g) (tpMapEq (@projT1 _ T') T)).
	exact (fun g=>IHa (projT1 g)).
Defined.
Implicit Arguments ctxProj [G n T].

(*
Remark ctxProj_top G T : ctxProj (topCtx G T) = @projT2 _ _.
	reflexivity.
Qed.

Definition ctxProj_pop G n := match G
return forall T (a:AtCtx G n T) T',(fun g=>ctxProj a (projT1 g)) = ctxProj (popCtx a T')
	with ctx _ _ => fun _ _ _=>eq_refl _ end.
Implicit Arguments ctxProj_pop [G n T].

Definition atCtxEta G n : forall T (a:AtCtx G n T),AtCtx G n (fun g=>T g).
	destruct G.
	unfold AtCtx.
	simpl.
	intro.
	destruct s as [| ? ? T'].

	simpl.
	exact (fun x=>x).

	destruct n;simpl;intro;destruct a.
		reflexivity.

		exact (mkPopCtx _ _ _ a).
Defined.
Implicit Arguments atCtxEta [G n T].

Definition ctxProj_Eta G n : forall T (a:AtCtx G n T),(fun g=>ctxProj a g) = ctxProj (atCtxEta a).
	destruct G.
	unfold AtCtx.
	simpl ctxSc.
	simpl ctxTp.
	intro.
	destruct s as [| ? ? T'].

	simpl AtCtxS.
	intro.
	destruct a.

	destruct n;simpl AtCtxS;intro;destruct a;reflexivity.
Defined.
Implicit Arguments ctxProj_Eta [G n T].
*)

(* Iterated context extension *)

Inductive ExtCtx GL : nat->Ctx->Type :=
	extOCtx : ExtCtx GL O GL |
	extSCtx n G : ExtCtx GL n G->forall T:G->Type,ExtCtx GL (S n) (extCtx G T).
Implicit Arguments extSCtx [GL n G].

Definition extSCtxInv GL n G T (xg:ExtCtx GL (S n) (extCtx G T)) (P:forall n G T,ExtCtx GL n (extCtx G T)->Type)
	(xgS:forall xg:ExtCtx GL n G,P _ _ _ (extSCtx xg T))
: P _ _ _ xg.
	pose (P' n Gx (xg:ExtCtx GL n Gx) := forall ne:IsExtCtx Gx,
		P _ _ _ (tr (ExtCtx GL n) (extCtxUnfold ne) xg)).
	assert (Peq := match G as G return forall T xg,P (S n) G T xg = P _ (ctx (ctxSc G)) _ xg
		with ctx _ _ => fun _ _=>eq_refl _ end T).
	apply (tr (fun C=>C) (eq_sym (Peq _))).
	generalize I.
	change (P' _ _ xg).
	refine (match xg as xg in ExtCtx _ Sn Gx return (Sn = S n)->(extCtx G T = Gx)->P' _ _ xg with
		extOCtx => fun e=>match O_S _ e with end |
		extSCtx _ _ xg0 _ => fun Hn HG=>_
	end (eq_refl _) (eq_refl _)).
	revert xg0.
	apply (tr (fun _=>_) (eq_sym (Sinj Hn))).
	apply (tr (fun GT=>forall xg,P' _ _ (extSCtx xg (projT2 GT))) (extCtxInj HG)).
	simpl.
	intros ? ?.
	simpl.
	exact (tr (fun C=>C) (Peq _) (xgS _)).
Defined.
Implicit Arguments extSCtxInv [GL n G T].

Definition extSCtxInvEq GL n G P := match G
return forall T (xg:ExtCtx GL n G) xgS,xgS xg = extSCtxInv (extSCtx xg T) P xgS
	with ctx _ _ => fun _ _ _=>eq_refl _ end.
Implicit Arguments extSCtxInvEq [GL n G T].

(*
Inductive ExtSCtx P : Ctx->Type := mkExtSCtx G : P G->forall T,ExtSCtx P (extCtx G T).
Implicit Arguments mkExtSCtx [P G].

Fixpoint ExtCtx GL n : Ctx->Type := match n with
	O => eq GL |
	S n => ExtSCtx (ExtCtx GL n)
end.

Definition extOCtx GL : ExtCtx GL O GL := eq_refl _.
Definition extSCtx GL n G (xg:ExtCtx GL n G) T : ExtCtx GL (S n) (extCtx G T) := mkExtSCtx xg _.
Implicit Arguments extSCtx [GL n G].

Definition ExtCtx_rect GL (P:forall n G,ExtCtx GL n G->Type)
	(xgO:P _ _ (extOCtx GL))
	(xgS:forall n G (xg:ExtCtx GL n G) (IHxg:P _ _ xg) T,P _ _ (extSCtx xg T))
: forall n G (xg:ExtCtx GL n G),P _ _ xg.
	refine (fix ExtCtx_rect n G := match n return forall xg:ExtCtx GL n G,P _ _ xg with
		O => _ |
		S _ => _
	end);simpl;intro;destruct xg.

	exact xgO.

	exact (xgS _ _ _ (ExtCtx_rect _ _ _) _).
Defined.
Implicit Arguments ExtCtx_rect [GL n G].

Definition extSCtxInv P G T (xg:ExtSCtx P (extCtx G T)) (C:forall G T,ExtSCtx P (extCtx G T)->Type)
	(xgS:forall xg:P G,C _ _ (mkExtSCtx xg T))
: C _ _ xg.
	pose (C' Gx xg := forall ne:IsExtCtx Gx,C _ _ (tr (ExtSCtx P) (extCtxUnfold ne) xg)).
	assert (HC : forall G T xg,C G T xg = C (ctx (ctxSc G)) T xg).
		exact (fun G=>match G with ctx _ _ => fun _ _=>eq_refl _ end).
	apply (tr (fun X=>X) (eq_sym (HC _ _ _))).
	generalize I.
	change (C' _ xg).
	refine (match xg as xg in ExtSCtx _ Gx return (extCtx G T = Gx)->C' Gx xg with
		mkExtSCtx _ xg _ => _ end (eq_refl _)).
	clear xg.
	intro.
	revert xg0.
	apply (tr (fun s=>forall xg:P (projT1 s),C' _ (mkExtSCtx xg (projT2 s))) (extCtxInj H)).
	clear G0 T0 H.
	simpl.
	intros ? ?.
	simpl.
	exact (tr (fun X=>X) (HC _ _ _) (xgS xg)).
Defined.
Implicit Arguments extSCtxInv [P G T].

Definition extSCtxInvEq P G C := match G
return forall T (xg:P G) xgS,xgS xg = extSCtxInv (mkExtSCtx xg T) C xgS
	with ctx _ _ => fun _ _ _=>eq_refl _ end.
Implicit Arguments extSCtxInvEq [P G T].
*)

(*
(* Induction on the number of added entries *)
Definition extCtxNInd D (GL:Ctx D) (P:forall n G,ExtCtx GL n G->Type)
	(xgO:P _ _ (extOCtx GL))
	(xgS:forall n,(forall G (xg:ExtCtx GL n G),P _ _ xg)->
		forall G (xg:ExtCtx GL n G) T,P _ _ (extSCtx xg T))
: forall n G (xg:ExtCtx GL n G),P _ _ xg.
	refine (fix extCtxNInd n G := match n with
		O => fun xg=>_ |
		S _ => fun xg=>_
	end).

	exact (extOCtxInv xg _ xgO).

	exact (extSCtxInv xg _ (xgS _ (extCtxNInd _))).
Defined.
Implicit Arguments extCtxNInd [D GL n G].
*)

Fixpoint unExt GL n G (xg:ExtCtx GL n G) : G->GL := match xg with
	extOCtx => fun g=>g |
	extSCtx _ _ xg _ => fun g=>unExt _ _ _ xg (projT1 g)
end.
Implicit Arguments unExt [GL n G].

Definition extAtCtxInd GL P (C:forall n G P',ExtCtx (extCtx GL P) n G->AtCtx G n P'->Type)
	(xgO:C _ _ _ (extOCtx _) (topCtx GL P))
	(xgS:forall n G P' xg (a:AtCtx G n P') T,C _ _ _ xg a->C _ _ _ (extSCtx xg T) (popCtx a T))
n G (xg:ExtCtx (extCtx GL P) n G) : forall P' (a:AtCtx G n P'),C _ _ _ xg a.
	induction xg;unfold AtCtx;simpl;intros;destruct a.

	exact xgO.

	exact (xgS _ _ _ _ _ _ (IHxg _ _)).
Defined.
Implicit Arguments extAtCtxInd [GL P n G P'].

Inductive ExtCtxComp GL' n G : Type := mkExtCtxComp G' (xg':ExtCtx GL' n G') (f':G'->G).
Implicit Arguments mkExtCtxComp [GL' n G G'].

Definition xc_G' GL' n G (xc:ExtCtxComp GL' n G) := match xc with mkExtCtxComp G' _ _ => G' end.
Implicit Arguments xc_G' [GL' n G].

Definition xc_xg' GL' n G (xc:ExtCtxComp GL' n G) : ExtCtx GL' n (xc_G' xc) := match xc with mkExtCtxComp _ xg' _ => xg' end.
Implicit Arguments xc_xg' [GL' n G].

Definition xc_f' GL' n G (xc:ExtCtxComp GL' n G) : xc_G' xc->G := match xc with mkExtCtxComp _ _ f' => f' end.
Implicit Arguments xc_f' [GL' n G].

Definition extCtxComp GL n G (xg:ExtCtx GL n G) (GL':Ctx) (f:GL'->GL) : ExtCtxComp GL' n G.
	induction xg.

	exact (mkExtCtxComp (extOCtx _) f).

	exact (mkExtCtxComp (extSCtx (xc_xg' IHxg) _)
		(fun (g:sigT (fun g=>T (_ g)))=>existT _ (xc_f' IHxg (projT1 g)) (projT2 g))).
Defined.
Implicit Arguments extCtxComp [GL n G].

Definition xcBump GL P l G (xg:ExtCtx GL l G) := extCtxComp xg (extCtx GL P) (@projT1 _ _).
Implicit Arguments xcBump [GL l G].

Definition ctxBump GL P l G (xg:ExtCtx GL l G) := xc_G' (xcBump P xg).
Implicit Arguments ctxBump [GL l G].

Definition xgBump GL P l G (xg:ExtCtx GL l G) : ExtCtx _ l (ctxBump P xg) := xc_xg' (xcBump P xg).
Implicit Arguments xgBump [GL l G].

Definition elBump GL P l G (xg:ExtCtx GL l G) T (t:forall g,T g) (g:ctxBump P xg) :=
	t (xc_f' (xcBump P xg) g).
Implicit Arguments elBump [GL l G T].

Definition atBumpLo GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd n l) : AtCtx (ctxBump P xg) n (elBump P xg T).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);simpl;intro.

	apply (extSCtxInv xg).
	clear xg.
	intro.
	reflexivity.

	revert T a IHa.
	apply (extSCtxInv xg).
	clear xg.
	intros.
	change (AtCtx (extCtx (ctxBump P xg) (elBump P xg T')) (S n) (fun g=>elBump P xg T (projT1 g))).
	apply popCtx.
	exact (IHa _ Ho xg).
Defined.
Implicit Arguments atBumpLo [GL l G n T].

Definition atBumpHi GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd l (S n)) : AtCtx (ctxBump P xg) (S n) (elBump P xg T).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	unfold ctxBump.
	simpl.
	apply (popCtx a).

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G n) T) in a.
	destruct a.
	change (AtCtx (extCtx (ctxBump P xg) (elBump P xg T')) (S (S n)) (fun g=>elBump P xg T (projT1 g))).
	apply popCtx.
	exact (IHxg _ Ho _ a).
Defined.
Implicit Arguments atBumpHi [GL l G n T].

Definition ctxProj_BumpLo GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd n l) :
elBump P xg (ctxProj a) = ctxProj (atBumpLo P xg a Ho).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	revert Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T.
	destruct G.
	simpl.
	intros.
	reflexivity.

	revert T a IHa Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T'.
	destruct G.
	simpl ctxTp.
	intros.
	change (elBump P (extSCtx xg T') (ctxProj (popCtx a T')) =
		ctxProj (popCtx (atBumpLo P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atBumpLo P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHa _ Ho xg)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_BumpLo [GL l G n T].

Definition ctxProj_BumpHi GL P l G n T (xg:ExtCtx GL l G) (a:AtCtx G n T) (Ho:ltd l (S n)) :
elBump P xg (ctxProj a) = ctxProj (atBumpHi P xg a Ho).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros ? ?.
	revert P.
	destruct GL as (GL,?).
	simpl ctxTp.
	intros.
	reflexivity.

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G n) T) in a.
	destruct a.
	change (elBump P (extSCtx xg T') (ctxProj (popCtx a T')) =
		ctxProj (popCtx (atBumpHi P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>elBump P (extSCtx xg T') X = _) (ctxProj_pop a T')).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atBumpHi P xg a Ho) (elBump P xg T'))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHxg _ Ho _ a)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_BumpHi [GL l G n T].

Definition xcSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) (p:forall g,P g) :=
	extCtxComp xg GL (fun g=>existT _ g (p g)).
Implicit Arguments xcSubst [GL P l G].

Definition ctxSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) p := xc_G' (xcSubst xg p).
Implicit Arguments ctxSubst [GL P l G].

Definition xgSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) p : ExtCtx GL l (ctxSubst xg p) :=
	xc_xg' (xcSubst xg p).
Implicit Arguments xgSubst [GL P l G].

Definition elSubst GL P l G (xg:ExtCtx (extCtx GL P) l G) T (t:forall g,T g) p
	(g:ctxSubst xg p) := t (xc_f' (xcSubst xg p) g).
Implicit Arguments elSubst [GL P l G T].

Definition atSubstLt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G n T) (Ho:ltd n l) p :
AtCtx (ctxSubst xg p) n (elSubst xg T p).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	apply (extSCtxInv xg).
	clear xg.
	intro.
	unfold ctxSubst.
	simpl.
	apply topCtx.

	revert T a IHa.
	apply (extSCtxInv xg).
	clear xg.
	intros.
	change (AtCtx (extCtx (ctxSubst xg p) (elSubst xg T' p)) (S n) (fun g=>elSubst xg T p (projT1 g))).
	apply popCtx.
	exact (IHa _ Ho xg).
Defined.
Implicit Arguments atSubstLt [GL P l G n T].

Definition atSubstGt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G (S n) T) (Ho:ltd l (S n)) p :
AtCtx (ctxSubst xg p) n (elSubst xg T p).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	change (PopCtx P (AtCtx GL n) T) in a.
	destruct a.
	exact (atCtxEta a).

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G (S n)) T) in a.
	destruct a.
	change (AtCtx (extCtx (ctxSubst xg p) (elSubst xg T' p)) (S n) (fun g=>elSubst xg T p (projT1 g))).
	apply popCtx.
	exact (IHxg _ Ho _ a).
Defined.
Implicit Arguments atSubstGt [GL P l G n T].

Definition elMBump GL P n G P' (xg:ExtCtx (extCtx GL P) n G) (a:AtCtx G n P') (p:forall g,P g) : forall g,P' g.
	revert P' a.
	induction xg;intros ? ?.

	destruct a.
	exact (fun g=>p (projT1 g)).

	change (PopCtx T (AtCtx G n) P') in a.
	destruct a as (P',?).
	exact (fun g=>IHxg _ a (projT1 g)).
Defined.
Implicit Arguments elMBump [GL P n G P'].

Definition ctxProj_SubstLt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G n T) (Ho:ltd n l) p :
elSubst xg (ctxProj a) p = ctxProj (atSubstLt xg a Ho p).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	revert Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T.
	destruct G.
	simpl.
	intros.
	reflexivity.

	revert T a IHa Ho.
	apply (extSCtxInv xg).
	clear xg.
	revert T'.
	destruct G.
	simpl ctxTp.
	intros.
	change (elSubst (extSCtx xg T') (ctxProj (popCtx a T')) p =
		ctxProj (popCtx (atSubstLt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atSubstLt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHa _ Ho xg)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_SubstLt [GL P l G n T].

Definition ctxProj_SubstGt GL P l G n T (xg:ExtCtx (extCtx GL P) l G) (a:AtCtx G (S n) T) (Ho:ltd l (S n)) p :
elSubst xg (ctxProj a) p = ctxProj (atSubstGt xg a Ho p).
	revert n Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	change (PopCtx P (AtCtx GL n) T) in a.
	destruct a.
	change (elSubst (extOCtx (extCtx GL P)) (ctxProj (popCtx a P)) p = ctxProj (atCtxEta a)).
	apply (tr (fun X=>elSubst (extOCtx _) X p = _) (ctxProj_pop a P)).
	apply (tr (fun X=>_ = X) (ctxProj_Eta a)).
	reflexivity.

	intro.
	destruct n.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G (S n)) T) in a.
	destruct a.
	change (elSubst (extSCtx xg T') (ctxProj (popCtx a T')) p =
		ctxProj (popCtx (atSubstGt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>elSubst (extSCtx xg T') X p = _) (ctxProj_pop a T')).
	apply (tr (fun X=>_ = X) (ctxProj_pop (atSubstGt xg a Ho p) (elSubst xg T' p))).
	apply (tr (fun X=>_ = fun g=>X (projT1 g)) (IHxg _ Ho _ a)).
	reflexivity.
Defined.
Implicit Arguments ctxProj_SubstGt [GL P l G n T].

Definition ctxProj_SubstEq GL P n G P' (xg:ExtCtx (extCtx GL P) n G) (a:AtCtx G n P') p :
elSubst xg (ctxProj a) p = elSubst xg (elMBump xg a p) p.
	apply extAtCtxInd with (xg := xg) (a := a);clear n G P' xg a.

	reflexivity.

	intros ? ?.
	destruct G.
	simpl ctxTp.
	intros.
	change ((fun g:ctxSubst (extSCtx xg T) p=>elSubst xg (ctxProj a) p (projT1 g)) =
		(fun g=>elSubst xg (elMBump xg a p) p (projT1 g))).
	apply (tr (fun X=>_ = fun g:ctxSubst (extSCtx xg T) p=>X (projT1 g)) H).
	reflexivity.
Defined.
Implicit Arguments ctxProj_SubstEq [GL P n G P'].

(* Stuff for substituting one variable for another *)

Fixpoint atMBump GL l G n T (xg:ExtCtx GL l G) (a:AtCtx GL n T) : ExAtCtx G (l + n) := match xg with
	extOCtx => exAtCtx a |
	extSCtx _ _ xg T' => exAtCtx (popCtx (xa_a (atMBump _ _ _ _ _ xg a)) T')
end.
Implicit Arguments atMBump [GL l G n T].

Definition atMBumpTEq GL a b P G (b':AtCtx GL b P) (xg:ExtCtx (extCtx GL P) a G) :
forall P' (a':AtCtx G a P'),xa_T (atMBump xg (popCtx b' P)) = P'.
	induction xg as [| a];intros ? ?;simpl.

	destruct a'.
	reflexivity.

	change (PopCtx T (AtCtx G a) P') in a'.
	destruct a' as (P',a').
	apply (tr (fun _=>_) (IHxg _ a')).
	reflexivity.
Defined.
Implicit Arguments atMBumpTEq [GL a b P G P'].

Definition ctxProj_MBump GL a b P G P' (b':AtCtx GL b P) (xg:ExtCtx (extCtx GL P) a G) (a':AtCtx G a P') :
ctxProj (tr (AtCtx G _) (atMBumpTEq b' xg a') (xa_a (atMBump xg (popCtx b' P)))) = elMBump xg a' (ctxProj b').
	apply extAtCtxInd with (xg := xg) (a := a');clear a G P' xg a'.

	revert P b'.
	destruct GL as (GL,?).
	intros.
	reflexivity.

	intros a ?.
	destruct G.
	simpl ctxTp.
	intros ? ? a' ? ?.
	simpl elMBump.
	apply (tr (fun t=>_ = fun g=>t (projT1 g)) H).
	simpl atMBumpTEq.
	refine (match atMBumpTEq b' xg a' as teq
		return ctxProj (tr (AtCtx (extCtx (ctx s) _) _) (tr _ teq _) _) =
			fun g=>ctxProj (tr _ teq _) (projT1 g)
		with eq_refl => _ end).
	clear P' a' H.
	simpl tr.
	reflexivity.
Defined.
Implicit Arguments ctxProj_MBump [GL a b P G P'].

End Context.


Require Import VST.progs.conclib.
Require Import VST.progs.ghosts.
Require Import RelationClasses.

Section ListMaps.

Context {A B : Type} {A_eq : EqDec A} {d : Inhabitant B}.

Definition map_Znth i (L : A -> option (list B)) k := option_map (fun v => Znth i v) (L k).

Lemma map_Znth_single : forall i (k : A) (v : list B),
  map_Znth i (singleton k v) = singleton k (Znth i v).
Proof.
  intros; unfold map_Znth, singleton; extensionality.
  if_tac; auto.
Qed.

Lemma map_Znth_add : forall (m1 m2 : A -> option (list B)) i,
  map_Znth i (map_add m1 m2) = map_add (map_Znth i m1) (map_Znth i m2).
Proof.
  intros; unfold map_add, map_Znth; extensionality.
  destruct (m1 x); auto.
Qed.

Lemma map_Znth_eq : forall (L : A -> option (list B)) k vs (Hlength : forall vs', L k = Some vs' -> Zlength vs' = Zlength vs)
  (Hnz : vs <> []) (Hall : forall i, 0 <= i < Zlength vs -> map_Znth i L k = Some (Znth i vs)),
  L k = Some vs.
Proof.
  intros.
  destruct (L k) eqn: Hk.
  specialize (Hlength _ eq_refl).
  apply f_equal, list_Znth_eq'; auto.
  rewrite Hlength; intros j Hj; specialize (Hall _ Hj).
  unfold map_Znth in Hall; rewrite Hk in Hall; inv Hall; auto.
  { lapply (Hall 0).
    unfold map_Znth; rewrite Hk; discriminate.
    { pose proof (Zlength_nonneg vs).
      destruct (eq_dec (Zlength vs) 0); [|omega].
      apply Zlength_nil_inv in e; subst; contradiction. } }
Qed.

Lemma map_Znth_upd : forall (m : A -> option (list B)) k v i,
  map_Znth i (map_upd m k v) = map_upd (map_Znth i m) k (Znth i v).
Proof.
  intros; unfold map_Znth, map_upd; extensionality.
  if_tac; auto.
Qed.

Lemma map_incl_Znth : forall (m1 m2 : A -> option (list B)) i, map_incl m1 m2 ->
  map_incl (map_Znth i m1) (map_Znth i m2).
Proof.
  unfold map_Znth; repeat intro.
  destruct (m1 k) eqn: Hm1; [|discriminate].
  rewrite (H _ _ Hm1); auto.
Qed.

End ListMaps.

Section Logs.
(* A log is a map from nat, and a finite log has a latest element. *)

Context {B : Type}.

Local Close Scope Z.

Definition log_latest s (v1 : nat) (v2 : B) := s v1 = Some v2 /\ forall v', v1 < v' -> s v' = None.

Lemma log_latest_singleton : forall v1 v2, log_latest (singleton v1 v2) v1 v2.
Proof.
  unfold singleton; split.
  - rewrite eq_dec_refl; auto.
  - intros; if_tac; auto; omega.
Qed.

Lemma log_incl_latest : forall k1 k2 v1 v2 log1 log2 (Hincl : map_incl log1 log2)
  (Hv1 : log1 k1 = Some v1) (Hlatest : log_latest log2 k2 v2), k1 <= k2.
Proof.
  intros.
  destruct (lt_dec k2 k1); [|omega].
  destruct Hlatest as (? & Hlatest).
  specialize (Hlatest _ l).
  specialize (Hincl _ _ Hv1); rewrite Hincl in Hlatest; discriminate.
Qed.

Lemma log_latest_upd : forall log v1 v2 v1' v2', log_latest log v1 v2 -> v1 < v1' ->
  map_incl log (map_upd log v1' v2') /\ log_latest (map_upd log v1' v2') v1' v2'.
Proof.
  intros; destruct H as (? & Hlast); unfold map_upd; split.
  - repeat intro; if_tac; auto.
    subst; rewrite (Hlast v1') in *; auto; discriminate.
  - split; [rewrite eq_dec_refl; auto|].
    intros v' ?; lapply (Hlast v'); [|omega].
    intro; if_tac; auto; omega.
Qed.

Lemma log_latest_inj : forall log v1 v2 v1' v2' (H1 : log_latest log v1 v2) (H1' : log_latest log v1' v2'),
  v1 = v1' /\ v2 = v2'.
Proof.
  intros.
  assert (log v1 = Some v2) as Hv1 by (apply H1).
  assert (log v1' = Some v2') as Hv1' by (apply H1').
  pose proof (log_incl_latest _ _ _ _ _ _ (map_incl_refl log) Hv1 H1').
  pose proof (log_incl_latest _ _ _ _ _ _ (map_incl_refl log) Hv1' H1).
  assert (v1 = v1') by omega; subst.
  destruct H1 as [H1 _], H1' as [H1' _].
  rewrite H1 in H1'; inv H1'; auto.
Qed.

Lemma log_latest_add : forall m1 m2 k1 k2 (v1 v2 : B)
  (Hlatest1 : log_latest m1 k1 v1) (Hlatest2 : log_latest m2 k2 v2),
  log_latest (map_add m1 m2) (max k1 k2) (if lt_dec k1 k2 then v2 else v1).
Proof.
  unfold log_latest, map_add; intros.
  destruct Hlatest1 as (Hv1 & Hk1), Hlatest2 as (Hv2 & Hk2).
  destruct (lt_dec k1 k2).
  - rewrite max_r by omega.
    rewrite Hk1 by auto; split; auto.
    intros; rewrite Hk1, Hk2; auto; omega.
  - rewrite max_l, Hv1 by omega; split; auto.
    intros; rewrite Hk1, Hk2; auto; omega.
Qed.

Lemma log_latest_upd_list : forall l (m : nat -> option B) k v k' v' (Hm : log_latest m k v)
  (Hlast : last l (k, v) = (k', v')) (Hlt : k <= k') (Hordered : Forall (fun '(k, v) => k <= k') l),
  log_latest (map_upd_list m l) k' v'.
Proof.
  intros.
  destruct (nil_dec l).
  { subst; inv Hlast; auto. }
  rewrite (app_removelast_last (k, v) n).
  rewrite map_upd_list_app; simpl.
  rewrite Hlast; split.
  - unfold map_upd; rewrite eq_dec_refl; auto.
  - intros; unfold map_upd.
    if_tac; [omega|].
    apply map_upd_list_out.
    + eapply Hm; omega.
    + rewrite in_map_iff; intros ((?, ?) & ? & ?); simpl in *; subst.
      rewrite Forall_forall in Hordered; exploit Hordered; [apply In_removelast; eauto|].
      simpl; omega.
Qed.

End Logs.

Lemma map_Znth_log_latest : forall {B} {d : Inhabitant B} m k (v : list B) i, log_latest m k v ->
  log_latest (map_Znth i m) k (Znth i v).
Proof.
  unfold log_latest, map_Znth; intros.
  destruct H as [-> H]; split; auto.
  intros; rewrite H; auto.
Qed.


Require Export P07.

Lemma makeblack_fiddle:
  forall s n, is_redblack s Black n ->
            exists n, is_redblack (makeBlack s) Red n.
Proof. exact FILL_IN_HERE. Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e336m3_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e251m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e336m3_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e413m21_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.