Require Import msl.base.
Require Import msl.ageable.
Require Import msl.sepalg.
Require Import msl.sepalg_generators.
Require Import msl.age_sepalg.
Require Import msl.predicates_hered.
Require Import msl.predicates_sl.

Local Open Scope pred.

Definition corable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
         (P: pred A) := forall w, P w = P (core w).

Lemma corable_spec: forall {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
  (P: pred A),
    corable P = forall x y:A, core x = core y -> P x -> P y.
Proof.
  unfold corable; intros; apply prop_ext; split; intros.
  + rewrite H in H1 |- *.
    rewrite <- H0.
    auto.
  + pose proof core_idem w.
    pose proof (H _ _ H0).
    pose proof (H _ _ (eq_sym H0)).
    apply prop_ext; split; auto.
Qed.

Lemma corable_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P && Q).
Proof.
 unfold corable; intros.
 apply prop_ext; split; intros [? ?]; split; congruence.
Qed.
Lemma corable_orp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P || Q).
Proof.
 unfold corable; intros.
 apply prop_ext; split; (intros [?|?]; [left|right]; congruence).
Qed.
Lemma corable_allp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall {B: Type} (P:  B -> pred A) ,
      (forall b, corable (P b)) -> corable (allp P).
Proof.
 unfold corable, allp; intros.
 apply prop_ext; split; simpl; intros.
 rewrite <- H; auto. rewrite H; auto.
Qed.
Lemma corable_exp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall {B: Type} (P:  B -> pred A) ,
      (forall b, corable (P b)) -> corable (exp P).
Proof.
 unfold corable, exp; intros.
 apply prop_ext; split; simpl; intros;  destruct H0 as [b ?]; exists b.
 rewrite <- H; auto. rewrite H; auto.
Qed.
Lemma corable_prop{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P, corable (prop P).
Proof.
 unfold corable, prop; intros.
 apply prop_ext; split; simpl; intros; auto.
Qed.

Lemma corable_imp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} {agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P --> Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold imp in *.
  simpl in *.
  intros.
  rename a' into y'.
  pose proof H3.
  apply necR_power_age in H5.
  destruct H5 as [n ?H].
  destruct (power_age_parallel' _ y' _ n (eq_sym H1) H5) as [x' [?H ?H]].
  apply (H0 _ _ (eq_sym H7)).
  apply H2.
  + apply necR_power_age; exists n; auto.
  + apply (H _ _ H7); auto.
Qed.

Lemma corable_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P * Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold sepcon.
  intros.
  simpl in H2 |- *.
  destruct H2 as [x' [x'' [? [? ?]]]].
  pose proof join_core H2.
  pose proof join_core (join_comm H2).
  exists (core y), y.
  repeat split.
  + apply core_unit.
  + apply H with x'; auto.
    rewrite core_idem.
    congruence.
  + apply H0 with x''; auto.
    congruence.
Qed.

Lemma corable_wand: forall {A:Type} {agA:ageable A} {JA: Join A} {PA: Perm_alg A} {SaA: Sep_alg A} {XA: Age_alg A} (P Q: pred A), corable P -> corable Q -> corable (P -* Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold wand in *.
  simpl in *.
  intros.
  rename x' into y'.
  rename y0 into w'.
  rename z into z'.
  apply necR_power_age in H3.
  destruct H3 as [n ?H].
  pose proof power_age_parallel' _ y' _ n (eq_sym H1) H3.
  destruct H6 as [x' [?H ?H]].
  pose proof join_core H4.
  pose proof join_core (join_comm H4).
  apply H0 with x'; [congruence |].
  apply (H2  x' (core x') x').
  + apply necR_power_age.
    exists n; auto.
  + apply join_comm, core_unit.
  + apply H with w'; auto.
    rewrite core_idem.
    congruence.
Qed.

Lemma corable_later: forall {A:Type} {agA:ageable A} {JA: Join A} {PA: Perm_alg A} {SaA: Sep_alg A} {XA: Age_alg A} P, corable P -> corable (|> P).
Proof.
  intros.
  rewrite corable_spec in H |- *.
  intros.
  unfold box in *.
  simpl in *.
  intros.
  apply laterR_power_age in H2.
  destruct H2 as [n ?H].
  rename a' into y'.
  destruct (power_age_parallel' _ y' _ _ (eq_sym H0) H2) as [x' [? ?]].
  apply H with x'; auto.
  apply H1.
  apply laterR_power_age.
  exists n; auto.
Qed.

Hint Resolve @corable_andp @corable_orp @corable_allp @corable_exp
                    @corable_imp @corable_prop @corable_sepcon @corable_wand @corable_later.

Lemma corable_andp_sepcon1{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  (P && Q) * R = P && (Q * R).
Proof.
intros.
apply pred_ext.
intros w [w1 [w2 [? [[? ?] ?]]]].
split.
apply join_core in H0.
rewrite H in H1|-*. rewrite <- H0; auto.
exists w1; exists w2; split; [| split]; auto.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; [|split]; auto.
split; auto.
apply join_core in H1.
rewrite H in H0|-*. rewrite H1; auto.
Qed.

(* The following 3 lemmas should not be necessary *)
Lemma corable_andp_sepcon2{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  (Q && P) * R = P && (Q * R).
Proof.
intros. rewrite andp_comm. apply corable_andp_sepcon1. auto.
Qed.

Lemma corable_sepcon_andp1 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  Q  * (P && R) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

Lemma corable_sepcon_andp2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  Q  * (R && P) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite andp_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

(* This hint doesn't work well, hence the extra clauses in normalize1 and normalize1_in *)
Hint Rewrite @corable_andp_sepcon1 @corable_andp_sepcon2
                    @corable_sepcon_andp1 @corable_sepcon_andp2 using solve [auto with normalize typeclass_instances].


(**************************************************************************
* 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.

Ltac trace_goal := idtac.
(*
  match goal with
  | |- ?g => idtac g
  end.
*)

(* ********************************************************************** *)
(** * 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 _) => (* idtac "(_ #p _)";*) trace_goal; 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 _ _ _) => (* idtac "(freshp _ _ _)";*) trace_goal; 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)) => (* idtac "(okp (?E &p ?G))";*) trace_goal;
  match goal with H: okp (E &p ?F &p G) |- _ =>
    apply (okp_remove H) end.

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

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

Hint Extern 1 (okp (?E)) => (* idtac "(okp (?E))";*) trace_goal;
  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 Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Datatypes.PropSet.
Require Import Coq.Lists.List. (* after SeparationLogic *)
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.DestructHead.

(* for [eauto with lia] *)
Require Import Crypto.Util.ZUtil.Hints.Core.

Import API.Compilers.
Import ListNotations Types.Notations.

Section UsedVarnames.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.
  Local Existing Instance Types.rep.Z.
  Local Instance varname_eqb_spec x y : BoolSpec _ _ _
    := Decidable.String.eqb_spec x y.
  Local Notation varname := String.string.

  Definition used_varnames nextn nvars : set varname :=
    of_list (map varname_gen (seq nextn nvars)).

  Lemma used_varnames_iff nextn nvars v :
    used_varnames nextn nvars v <->
    (exists n,
        v = varname_gen n /\ nextn <= n < nextn + nvars)%nat.
  Proof.
    cbv [used_varnames of_list]. revert nextn v.
    induction nvars; intros; cbn [seq map In];
      [ split; try tauto; intros; cleanup; lia | ].
    rewrite IHnvars.
    split; intros;
      repeat match goal with
             | _ => progress cleanup
             | _ => progress subst
             | H : _ \/ _ |- _ => destruct H
             | |- exists _, _ => eexists; solve [eauto with lia]
             end; [ ].
    match goal with H : _ <= _ |- _ =>
                    apply le_lt_or_eq in H; destruct H; [right | left]
    end.
    { eexists; eauto with lia. }
    { congruence. }
  Qed.

  Lemma used_varnames_disjoint n1 n2 l1 l2 :
    n1 + l1 <= n2 ->
    disjoint (used_varnames n1 l1) (used_varnames n2 l2).
  Proof.
    cbv [used_varnames].
    revert n1 n2 l2; induction l1; cbn [map seq]; intros;
      rewrite ?of_list_nil, ?of_list_cons;
      eauto using disjoint_empty_l.
    rewrite add_union_singleton.
    apply disjoint_union_l_iff; split; eauto with lia; [ ].
    apply disjoint_not_in. intro.
    repeat match goal with
           | _ => progress cleanup
           | H : In _ (map _ _) |- _ => rewrite in_map_iff in H
           | H : In _ (seq _ _) |- _ => rewrite in_seq in H
           | H : varname_gen _ = varname_gen _ |- _ =>
             apply varname_gen_unique in H
           | _ => lia
           end.
  Qed.

  Lemma used_varnames_succ_high n l :
    sameset (used_varnames n (S l))
            (add (used_varnames n l) (varname_gen (n + l))).
  Proof.
    intros. cbv [used_varnames].
    rewrite seq_snoc, map_app. cbn [map].
    rewrite of_list_app, of_list_cons.
    rewrite !add_union_singleton, of_list_nil, union_empty_r.
    apply union_comm.
  Qed.

  Lemma used_varnames_succ_low n m :
    PropSet.sameset (used_varnames n (S m))
                    (PropSet.add (used_varnames (S n) m)
                                 (varname_gen n)).
  Proof.
    apply sameset_iff. cbn. firstorder idtac.
  Qed.

  Lemma used_varnames_1 n :
    PropSet.sameset (used_varnames n 1)
                    (PropSet.singleton_set (varname_gen n)).
  Proof.
    apply sameset_iff. cbn. firstorder idtac.
  Qed.

  Lemma used_varnames_subset n1 n2 l1 l2 :
    (n2 <= n1)%nat ->
    (n1 + l1 <= n2 + l2)%nat ->
    PropSet.subset (used_varnames n1 l1)
                   (used_varnames n2 l2).
  Proof.
    cbv [PropSet.subset PropSet.elem_of];
      intros; rewrite !used_varnames_iff in *.
    cleanup; subst.
    eexists; split; [ reflexivity | lia ].
  Qed.

  Lemma used_varnames_union n m l :
    sameset (used_varnames n (m + l))
            (union (used_varnames n m) (used_varnames (n + m) l)).
  Proof.
    cbv [used_varnames].
    revert n m; induction l; cbn [map seq]; intros;
      rewrite ?Nat.add_0_r, ?of_list_nil, ?union_empty_r;
      try reflexivity; [ ].
    rewrite of_list_cons, add_union_singleton, union_assoc.
    rewrite <-Nat.add_succ_comm. rewrite IHl.
    rewrite seq_snoc, map_app. cbn [map].
    rewrite of_list_app, of_list_cons.
    rewrite !add_union_singleton, of_list_nil, union_empty_r.
    rewrite Nat.add_succ_r.
    reflexivity.
  Qed.

  Lemma used_varnames_shift n m l :
    subset (used_varnames (n + m) l)
           (used_varnames n (m + l)).
  Proof.
    cbv [subset]. intros.
    match goal with H : _ |- _ =>
                    apply used_varnames_iff in H end.
    apply used_varnames_iff.
    cleanup; subst. eexists; split; eauto.
    lia.
  Qed.

  Lemma used_varnames_subset_singleton n m l :
    n <= m < n + l ->
    subset (singleton_set (varname_gen m))
           (used_varnames n l).
  Proof.
    cbv [subset singleton_set elem_of]. intros.
    apply used_varnames_iff; subst.
    eexists; split; eauto; lia.
  Qed.

  Implicit Types l : locals.

  Lemma only_differ_zero nextn l :
    map.only_differ l (used_varnames nextn 0) l.
  Proof.
    cbv [map.only_differ used_varnames of_list elem_of].
    tauto.
  Qed.

  Lemma only_differ_succ nextn nvars l1 l2 v :
    map.only_differ (map.put l1 (varname_gen nextn) v)
                    (used_varnames (S nextn) nvars) l2 ->
    map.only_differ l1 (used_varnames nextn (S nvars)) l2.
  Proof.
    intros.
    eapply Proper_only_differ;
      [ reflexivity | | reflexivity | eapply only_differ_trans;
         solve [eauto using @only_differ_sym, @only_differ_put with typeclass_instances ] ].
    eapply sameset_iff; intros.
    cbv [used_varnames of_list elem_of union singleton_set].
    cbn [seq map In].
    tauto.
  Qed.

  Lemma only_differ_step nvars nvars' nextn l1 l2 l3 :
    map.only_differ l1 (used_varnames nextn nvars) l2 ->
    map.only_differ l2 (used_varnames (nextn + nvars) nvars') l3 ->
    map.only_differ l1 (used_varnames nextn (nvars + nvars')) l3.
  Proof.
    cbv [map.only_differ used_varnames of_list
                         elem_of].
    let H1 := fresh in
    let H2 := fresh in
    let x := fresh "x" in
    intros H1 H2 x; specialize (H1 x); specialize (H2 x).
    repeat match goal with
           | _ => progress cleanup
           | _ => progress subst
           | H : _ \/ _ |- _ => destruct H
           | |- context [In _ (map _ _)] => rewrite in_map_iff
           | H : In _ (map _ _) |- _ => apply in_map_iff in H
           | H : In _ (seq _ _) |- _ => apply in_seq in H
           | H : varname_gen _ = varname_gen _ |- _ =>
             apply varname_gen_unique in H
           | _ => solve [right; congruence]
           | _ => solve [left; eexists;
                         rewrite in_seq, varname_gen_unique; split;
                         eauto with lia ]
           end.
  Qed.

  Lemma disjoint_used_varnames_lt n nvars (vset : set varname) :
    (forall x, n <= x -> ~ vset (varname_gen x)) ->
    disjoint (used_varnames n nvars) vset.
  Proof.
    cbv [disjoint elem_of]; intros.
    apply Decidable.imp_simp.
    { cbv [used_varnames Decidable.decidable of_list ].
      match goal with
        |- In ?x ?l \/ ~ In ?x ?l =>
        destruct (in_dec string_dec x l); [left|right]
      end; tauto. }
    rewrite used_varnames_iff.
    intros; cleanup; subst.
    eauto with lia.
  Qed.

  Lemma disjoint_used_varnames_singleton n nvars m :
    m < n ->
    disjoint (used_varnames n nvars)
             (singleton_set (varname_gen m)).
  Proof.
    cbv [singleton_set elem_of]; intros.
    eapply disjoint_used_varnames_lt. intros.
    rewrite varname_gen_unique. lia.
  Qed.
End UsedVarnames.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.

Import HaskellListNotations.
Open Scope string.

Definition whole_prog := [(NonRecursive (Decl (0,"demote") DPrim)),(NonRecursive (Decl (1,"+") DPrim)),(NonRecursive (Decl (2,"-") DPrim)),(NonRecursive (Decl (3,"*") DPrim)),(NonRecursive (Decl (4,"/") DPrim)),(NonRecursive (Decl (5,"%") DPrim)),(NonRecursive (Decl (6,"^^") DPrim)),(NonRecursive (Decl (7,"lg2") DPrim)),(NonRecursive (Decl (9,"True") DPrim)),(NonRecursive (Decl (10,"False") DPrim)),(NonRecursive (Decl (11,"negate") DPrim)),(NonRecursive (Decl (12,"complement") DPrim)),(NonRecursive (Decl (13,"<") DPrim)),(NonRecursive (Decl (14,">") DPrim)),(NonRecursive (Decl (15,"<=") DPrim)),(NonRecursive (Decl (16,">=") DPrim)),(NonRecursive (Decl (17,"==") DPrim)),(NonRecursive (Decl (18,"!=") DPrim)),(NonRecursive (Decl (19,"===") (DExpr (ETAbs (87,"a") (ETAbs (88,"b") (EAbs (89,"f") (EAbs (90,"g") (EAbs (91,"x") (EApp (EApp (ETApp (EVar (17,"==")) (TVar (TVBound 31 KType))) (EApp (EVar (89,"f")) (EVar (91,"x")))) (EApp (EVar (90,"g")) (EVar (91,"x")))))))))))),(NonRecursive (Decl (20,"!==") (DExpr (ETAbs (92,"a") (ETAbs (93,"b") (EAbs (94,"f") (EAbs (95,"g") (EAbs (96,"x") (EApp (EApp (ETApp (EVar (18,"!=")) (TVar (TVBound 41 KType))) (EApp (EVar (94,"f")) (EVar (96,"x")))) (EApp (EVar (95,"g")) (EVar (96,"x")))))))))))),(NonRecursive (Decl (21,"min") (DExpr (ETAbs (97,"a") (EAbs (98,"x") (EAbs (99,"y") (EIf (EApp (EApp (ETApp (EVar (13,"<")) (TVar (TVBound 50 KType))) (EVar (98,"x"))) (EVar (99,"y"))) (EVar (98,"x")) (EVar (99,"y"))))))))),(NonRecursive (Decl (22,"max") (DExpr (ETAbs (100,"a") (EAbs (101,"x") (EAbs (102,"y") (EIf (EApp (EApp (ETApp (EVar (14,">")) (TVar (TVBound 56 KType))) (EVar (101,"x"))) (EVar (102,"y"))) (EVar (101,"x")) (EVar (102,"y"))))))))),(NonRecursive (Decl (23,"/\\") (DExpr (EAbs (103,"x") (EAbs (104,"y") (EIf (EVar (103,"x")) (EVar (104,"y")) (EVar (10,"False")))))))),(NonRecursive (Decl (24,"\\/") (DExpr (EAbs (105,"x") (EAbs (106,"y") (EIf (EVar (105,"x")) (EVar (9,"True")) (EVar (106,"y")))))))),(NonRecursive (Decl (25,"==>") (DExpr (EAbs (107,"a") (EAbs (108,"b") (EIf (EVar (107,"a")) (EVar (108,"b")) (EVar (9,"True")))))))),(NonRecursive (Decl (26,"&&") DPrim)),(NonRecursive (Decl (27,"||") DPrim)),(NonRecursive (Decl (28,"^") DPrim)),(NonRecursive (Decl (29,"zero") DPrim)),(NonRecursive (Decl (30,"<<") DPrim)),(NonRecursive (Decl (31,">>") DPrim)),(NonRecursive (Decl (32,"<<<") DPrim)),(NonRecursive (Decl (33,">>>") DPrim)),(NonRecursive (Decl (34,"#") DPrim)),(NonRecursive (Decl (35,"splitAt") DPrim)),(NonRecursive (Decl (36,"join") DPrim)),(NonRecursive (Decl (37,"split") DPrim)),(NonRecursive (Decl (38,"reverse") DPrim)),(NonRecursive (Decl (39,"transpose") DPrim)),(NonRecursive (Decl (40,"@") DPrim)),(NonRecursive (Decl (41,"@@") DPrim)),(NonRecursive (Decl (42,"!") DPrim)),(NonRecursive (Decl (43,"!!") DPrim)),(NonRecursive (Decl (44,"update") DPrim)),(NonRecursive (Decl (45,"updateEnd") DPrim)),(NonRecursive (Decl (46,"updates") (DExpr (ETAbs (162,"a") (ETAbs (163,"b") (ETAbs (164,"c") (ETAbs (165,"d") (EAbs (166,"xs0") (EAbs (167,"idxs") (EAbs (168,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 124 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (169,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (169,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 124 KNum))) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (EList [(EVar (166,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (44,"update")) (TVar (TVBound 121 KNum))) (TVar (TVBound 122 KType))) (TVar (TVBound 123 KNum))) (EVar (170,"xs"))) (EVar (171,"i"))) (EVar (172,"b"))) [[(From (170,"xs") (EVar (169,"xss")))],[(From (171,"i") (EVar (167,"idxs")))],[(From (172,"b") (EVar (168,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (47,"updatesEnd") (DExpr (ETAbs (173,"a") (ETAbs (174,"b") (ETAbs (175,"c") (ETAbs (176,"d") (EAbs (177,"xs0") (EAbs (178,"idxs") (EAbs (179,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 159 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (180,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (180,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 159 KNum))) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (EList [(EVar (177,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (45,"updateEnd")) (TVar (TVBound 156 KNum))) (TVar (TVBound 157 KType))) (TVar (TVBound 158 KNum))) (EVar (181,"xs"))) (EVar (182,"i"))) (EVar (183,"b"))) [[(From (181,"xs") (EVar (180,"xss")))],[(From (182,"i") (EVar (178,"idxs")))],[(From (183,"b") (EVar (179,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (48,"fromThen") DPrim)),(NonRecursive (Decl (49,"fromTo") DPrim)),(NonRecursive (Decl (50,"fromThenTo") DPrim)),(NonRecursive (Decl (51,"infFrom") DPrim)),(NonRecursive (Decl (52,"infFromThen") DPrim)),(NonRecursive (Decl (53,"error") DPrim)),(NonRecursive (Decl (54,"pmult") DPrim)),(NonRecursive (Decl (55,"pdiv") DPrim)),(NonRecursive (Decl (56,"pmod") DPrim)),(NonRecursive (Decl (57,"random") DPrim)),(NonRecursive (Decl (61,"take") (DExpr (ETAbs (209,"front") (ETAbs (210,"back") (ETAbs (211,"elem") (EAbs (212,"__p1") (EWhere (EVar (214,"x")) [(NonRecursive (Decl (213,"__p2") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (TVar (TVBound 214 KNum))) (TVar (TVBound 215 KNum))) (TVar (TVBound 216 KType))) (EVar (212,"__p1")))))),(NonRecursive (Decl (214,"x") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 0))))),(NonRecursive (Decl (215,"__p0") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (62,"drop") (DExpr (ETAbs (216,"front") (ETAbs (217,"back") (ETAbs (218,"elem") (EAbs (219,"__p4") (EWhere (EVar (222,"y")) [(NonRecursive (Decl (220,"__p5") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (TVar (TVBound 231 KNum))) (TVar (TVBound 232 KNum))) (TVar (TVBound 233 KType))) (EVar (219,"__p4")))))),(NonRecursive (Decl (221,"__p3") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 0))))),(NonRecursive (Decl (222,"y") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (63,"tail") (DExpr (ETAbs (223,"a") (ETAbs (224,"b") (EAbs (225,"xs") (EApp (ETApp (ETApp (ETApp (EVar (62,"drop")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 249 KNum))) (TVar (TVBound 250 KType))) (EVar (225,"xs"))))))))),(NonRecursive (Decl (64,"width") (DExpr (ETAbs (226,"bits") (ETAbs (227,"len") (ETAbs (228,"elem") (EAbs (229,"__p6") (ETApp (ETApp (EVar (0,"demote")) (TVar (TVBound 256 KNum))) (TVar (TVBound 255 KNum)))))))))),(NonRecursive (Decl (65,"undefined") (DExpr (ETAbs (230,"a") (EApp (ETApp (ETApp (EVar (53,"error")) (TVar (TVBound 260 KType))) (TCon (TC (TCNum 9)) [])) (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 117)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 102)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 105)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) []))])))))),(NonRecursive (Decl (66,"groupBy") (DExpr (ETAbs (231,"each") (ETAbs (232,"parts") (ETAbs (233,"elem") (ETApp (ETApp (ETApp (EVar (37,"split")) (TVar (TVBound 266 KNum))) (TVar (TVBound 265 KNum))) (TVar (TVBound 267 KType))))))))),(NonRecursive (Decl (68,"trace") DPrim)),(NonRecursive (Decl (69,"traceVal") (DExpr (ETAbs (238,"n") (ETAbs (239,"a") (EAbs (240,"msg") (EAbs (241,"x") (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (68,"trace")) (TVar (TVBound 273 KNum))) (TVar (TVBound 274 KType))) (TVar (TVBound 274 KType))) (EVar (240,"msg"))) (EVar (241,"x"))) (EVar (241,"x")))))))))),(NonRecursive (Decl (242,"x") (DExpr (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 3)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 4)) [])) (TCon (TC (TCNum 8)) []))])))),(NonRecursive (Decl (243,"y") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (37,"split")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (EVar (242,"x")))))),(NonRecursive (Decl (244,"a") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 0)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 0)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))))),(NonRecursive (Decl (245,"b") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 1)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 0)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) [])))))),(NonRecursive (Decl (246,"c") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 0)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 1)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))))),(NonRecursive (Decl (247,"d") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 1)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 1)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) []))))))].

Definition ge := bind_decl_groups whole_prog gempty.

Definition a := EVar (244,"a").
Definition b := EVar (245,"b").
Definition c := EVar (246,"c").
Definition d := EVar (247,"d").

Definition v (z : Z) := @repr 8 z.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

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


Require Import ZArith.
Require Import interface_tyc2.

Require Import Logic.SeparationLogic.Sound.Sound_Flat.
Require Import Logic.SeparationLogic.ShallowEmbedded.PredicateSeparationLogic.

Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.

Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfJudgement.

Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfIteratedConnectives.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfClassicalAxioms.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.

Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.

Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfCancel.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.ProofTheory.IterSepcon.
Require Import Logic.SeparationLogic.ProofTheory.Corable.
Require Import Logic.SeparationLogic.ProofTheory.Deduction.

Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.PropositionalLogic.ShallowEmbedded.PredicatePropositionalLogic.

Require Import Logic.SeparationLogic.Model.OSAExamples.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.

Definition var : Type := nat.

Definition store : Type := var -> Z.

Definition addr : Type := Z.

Definition heap : Type := Heap addr Z.

Definition state : Type := store * heap.

(* Definition join_heap : heap -> heap -> heap -> Prop :=
  fun h1 h2 h3 =>
    forall p : Z,
      (exists v, h1 p = Some v /\ h2 p = None /\ h3 p = Some v) \/
      (exists v, h1 p = None /\ h2 p = Some v /\ h3 p = Some v) \/
      (h1 p = None /\ h2 p = None /\ h3 p = None).

Definition join : state -> state -> state -> Prop :=
  fun st1 st2 st3 => fst st1 = fst st2 /\ fst st2 = fst st3 /\ join_heap (snd st1) (snd st2) (snd st3).

Definition SepCon (e1 e2 : state -> Prop) : state -> Prop :=
  fun st => exists st1 st2, join st1 st2 st /\ e1 st1 /\ e2 st2. *)

(* Definition jjoin (x y : nat -> option Z) : nat -> option Z :=
  fun p => match x p, y p with
    | Some n1, Some n2 => None
    | Some n1, None => Some n1
    | None, Some n2 => Some n2
    | None, None => None
  end. *)

Instance stateR : KripkeModel.KI.Relation (state) := fun x y => x = y.

Instance store_join : Join store := equiv_Join.

Instance heap_join : Join heap := Heap_Join addr Z.

Instance stateJoin : Join state := prod_Join store heap.

Instance stateJ : SeparationAlgebra.Join (state) := stateJoin.

Instance storeSA : SeparationAlgebra store := equiv_SA.

Instance heapSA : SeparationAlgebra heap := Heap_SA addr Z.

Instance stateSA : SeparationAlgebra state := prod_SA store heap.

Module NaiveLang <: LanguageSig.
  Definition expr := state -> Prop.
  Section NaiveLang.
    Definition context := expr -> Prop.
    Definition provable (e : expr) : Prop := forall st, e st.
    Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
    Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
    Definition sepcon := WeakSemantics.sepcon.
    Definition falsep : expr := fun st => False.
    Definition emp : expr := fun st => forall p, (snd st) p = None.
  End NaiveLang.
End NaiveLang.

Module NaiveRule.
Include DerivedNames (NaiveLang).

Instance L : Language := (Build_Language expr) .
Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
Instance falsepL : (FalseLanguage L) := (Build_FalseLanguage L falsep) .

Lemma falsep_sepcon_impp : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
Proof.
  unfold provable, impp, sepcon, falsep. intros.
  destruct H as [st1 [st2 ?]]. tauto.
Qed.

Lemma sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
Proof.
  intros x y.
  exact (@sound_sepcon_comm L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y).
Qed.

Lemma sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
Proof.
  intros x y z.
  exact (@sound_sepcon_assoc1 L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y z).
Qed.

Lemma sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
Proof.
  unfold provable, impp, sepcon.
  intros.
  destruct H1 as [st1 [st2 ?]].
  exists st1, st2.
  split; try tauto.
  specialize (H st1). specialize (H0 st2).
  tauto.
Qed.

Lemma andp_intros : (forall x y : expr, provable (impp x (impp y (andp x y)))) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma andp_elim1 : (forall x y : expr, provable (impp (andp x y) x)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma andp_elim2 : (forall x y : expr, provable (impp (andp x y) y)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma modus_ponens : (forall x y : expr, provable (impp x y) -> provable x -> provable y) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma axiom1 : (forall x y : expr, provable (impp x (impp y x))) .
Proof.
  unfold provable, impp. auto.
Qed.

Lemma axiom2 : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z)))) .
Proof.
  unfold provable, impp. auto.
Qed.

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
(*Module Solver := IPSolver NaiveLang.*)
Import T.


Require Import ExtLib.Data.Stream.
Require Import ExtLib.Structures.MonadState.
Require Import QArith.Qcanon.
Require Import QArith_base.
Require Import Coq.Lists.List.
Require Import ExtLib.Data.Vector.
Require Import ExtLib.Structures.Functor.

Require Import BinNums.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Data.Monads.IdentityMonad.
Require Import ExtLib.Data.Monads.StateMonad.

Require Import Markov.Random.

(** Following the semantics of Huang and Morrisett:
 **  [An application of computable distributions to the semantics of
 **   probabilistic programming languages]
 **)
Definition PD (T : Type) : Type := state Bits T.
Global Instance Monad_PD : Monad PD := Monad_state _.

(*
(**
 ** A sampler for biased coin flips
 ** NOTE: This sampler is not correct for rationals that are not [x/2^n]
 **)
Local Fixpoint get_precision (n : positive) : positive :=
  match n with
  | q~1 => Psucc (get_precision q)
  | q~0 => Psucc (get_precision q)
  | 1 => 1
  end%positive.

Local Fixpoint Q_to_precision' (n : positive) (b : Bits) (acc : N)
      {T} (k : N -> Bits -> T) : T :=
  match n with
  | xH => match b with
          | Bit Int32.D1 b' => k (2 * acc + 1)%N b'
          | Bit Int32.D0 b' => k (2 * acc)%N b'
          end
  | xO n => Q_to_precision' n b acc (fun acc b => Q_to_precision' n b acc k)
  | xI n => match b with
            | Bit c b' =>
              let acc' := (if c then 2 * acc + 1 else 2 * acc)%N in
              Q_to_precision' n b' acc' (fun acc b => Q_to_precision' n b acc k)
            end
  end.

Local Definition Q_to_precision (prec : positive) (b : Bits) : Q * Bits :=
  Q_to_precision' prec b 0%N
                  (fun n b => ({| Qnum := Z_of_N n
                                ; Qden := pow_pos Pmult 2%positive prec |} , b)).

Definition flip (q : Q) : PD bool :=
  {| runState := fun b =>
                   match Qcompare q 0 with
                   | Lt => (true, b)
                   | _ => match Qcompare 1 q with
                          | Lt => (false, b)
                          | _ =>
                            let prec := get_precision q.(Qden) in
                            let (q', b') := Q_to_precision prec b in
                            (match Qcompare q' q with
                             | Lt | Eq => true
                             | Gt => false
                             end, b')
                          end
                   end |}.
*)

(**
 ** A fair coin flip
 **)
Definition fair_coin : PD bool :=
  {| runState := fun b =>
                   match b with
                   | Bit x b =>
                     (match x with
                      | Int32.D0 => false
                      | Int32.D1 => true
                      end, b)
                   end |}.

(*
(**
 ** Random from Range
 **)
Fixpoint from_range (low count : nat) : PD nat :=
  match count with
  | 0 => ret low
  | S n =>
    bind (flip {| Qnum := 1%Z ; Qden := Pos.of_succ_nat n |})
         (fun x => if x then ret low
                   else from_range (S low) n)
  end%nat.
*)

(*
Definition digits (n : nat) : PD (vector Int32.digits n) :=
{| runState := fun b => takeBits n b (fun a b => (b, a)) |}.
*)

Section sample.
  Context {T : Type} (c : PD T).
  Local Instance MonadState_state : MonadState Bits PD := MonadState_state _.

  Let comp : PD T :=
    bind (mkState take_int32) (fun z1 =>
    bind (mkState take_int32) (fun z2 =>
    bind (mkState take_int32) (fun z3 =>
    bind (mkState take_int32) (fun z4 =>
    bind (MonadState.put (lfsr113_gen z1 z2 z3 z4))
         (fun _ => c))))).

  CoFixpoint sample (s : Bits)
  : stream T :=
    scons (evalState comp s)
          (sample (@takeBits 17 s _ (fun x _ => x))).
End sample.

(** TODO(gmalecha): To ExtLib **)
Section stream_take.
  Context {T : Type}.

  Fixpoint take (n : nat) (s : stream T) : list T :=
    match n with
    | Datatypes.O => nil
    | Datatypes.S n => match s with
                       | scons v s => v :: take n s
                       | snil => nil
                       end
    end.
End stream_take.

Require Import ExtLib.Core.RelDec.

Section sample_discrete.
  Context {T : Type} {r : RelDec (@eq T)}.

  Require Import ExtLib.Data.Map.FMapAList.

  Definition increment (k : T) (ls : alist T positive) : alist T positive :=
    match alist_find _ k ls with
    | None => alist_add _ k 1%positive ls
    | Some x => alist_add _ k (Pos.succ x) ls
    end.

  Definition sample_discrete (n : nat) (c : PD T) : alist T Q :=
    fmap (fun x => this (Q2Qc {| Qnum := Zpos x ; Qden := Pos.of_nat n |}))
         (List.fold_left (fun d r => increment r d) (take n (sample c lfsr113))
                         nil).
End sample_discrete.

Require Export ExtLib.Structures.Monad.


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

(***
Modulus : 2^130 - 5
Base: 26
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 26;
    bitwidth := 32;
    s := 2^130;
    c := [(1, 5)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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