Require Import
  Coq.Program.Program
  Coq.Program.Tactics
  Coq.Lists.List.

Require Export
  Freer
  Union.

Import ListNotations.

Generalizable All Variables.

Inductive FindElem (t : Type -> Type) : list (Type -> Type) -> Type :=
  | Here : forall xs, FindElem t (t :: xs)
  | Next : forall t' xs, FindElem t xs -> FindElem t (t' :: xs).

Class Member (t : Type -> Type) (r : list (Type -> Type)) := {
  inj : forall v, t v -> Union r v;
  prj : forall v, Union r v -> option (t v);
  hasElem : FindElem t r
}.

Arguments inj {t r _ v} _.
Arguments prj {t r _ v} _.

Program Instance Member_Here (t : Type -> Type) (r : list (Type -> Type)) :
  Member t (t :: r) | 1 := {
  inj := fun _ x => UThis x;
  prj := fun _ u =>
    match decomp u with
    | inl x => Some x
    | inr _ => None
    end;
  hasElem := Here _ _
}.

Program Instance Member_Next (t t' : Type -> Type) (r : list (Type -> Type)) :
  Member t r -> Member t (t' :: r) | 2 := {
  inj := fun _ x => UThat (inj x);
  prj := fun _ u =>
    match decomp u with
    | inl _ => None
    | inr u => prj u
    end;
  hasElem := Next _ _ _ hasElem
}.

Fixpoint FindElem_last  (t : Type -> Type) (r : list (Type -> Type)) :
  FindElem t (r ++ [t]) :=
  match r with
  | [] => Here _ _
  | _ :: xs => Next _ _ _ (FindElem_last t xs)
  end.

Program Instance Member_Last (t : Type -> Type) (r : list (Type -> Type)) :
  Member t (r ++ [t]) | 2 := {
  inj := fun _ x => inject_last t r x;
  prj := fun _ u =>
    match decomp_rev u with
    | inl _ => None
    | inr x => Some x
    end;
  hasElem := FindElem_last t r
}.

Fixpoint injF `{Member eff r} `(f : Freer eff a) : Freer (Union r) a :=
  match f with
  | Pure v => Pure v
  | Impure f k => Impure (inj f) (fun x => injF (k x))
  end.


Require Import Morphisms.

Set Implicit Arguments.

Section relations.
Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).

Definition Spec : Type := cfg -> (cfg -> Prop) -> Prop.
Definition subspec (A B:Spec) : Prop := forall k P, A k P -> B k P.
Definition mono (F : Spec -> Spec) : Prop := Proper (subspec ==> subspec) F.
Definition ho_mono (F : (Spec -> Spec) -> (Spec -> Spec)) : Prop
  := Proper ((subspec ==> subspec) ==> (subspec ==> subspec)) F.

(* t : Spec -> Spec *)
Inductive t (b : Spec -> Spec) (X : Spec) : Spec :=
| t_def : forall Y, mono Y -> (forall A, subspec (Y (b A)) (b (Y A)))
                    -> subspec (Y X) (t b X).

Lemma t_mono : forall b, mono (t b).
Proof. destruct 2. econstructor. eauto. eauto. revert H2. apply H0. assumption. Qed.

Lemma t_base : forall X b, mono b -> subspec (b X) (t b X).
Proof.
  unfold subspec;intros. eapply t_def with (b:=b).
  eassumption. firstorder. assumption.
Qed.

Lemma t_id : forall (X:Spec) (b:Spec -> Spec), subspec X (t b X).
Proof.
  unfold subspec;intros.
  eapply t_def with (Y := fun X => X) (b := b). unfold mono. firstorder. firstorder. trivial.
Qed.

Lemma t_compat : forall (X:Spec) b, mono b -> subspec (t b (b X)) (b (t b X)).
Proof. unfold subspec. intros. destruct H0. eapply H1 in H2.
       revert H2. apply H. eapply t_def;eauto. Qed.

Lemma t_idem : forall X b, mono b -> subspec (t b (t b X)) (t b X).
Proof. unfold subspec. intros. apply t_def with (fun X => t b (t b X)).
       intro. intros;intro;intros. revert H2. apply t_mono.
       intros;intro;intros. revert H2. apply t_mono. trivial.
       intros. intro. intros. apply t_compat. assumption.
       revert H1. eapply t_mono. apply t_compat. assumption.
       assumption.
Qed.

Lemma t_ext : forall Rules b,
    mono b -> subspec Rules (b (t b Rules)) -> subspec (t b Rules) (b (t b Rules)).
Proof. intros. unfold subspec. intros. apply (t_mono H0) in H1. apply t_compat in H1.
       revert H1. eapply H. apply t_idem. assumption. assumption. Qed.

Lemma t_rule : forall (F : Spec -> Spec) b, mono F -> mono b ->
                  (forall X, subspec (F X) (t b X)) ->
                  forall A, subspec (F (t b A)) (t b A).
Proof. intros. unfold subspec;intros. eapply t_idem. apply H0. revert H2. apply H1. Qed.

(* A higher order function so F <= Step F exactly when F is compatible, i.e. F o step <= step o F
   Thus t is the greatest fixpoint of B
 *)

Inductive B (b : Spec -> Spec) (F : Spec -> Spec) (X : Spec) k (P:cfg -> Prop) : Prop :=
| B_def : forall G, mono G
                       -> (forall A, subspec (G (b A)) (b (F A)))
                       -> G X k P -> B b F X k P.
(* T is related to Step as t is related to step.
   F <= B (T F) implies F <= t
 *)
Inductive T (b : Spec -> Spec) (F: Spec -> Spec) (X : Spec) : Spec :=
  (* trans : Spec -> Spec *)
| T_def : forall Y, ho_mono Y
                    -> (forall G A, mono G -> subspec (Y (B b G) A) (B b (Y G) A))
                    -> subspec (Y F X) (T b F X).

Lemma B_mono : forall b, mono b -> ho_mono (B b).
Proof. destruct 4. apply B_def with G. assumption.
       intros. intro;intros. apply H3 in H5. revert H5. apply H. apply H0. firstorder.
       revert H4. apply H2. assumption.
Qed.

Lemma T_mono : forall b, ho_mono (T b).
Proof. destruct 3. econstructor;try eassumption. revert H3. apply H1.
       apply H. assumption.
Qed.

Lemma Tf_id : forall b (F : Spec -> Spec), forall A, subspec A (T b F A).
Proof.
  Ltac T_finish Q := apply T_def with Q;[solve[firstorder]|..|assumption];
   let G:=fresh "G" in intro G;unfold subspec;intros;
   try solve[apply B_def with (Q G);[firstorder..|assumption]].
 Ltac T_solve :=
     match goal with
     | [|- forall b F A, subspec (@?Q F A) (T b F A) ] =>
                     intros b F A;intro;intros;T_finish Q
     | [|- forall b F A, mono F -> subspec (@?Q F A) (T b F A) ] =>
                     intros b F A HF;intro;intros;T_finish Q
     | [|- forall b F A, mono F -> forall A, subspec (@?Q F A) (T b F A) ] =>
                     intros b F HF A;intro;intros;T_finish Q
     end.
  T_solve.
Qed.

Lemma Tf_base : forall b (F : Spec -> Spec), forall A, mono b -> subspec (b A) (T b F A).
Proof.
  intros;intro;intros.
  eapply T_def with (fun X => b). firstorder. intros.
  intros;intro;intros.
  eapply B_def. apply H. intros. firstorder. trivial. trivial.
Qed.

Lemma T_id : forall b (F : Spec -> Spec), forall A, subspec (F A) (T b F A).
Proof.
  intros;intro;intros.
  eapply T_def with (fun X => X). firstorder. intros. firstorder. trivial.
Qed.

Lemma T_compat: forall b F, mono b -> mono F -> forall A,
                                subspec (T b (B b F) A) (B b (T b F) A).
Proof.
  intros;intro;intros.
  destruct H1.
  apply H2 in H3;[|assumption].
  revert H3. apply B_mono. assumption.
  intro;intros;intro;intros. apply T_def with Y;try assumption.
  revert H4. apply H1. firstorder. trivial. firstorder.
Qed.

Lemma T_idem : forall b (F : Spec -> Spec),
    mono b -> forall A, subspec (T b (T b F) A) (T b F A).
Proof.
  intros;intro;intros.
  eapply T_def with (fun F => T b (T b F));[..|assumption].
  intro;intros. apply T_mono. apply T_mono;assumption.
  intros. intro;intros. apply T_compat. assumption. apply T_mono; assumption.
  revert H2. apply T_mono;[|firstorder].
  intro;intros. intro;intros. apply T_compat. assumption. assumption.
  revert H3. apply T_mono. apply B_mono. assumption. firstorder. assumption.
Qed.

Definition bot (x:cfg) (P : cfg -> Prop) : Prop := False.

Lemma Tbot_compat : forall b (X:Spec),
    mono b -> subspec (T b (fun _ => bot) (b X)) (b (T b (fun _ => bot) X)).
Proof.
  intros;intro;intros. destruct H0. edestruct H1.
  assert (mono (fun _ => bot)). firstorder. apply H3.
  eapply H0. Focus 3. apply H2. firstorder.
  intro;intros. eassumption.
  apply H4 in H5. revert H5. apply H.
  intro;intros. eapply T_def; try eassumption.
Qed.

Lemma T_t : forall b A, subspec (t b A) (T b (fun _ => bot) A).
Proof.
  destruct 1.
  apply T_def with (fun _ => Y);[firstorder| |assumption].
  unfold subspec;intros.
  apply B_def with Y;auto.
Qed.

Lemma t_T : forall b A, mono b -> subspec (T b (fun _ => bot) A) (t b A).
Proof.
  intros;intro;intros.
  eapply t_def. apply T_mono. Focus 3. eassumption. firstorder.
  intros;intro;intros. apply Tbot_compat; trivial.
Qed.

Lemma Tf_t : forall b F A, mono F -> subspec (t b A) (T b F A).
Proof.
  unfold subspec;intros.
  apply T_t in H0. revert H0.
  apply T_mono. firstorder.
  unfold subspec;trivial.
Qed.

Lemma dup_compat : forall b F A, mono b -> mono F ->
   subspec (B b F (B b F A)) (B b (fun A => F (F A)) A).
Proof.
  intros. intro;intros.
  apply B_def with (G:=(fun A => B b F (B b F A)));[..|assumption].
  intro;intros. apply B_mono. assumption. trivial. apply B_mono; trivial.
  intros;intro;intros.
  assert (forall X, subspec (B b F (b X)) (b (F X))).
  intros;intro;intros. destruct H3. apply H4. assumption.
  apply H3. revert H2. apply B_mono; trivial.
Qed.

Lemma Tf_idem : forall b (F : Spec -> Spec),
    mono b -> mono F -> forall A, subspec (T b F (T b F A)) (T b F A).
Proof.
  intros;intro;intros.
  apply T_idem. assumption. apply T_def with (fun F A => F (F A));[..|assumption].
  intro;intros;intro;intros. apply H2. apply H2. assumption.
  intros. apply dup_compat; trivial.
Qed.

Lemma tfun : forall b (F : Spec -> Spec),
    mono b -> mono F -> forall A, subspec (F (T b F A)) (T b F A).
Proof.
  intros;intro;intros. apply Tf_idem; try assumption. apply T_id. assumption.
Qed.

Lemma t_gfp : forall b (F : Spec -> Spec), mono F ->
    (forall A, subspec (F A) (B b F A)) ->
    (forall A, subspec (F A) (t b A)).
intros;intro;intros.
apply t_def with F;try assumption.
intros;intro;intros.
destruct (H0 (b A0) _ _ H2).
apply H4. assumption.
Qed.

Lemma t_gfp_help : forall b (F : Spec -> Spec), mono F ->
    (forall A, subspec ((T b F) A) (B b (T b F) A)) ->
    (forall A, subspec ((T b F) A) (t b A)).
Proof.
  intros. apply t_gfp. apply T_mono. eauto. assumption.
Qed.

Lemma t_gfp' : forall b (F : Spec -> Spec), mono b -> mono F ->
    (forall A, subspec (F A) (B b (T b F) A)) ->
    (forall A, subspec (F A) (t b A)).
Proof.
  intros. assert (subspec (F A) (B b (T b F) A)) by apply H1.
  assert (forall A, subspec ((T b F) A) (T b (B b (T b F)) A)). (* assumption, mono of T *)
  intros;intro;intros. eapply T_mono. Focus 3. eapply H3. firstorder. firstorder.
  assert (forall A, subspec (T b (B b (T b F)) A) (B b (T b (T b F)) A)).
  intros;intro;intros. apply T_compat. assumption. apply T_mono. eauto. trivial.
  assert (forall A, subspec (B b (T b (T b F)) A) (B b (T b F) A)). (* idempotency of T *)
  intros;intro;intros. revert H5. apply B_mono. assumption. intro;intros;intro;intros.
  eapply T_idem. apply H. revert H6. apply T_mono. apply T_mono. trivial. trivial. firstorder.
  assert (forall A, subspec ((T b F) A) (B b (T b F) A)).
  intros;intro;intros. apply H5. apply H4. apply H3. trivial.
  eapply t_gfp_help with (A:=A) in H6.
  intro;intros. apply H6. apply T_id. trivial. trivial.
Qed.

Lemma T_rule_f : forall b F, mono b -> mono F ->
                             (forall A, subspec (F A) (t b A)) ->
                           (forall A, subspec (T b F A) (t b A)).
Proof.
  intros;intro;intros.
  assert (forall A, subspec (T b F A) (T b (t b) A)).
  intros. apply T_mono; firstorder.
  pose proof T_t.
  assert (forall A, subspec (T b F A) (T b (T b (fun _ => bot)) A)).
  intros.
  intro;intros. apply H3 in H5. inversion H5; subst.
  eapply T_def. eassumption. apply H7. revert H8. apply H6.
  intro;intros;intro;intros. apply H4. revert H9. apply t_mono. trivial.
  firstorder.
  eapply T_idem in H5.
  pose proof t_T. apply H6. assumption. eassumption. trivial. trivial.
Qed.

Lemma rule_by_T : forall b (F : Spec -> Spec), mono b -> mono F ->
    (forall A, subspec (F (b A)) (b (T b F A))) -> (forall A, subspec (F A) (t b A)).
  (* true by lemma 6.2 and fb <= b(Tf) ==> f <= B(Tf) ==> f <= Bdag f ==> f <= t *)
  intros. apply t_gfp'. apply H. apply H0.
  intros. unfold subspec. intros. apply B_def with (G := F).
  apply H0. apply H1. trivial.
Qed.

Lemma use_step : forall b F, mono b -> mono F -> forall A, subspec (b (T b F A)) (T b F A).
Proof.
  unfold subspec;intros. apply Tf_idem; try assumption. apply Tf_base; auto.
Qed.

End relations.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import bedrock2.Array.
Require Import bedrock2.Scalars.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Tactics.destr.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Word.LittleEndianList.
Require Import coqutil.Datatypes.PropSet.
Require Import coqutil.Datatypes.List.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Coq.Lists.List. (* after SeparationLogic *)
Import ListNotations.

Import AbstractInterpretation.Compilers.

Section Maps.
  Local Hint Mode map.map - - : typeclass_instances.
  Context {key value} {key_eqb}
          {map : map.map key value}
          {key_eq_dec :
             forall x y : key,
               BoolSpec (x = y) (x <> y) (key_eqb x y)}
          {map_ok : map.ok map}.

  Lemma only_differ_empty m :
    map.only_differ m PropSet.empty_set m.
  Proof. right; reflexivity. Qed.

  Lemma only_differ_sym m1 m2 ks :
    map.only_differ m1 ks m2 ->
    map.only_differ m2 ks m1.
  Proof. firstorder congruence. Qed.

  Lemma only_differ_trans m1 m2 m3 ks1 ks2 :
    map.only_differ m2 ks1 m1 ->
    map.only_differ m3 ks2 m2 ->
    map.only_differ m3 (union ks1 ks2) m1.
  Proof. firstorder congruence. Qed.

  Global Instance Proper_only_differ :
    Proper (eq ==> sameset ==> eq ==> iff) map.only_differ.
  Proof. firstorder congruence. Qed.

  Global Instance Proper_undef_on :
    Proper (eq ==> sameset ==> iff) map.undef_on.
  Proof. firstorder congruence. Qed.

  Lemma only_differ_put m k v :
    map.only_differ (map.put m k v) (singleton_set k) m.
  Proof.
    cbv [map.only_differ elem_of singleton_set].
    intro x; destr (key_eqb k x); subst;
      rewrite ?map.get_put_same, ?map.get_put_diff by congruence;
      tauto.
  Qed.

  Lemma putmany_of_list_zip_app_l m ks1 ks2 vs :
    map.putmany_of_list_zip (ks1 ++ ks2) vs m =
    Option.bind
      (map.putmany_of_list_zip
         ks1 (List.firstn (Datatypes.length ks1) vs) m)
      (map.putmany_of_list_zip
         ks2 (List.skipn (Datatypes.length ks1) vs)).
  Proof.
    revert m ks2 vs; induction ks1; destruct vs;
      rewrite ?app_nil_l, <-?app_comm_cons;
      try reflexivity; [ ].
    apply IHks1.
  Qed.

  Lemma putmany_of_list_zip_None ks vs m :
    map.putmany_of_list_zip ks vs m = None <->
    length ks <> length vs.
  Proof.
    revert m vs; induction ks; destruct vs;
      cbn [map.putmany_of_list_zip length];
      split; intros; try congruence;
        match goal with
        | H : _ |- _ => apply IHks in H; lia
        | _ => apply IHks; lia
        end.
  Qed.

  Lemma putmany_of_list_zip_combine m ks vs :
    length ks = length vs ->
    map.putmany_of_list_zip ks vs m =
    Some (map.putmany_of_list (combine ks vs) m).
  Proof.
    revert m vs; induction ks; destruct vs; intros;
      cbn [length] in *; try lia; try reflexivity; [ ].
    cbn [map.putmany_of_list_zip map.putmany_of_list combine].
    rewrite IHks; auto.
  Qed.

  Lemma put_put_comm k1 k2 v1 v2 m :
    k1 <> k2 ->
    map.put (map.put m k1 v1) k2 v2 =
    map.put (map.put m k2 v2) k1 v1.
  Proof.
    intros.
    apply map.map_ext; intro k;
      destruct (key_eq_dec k1 k);
      destruct (key_eq_dec k2 k);
      subst; try congruence;
        repeat first [ rewrite map.get_put_same
                     | rewrite map.get_put_diff by congruence
                     | reflexivity ].
  Qed.

  Lemma putmany_of_list_put_comm kv k v m :
    ~ In k (List.map fst kv) ->
    map.putmany_of_list kv (map.put m k v) =
    map.put (map.putmany_of_list kv m) k v.
  Proof.
    revert m k v; induction kv; intros;
      [ reflexivity | ].
    cbn [map.putmany_of_list]. break_match.
    cbn [List.map In fst] in *.
    match goal with H : _ |- _ =>
                    apply Decidable.not_or in H; destruct H end.
    rewrite <-IHkv by auto.
    rewrite put_put_comm by congruence.
    reflexivity.
  Qed.

  Lemma putmany_of_list_comm kv1 kv2 m :
    NoDup (List.map fst (kv1 ++ kv2)) ->
    map.putmany_of_list kv1 (map.putmany_of_list kv2 m) =
    map.putmany_of_list kv2 (map.putmany_of_list kv1 m).
  Proof.
    revert kv2 m; induction kv1; destruct kv2; intros;
      try reflexivity; [ ].
    rewrite map_app in *. cbn [List.map] in *.
    cbn [map.putmany_of_list]. break_match.
    repeat match goal with
           | H : NoDup (_ ++ _) |- _ =>
             apply NoDup_app_iff in H
           | H : _ /\ _ |- _ => destruct H
           | H : NoDup (_ :: _) |- _ => inversion H; subst; clear H
           end.
    cbn [In fst] in *.
    rewrite !putmany_of_list_put_comm by firstorder idtac.
    rewrite put_put_comm by firstorder idtac.
    rewrite IHkv1; [ reflexivity | ].
    rewrite map_app. apply NoDup_app_iff.
    firstorder idtac.
  Qed.

  Lemma putmany_of_list_zip_bind_comm ks1 ks2 vs1 vs2 m :
    NoDup (ks1 ++ ks2) ->
    Option.bind
      (map.putmany_of_list_zip ks1 vs1 m)
      (map.putmany_of_list_zip ks2 vs2) =
    Option.bind
      (map.putmany_of_list_zip ks2 vs2 m)
      (map.putmany_of_list_zip ks1 vs1).
  Proof.
    intros.
    destruct (Nat.eq_dec (length ks1) (length vs1));
      destruct (Nat.eq_dec (length ks2) (length vs2));
      try solve [
            cbv [Option.bind]; break_match; try reflexivity;
            repeat match goal with
                   | H : _ = Some _ |- _ =>
                     apply map.putmany_of_list_zip_sameLength in H
                   | H : _ = None |- _ =>
                     apply putmany_of_list_zip_None in H
                   | _ => apply putmany_of_list_zip_None
                   | _ => symmetry; apply putmany_of_list_zip_None
                   | _ => congruence
                   end ]; [ ].
    repeat match goal with
           | _ => rewrite putmany_of_list_zip_combine by auto
           | _ => progress cbn [Option.bind]
           end.
    rewrite <-putmany_of_list_comm; [ reflexivity | ].
    rewrite <-combine_app_samelength by congruence.
    rewrite map_fst_combine.
    rewrite firstn_all2 by (rewrite !app_length; lia).
    assumption.
  Qed.

  Lemma getmany_of_tuple_empty sz keys :
    sz <> 0%nat ->
    map.getmany_of_tuple (sz:=sz) map.empty keys = None.
  Proof.
    destruct sz; try congruence.
    cbn; intros. rewrite map.get_empty. reflexivity.
  Qed.

  Lemma undef_on_None m k ks :
    map.undef_on m ks ->
    elem_of k ks ->
    map.get m k = None.
  Proof.
    intros.
    match goal with H : map.undef_on _ _ |- _ =>
                    specialize (H _ ltac:(eassumption));
                      rewrite map.get_empty in H
    end.
    congruence.
  Qed.

  Lemma undef_on_empty ks :
    map.undef_on map.empty ks.
  Proof. firstorder idtac. Qed.

  Lemma get_only_differ_undef m1 m2 ks k v :
    map.only_differ m1 ks m2 ->
    map.undef_on m1 ks ->
    map.get m1 k = Some v ->
    map.get m2 k = Some v.
  Proof.
    repeat match goal with
           | _ => progress intros
           | H : map.only_differ _ _ _ |- _ =>
             specialize (H k); destruct H
           | H1 : map.undef_on _ ?ks, H2 : elem_of ?k ?ks |- _ =>
             eapply undef_on_None in H2; [ | eassumption .. ]
           | _ => congruence
           end.
  Qed.

  Lemma only_differ_union_undef_l m1 m2 k1 k2 :
    map.only_differ m1 (union k1 k2) m2 ->
    map.undef_on m1 k2 ->
    map.undef_on m2 k2 ->
    map.only_differ m1 k1 m2.
  Proof.
    intros.
    match goal with H : map.only_differ _ _ _ |- map.only_differ _ _ _ =>
                    let x := fresh "x" in intro x; specialize (H x);
                                            destruct H
    end; [ | tauto ].
    match goal with H : elem_of _ (union _ _) |- _ =>
                    destruct H end;
      erewrite ?undef_on_None by eauto; tauto.
  Qed.

  Lemma undef_on_subset m k1 k2 :
    subset k1 k2 ->
    map.undef_on m k2 ->
    map.undef_on m k1.
  Proof. firstorder congruence. Qed.

  Lemma only_differ_disjoint_undef_on m1 m2 ks s :
    map.only_differ m1 ks m2 ->
    disjoint ks s ->
    map.undef_on m1 s ->
    map.undef_on m2 s.
  Proof. firstorder congruence. Qed.

  Lemma undef_on_union_iff m k1 k2 :
    map.undef_on m (union k1 k2) <->
    (map.undef_on m k1 /\ map.undef_on m k2).
  Proof.
    cbv [map.undef_on map.agree_on union elem_of].
    repeat split; intros; destruct_head'_or; destruct_head'_and; eauto.
  Qed.

  Lemma put_undef_on k v m s :
    map.undef_on m s ->
    ~ s k ->
    map.undef_on (map.put m k v) s.
  Proof.
    cbv [map.undef_on map.agree_on elem_of].
    intros. rewrite map.get_empty.
    match goal with H : context [map.empty] |- _ =>
                    setoid_rewrite map.get_empty in H end.
    match goal with H1 : ~ ?s ?k1, H2 : ?s ?k2 |- _ =>
                    destruct (key_eq_dec k1 k2); subst;
                      [ tauto | ]
    end.
    rewrite map.get_put_diff by congruence. eauto.
  Qed.

  Lemma of_list_zip_app ks1 ks2 vs1 vs2 :
    length ks1 = length vs1 ->
    length ks2 = length vs2 ->
    (exists l,
        map.of_list_zip (ks1 ++ ks2) (vs1 ++ vs2) = Some l).
  Proof.
    intros. apply map.sameLength_putmany_of_list.
    rewrite !app_length; lia.
  Qed.

  Lemma putmany_of_list_zip_undef_on ks vs m1 m2 s :
    map.putmany_of_list_zip ks vs m1 = Some m2 ->
    disjoint (of_list ks) s ->
    map.undef_on m1 s ->
    map.undef_on m2 s.
  Proof.
    revert vs m1 m2 s; induction ks; destruct vs;
      cbn [map.putmany_of_list_zip]; intros;
        try match goal with H : Some _ = Some _ |- _ =>
                            inversion H; subst; clear H
            end; try congruence; eauto; [ ].
    match goal with H : _ |- _ =>
                    symmetry in H; apply disjoint_cons in H
    end.
    destruct_head'_and.
    eapply IHks; eauto.
    { symmetry; eauto. }
    { apply put_undef_on; eauto.
      eapply disjoint_singleton_r_iff; eauto. }
  Qed.

  Lemma of_list_zip_undef_on ks vs m s :
    map.of_list_zip ks vs = Some m ->
    disjoint (of_list ks) s ->
    map.undef_on m s.
  Proof.
    cbv [map.of_list_zip]; intros.
    eapply putmany_of_list_zip_undef_on; eauto.
    cbv [map.undef_on map.agree_on]; reflexivity.
  Qed.

  Lemma only_differ_notin k ks m m' :
    map.only_differ m ks m' ->
    ~ ks k ->
    map.get m' k = map.get m k.
  Proof.
    cbv [map.only_differ PropSet.elem_of].
    let H := fresh in
    intro H; specialize (H k); destruct H.
    { tauto. }
    { auto. }
  Qed.
End Maps.

(* proofs about list_Z_bounded_by *)
Section ListZBoundedBy.
  Lemma relax_list_Z_bounded_by r1 r2 x :
    ZRange.type.option.is_tighter_than
      (t:=type.base (base.type.list (base.type.type_base base.type.Z)))
      (Some r1) (Some r2) = true ->
    list_Z_bounded_by r1 x ->
    list_Z_bounded_by r2 x.
  Proof.
    cbn in r1, r2 |- *. intros.
    pose proof length_list_Z_bounded_by _ x ltac:(eassumption).
    match goal with H : FoldBool.fold_andb_map _ _ _ = true |- _ =>
                    pose proof H;
                      apply FoldBool.fold_andb_map_length in H
    end.
    generalize dependent r1; generalize dependent r2.
    generalize dependent x; induction x; cbn [length].
    { destruct r2; cbn [length]; intros; [ | lia].
      reflexivity. }
    { destruct r1, r2; cbn [length]; intros; try lia; [ ].
      cbv [list_Z_bounded_by] in *. cbn [FoldBool.fold_andb_map] in *.
      repeat match goal with
             | H : _ /\ _ |- _ => destruct H
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H
             end.
      apply Bool.andb_true_iff; split.
      { break_innermost_match; [ | reflexivity].
        break_innermost_match_hyps; [ | congruence ].
        cbv [ZRange.is_tighter_than_bool] in *.
        repeat match goal with
               | H : _ /\ _ |- _ => destruct H
               | H : (_ && _)%bool = true |- _ =>
                 apply Bool.andb_true_iff in H
               end.
        apply Bool.andb_true_iff; split; Z.ltb_to_lt; lia. }
      { eapply IHx;
          match goal with
          | |- length _ = length _ =>
            idtac (* no eassumption on length goals *)
          | _ => try eassumption
          end; lia. } }
  Qed.

  Lemma list_Z_bounded_by_Forall x r m :
    list_Z_bounded_by (repeat (Some r) m) x ->
    Forall (fun z : Z => ZRange.lower r <= z <= ZRange.upper r)%Z x.
  Proof.
    intros.
    pose proof length_list_Z_bounded_by _ x ltac:(eassumption).
    cbv [list_Z_bounded_by] in *.
    rewrite repeat_length in *.
    generalize dependent x.
    generalize dependent m.
    induction m; intros;
      destruct x; intros; cbn [length] in *; subst;
        try lia; [ | ]; constructor;
          [ | apply IHm; [ | lia] ].
    all: cbn [repeat FoldBool.fold_andb_map] in *.
    all: repeat match goal with
                | H : _ /\ _ |- _ => destruct H
                | H : (_ && _)%bool = true |- _ =>
                  apply Bool.andb_true_iff in H
                | _ => progress Z.ltb_to_lt
                | _ => solve [auto]
                | _ => lia
                end.
  Qed.

  Lemma list_Z_bounded_by_cons b0 bs x0 xs:
    list_Z_bounded_by (b0 :: bs) (x0 :: xs) <->
    (match b0 with
     | Some r =>
       ZRange.is_bounded_by_bool x0 r = true
     | None => True
     end /\ list_Z_bounded_by bs xs).
  Proof.
    cbv [list_Z_bounded_by]. cbn [FoldBool.fold_andb_map].
    cbv [ZRange.is_bounded_by_bool].
    split; destruct b0; intros;
      repeat match goal with
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H
             | |- (_ && _)%bool = true => apply Bool.andb_true_iff
             | H : _ /\ _ |- _ => destruct H
             | |- _ /\ _ => split
             | _ => assumption
             | _ => tauto
             end.
  Qed.

  Lemma list_Z_tighter_than_cons b1 b2 b1s b2s :
    list_Z_tighter_than (b1 :: b1s) (b2 :: b2s) <->
    (match b1 with
     | Some r1 =>
       match b2 with
       | Some r2 =>
         (ZRange.lower r2 <= ZRange.lower r1
          /\ ZRange.upper r1 <= ZRange.upper r2)%Z
       | None => True
       end
     | None => match b2 with
               | Some _ => False
               | None => True
               end
     end /\ list_Z_tighter_than b1s b2s).
  Proof.
    cbv [list_Z_tighter_than]. cbn [FoldBool.fold_andb_map].
    split; destruct b1, b2; intros;
      repeat match goal with
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H
             | |- (_ && _)%bool = true => apply Bool.andb_true_iff
             | H : _ /\ _ |- _ => destruct H
             | |- _ /\ _ => split
             | _ => progress Z.ltb_to_lt
             | _ => assumption
             | _ => tauto
             | _ => congruence
             end.
  Qed.

  Lemma list_Z_bounded_by_snoc b0 bs x0 xs:
    list_Z_bounded_by (bs ++ [b0]) (xs ++ [x0]) <->
    (match b0 with
     | Some r =>
       ZRange.is_bounded_by_bool x0 r = true
     | None => True
     end /\ list_Z_bounded_by bs xs).
  Proof.
    cbv [list_Z_bounded_by].
    rewrite FoldBool.fold_andb_map_snoc.
    cbv [ZRange.is_bounded_by_bool].
    split; destruct b0; intros;
      repeat match goal with
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H
             | |- (_ && _)%bool = true => apply Bool.andb_true_iff
             | H : _ /\ _ |- _ => destruct H
             | |- _ /\ _ => split
             | _ => assumption
             | _ => tauto
             end.
  Qed.

  Lemma relax_to_bounded_upperbounds bs upperbounds x :
    list_Z_bounded_by
      (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
           upperbounds) x ->
    Forall (fun r =>
              match r with
              | Some r => ZRange.lower r = 0%Z
              | None => True end) bs ->
    list_Z_bounded_by bs upperbounds ->
    list_Z_bounded_by bs x.
  Proof.
    intros.
    pose proof length_list_Z_bounded_by bs _ ltac:(eassumption).
    pose proof length_list_Z_bounded_by _ x ltac:(eassumption).
    rewrite map_length in *.
    generalize dependent bs. generalize dependent upperbounds.
    generalize dependent x.
    induction x; destruct upperbounds; destruct bs;
      cbn [map length] in *; try congruence; intros; [ ].
    repeat match goal with
           | _ => progress cbv [ZRange.is_bounded_by_bool] in *
           | _ => progress cbn [ZRange.lower ZRange.upper] in *
           | H : _ = 0 |- _ => rewrite H in *
           | H : Forall _ (_ :: _) |- _ =>
             inversion H; subst; clear H
           | H : (_ && _)%bool = true |- _ =>
             apply Bool.andb_true_iff in H
           | H : list_Z_bounded_by (_ :: _) (_ :: _) |- _ =>
             apply list_Z_bounded_by_cons in H; destruct H
           | |- list_Z_bounded_by (_ :: _) (_ :: _) =>
             apply list_Z_bounded_by_cons; split
           | |- (_ && _)%bool = true => apply Bool.andb_true_iff
           | H : _ /\ _ |- _ => destruct H
           | |- _ /\ _ => split
           | _ => progress break_match
           | _ => solve [auto]
           | _ => Z.ltb_to_lt; lia
           | H : _ |- list_Z_bounded_by _ _ => eapply H; solve [eauto]
           end.
  Qed.

  Lemma tighter_than_if_upper_bounded_by lo uppers bs :
    list_Z_bounded_by bs uppers ->
    Forall (fun b =>
              exists r,
                b = Some r /\ ZRange.lower r = lo) bs ->
    list_Z_tighter_than
      (map (fun v : Z => Some {| ZRange.lower := lo; ZRange.upper := v |})
           uppers) bs.
  Proof.
    clear; revert bs; induction uppers; intros;
      lazymatch goal with
      | H : list_Z_bounded_by _ _ |- _ =>
        pose proof H; apply length_list_Z_bounded_by in H
      end; (destruct bs; cbn [length] in *; try auto with lia); [ ].
    repeat lazymatch goal with
           | H : list_Z_bounded_by (_::_) (_::_) |- _ =>
             rewrite list_Z_bounded_by_cons in H
           | |- list_Z_tighter_than (map _ (_ :: _)) (_ :: _) =>
             cbn [map]; rewrite list_Z_tighter_than_cons
           | H : ZRange.is_bounded_by_bool _ _ = true |- _ =>
             apply Bool.andb_true_iff in H; destruct H;
               Z.ltb_to_lt
           | H : Forall _ (_ :: _) |- _ => inversion H; clear H; subst
           | H : exists _, _ |- _ => destruct H; subst
           | H : _ /\ _ |- _ => destruct H; subst
           end.
    progress cbn [ZRange.lower ZRange.upper].
    split; auto with lia.
  Qed.

  Lemma partition_bounded_by_partition_ones x lg2s nb :
    (0 <= x < 2 ^ lg2s)%Z ->
    list_Z_bounded_by
      (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
           (Partition.Partition.partition
              (ModOps.weight 8 1) nb (2 ^ lg2s - 1)))
      (Partition.Partition.partition (ModOps.weight 8 1) nb x).
  Proof.
    clear.
    induction nb; [ reflexivity | ].
    rewrite !Partition.partition_step.
    rewrite map_last, list_Z_bounded_by_snoc.
    split; [ | solve [auto] ]. cbv [ZRange.is_bounded_by_bool].
    cbn [ZRange.lower ZRange.upper].
    apply Bool.andb_true_iff; split; Z.ltb_to_lt;
      [ ZeroBounds.Z.zero_bounds;
        solve [auto using Core.weight_positive, ModOps.wprops
                 with zarith] | ].
    apply Z.div_le_mono;
      [ solve [auto using Core.weight_positive, ModOps.wprops
                 with zarith] | ].
    cbv [ModOps.weight]. rewrite Nat2Z.inj_succ.
    autorewrite with zsimplify_fast. clear IHnb.
    destruct (Z_lt_dec lg2s ((8 * Z.of_nat nb + 8)%Z));
      [ assert (2 ^ lg2s < 2 ^ (8 * Z.of_nat nb + 8))%Z | ].
    1:auto with zarith.
    1:rewrite !Z.mod_small; auto with zarith.
    replace (2 ^ lg2s - 1)%Z with (Z.ones lg2s)
      by (rewrite Z.ones_equiv; auto with zarith).
    rewrite Z.ones_mod_pow2 by auto with zarith.
    lazymatch goal with
      |- context [(x mod ?m)%Z] =>
      pose proof Z.mod_pos_bound x m ltac:(auto with zarith)
    end.
    rewrite Z.ones_equiv; auto with zarith.
  Qed.
End ListZBoundedBy.

Section Bytes.
  Context {width : Z} {word : word width} {word_ok : word.ok word}.
  Local Notation bytes_per_word := (Z.to_nat (Memory.bytes_per_word width)).

  Definition eval_bytes bs := map le_combine (chunk bytes_per_word bs).

  Definition encode_bytes (xs : list word) : list Byte.byte :=
    flat_map (fun w => le_split bytes_per_word (word.unsigned w)) xs.

  Lemma bytes_per_word_nz : bytes_per_word <> 0%nat.
  Proof.
    pose proof word.width_pos.
    cbv [Memory.bytes_per]. change 0%nat with (Z.to_nat 0).
    rewrite Z2Nat.inj_iff by (try apply Z.div_pos; lia).
    apply not_eq_sym. apply Z.lt_neq, Z.div_str_pos.
    lia.
  Qed.

  Lemma eval_bytes_length bs n :
    length bs = (n * bytes_per_word)%nat ->
    length (eval_bytes bs) = n.
  Proof.
    intro Hlength.
    pose proof bytes_per_word_nz.
    rewrite <-(Nat.div_mul n bytes_per_word) by trivial.
    cbv [eval_bytes]; rewrite map_length, length_chunk by trivial.
    rewrite Hlength, Nat.div_up_exact, Nat.div_mul; trivial.
  Qed.

  Lemma Forall_map_byte_unsigned x :
    Forall (fun z : Z => 0 <= z < 2 ^ 8)%Z (map Byte.byte.unsigned x).
  Proof.
    induction x; cbn [length] in *; constructor; eauto; [ ].
    apply Byte.byte.unsigned_range.
  Qed.

  Context {bits_per_word_eq_width : (Z.of_nat bytes_per_word * 8 = width)%Z}.

  Lemma eval_bytes_range bs :
    Forall (fun z : Z => (0 <= z < 2 ^ width)%Z) (eval_bytes bs).
  Proof.
    pose proof bytes_per_word_nz as Hnz.
    apply Forall_map_iff, Forall_nth; intros.
    split; try eapply Z.lt_le_trans; try apply le_combine_bound.
    eapply Z.pow_le_mono_r; [cbv;trivial|].
    rewrite length_chunk in H by trivial.
    erewrite nth_error_nth in *; [|eapply nth_error_chunk; trivial].
    rewrite firstn_length, skipn_length.

    change 8%Z with (Z.of_nat 8).
    rewrite <-Nat2Z.inj_mul, <-Nat.mul_min_distr_l, Nat2Z.inj_min, Nat.mul_comm.
    rewrite Nat2Z.inj_mul.
    setoid_rewrite bits_per_word_eq_width.
    eapply Z.le_min_l.
  Qed.
End Bytes.

Section Scalars.
  Context
  {width: Z} {BW: Bitwidth.Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}
  {locals: map.map String.string word}
  {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}
  {ext_spec: bedrock2.Semantics.ExtSpec}
  {varname_gen : nat -> String.string}
  {word_ok : word.ok word} {mem_ok : map.ok mem}
  {locals_ok : map.ok locals}
  {env_ok : map.ok env}
  {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Local Notation bytes_per_word :=
    (@Memory.bytes_per_word width).

  Lemma scalar_to_bytes (a x : word) :
    Lift1Prop.iff1
      (scalar a x)
      (array ptsto (word.of_Z 1) a
             (LittleEndianList.le_split (Z.to_nat bytes_per_word)
             (word.unsigned x))).
  Proof.
    unfold scalar, truncated_word, truncated_scalar, littleendian, ptsto_bytes.ptsto_bytes.
    rewrite HList.tuple.to_list_of_list; reflexivity.
  Qed.

  Lemma truncated_scalar_one_ptsto_iff1 :
    forall (addr : word) x,
      Lift1Prop.iff1
        (truncated_scalar access_size.one addr x)
        (ptsto addr (Byte.byte.of_Z x)).
  Proof. intros.
    unfold scalar, truncated_word, truncated_scalar, littleendian, ptsto_bytes.ptsto_bytes.
    rewrite HList.tuple.to_list_of_list. unfold Memory.bytes_per, le_split, array.
    cancel.
  Qed.

  Lemma array_truncated_scalar_scalar_iff1 :
    forall xs (start : word) size,
      Lift1Prop.iff1
        (array (truncated_scalar access_size.word)
               size start (map word.unsigned xs))
        (array scalar size start xs).
  Proof.
    induction xs; cbn [array map]; intros; [ reflexivity | ].
    rewrite IHxs by auto. reflexivity.
  Qed.

  Lemma array_truncated_scalar_ptsto_iff1 :
    forall xs (start : word) size,
      Lift1Prop.iff1
        (array (truncated_scalar access_size.one)
               size start xs)
        (array ptsto size start (map Byte.byte.of_Z xs)).
  Proof.
    induction xs; cbn [array map]; intros; [ reflexivity | ].
    rewrite IHxs by auto. rewrite truncated_scalar_one_ptsto_iff1.
    cancel.
  Qed.
End Scalars.

Section Words.
  Local Hint Mode word.word - : typeclass_instances.
  Context {width} {word : word.word width} {ok : word.ok word}.

  Lemma map_of_Z_unsigned x :
    map word.of_Z (map word.unsigned x) = x.
  Proof.
    rewrite map_map.
    rewrite map_ext with (g:=id);
      [ solve [apply map_id] | ].
    intros. rewrite word.of_Z_unsigned.
    reflexivity.
  Qed.

  Lemma map_unsigned_of_Z x :
    map word.unsigned (map word.of_Z x) = map word.wrap x.
  Proof.
    rewrite map_map. apply map_ext.
    exact word.unsigned_of_Z.
  Qed.

  Lemma Forall_map_unsigned x :
    Forall (fun z : Z => (0 <= z < 2 ^ width)%Z)
           (map word.unsigned x).
  Proof.
    induction x; intros; cbn [map]; constructor;
      auto using word.unsigned_range.
  Qed.

  Local Notation bytes_per_word := (Z.to_nat (Memory.bytes_per_word width)).
  Lemma Forall_word_unsigned_within_access_size
    {bits_per_word_eq_width : (Z.of_nat bytes_per_word * 8 = width)%Z} x :
    Forall
      (fun z : Z =>
         0 <= z < 2 ^ (Z.of_nat (Memory.bytes_per (width:=width) access_size.word) * 8))%Z
      (map word.unsigned x).
  Proof.
    intros.
    eapply Forall_impl; [ | apply Forall_map_unsigned ].
      cbv beta; intros.
    setoid_rewrite bits_per_word_eq_width; assumption.
  Qed.
End Words.

(* These lemmas should be moved to bedrock2, not coqutil *)
Section Separation.
  Local Hint Mode map.map - - : typeclass_instances.
  Context `{map_ok : map.ok}
           {key_eqb : forall H H0 : key, bool}
           {key_eq_dec :
              forall x y : key,
                BoolSpec (x = y) (x <> y) (key_eqb x y)}.
  Lemma sep_empty_iff (q r : map.rep -> Prop) :
    sep q r map.empty <-> q map.empty /\ r map.empty.
  Proof.
    cbv [sep].
    repeat match goal with
           | _ => progress (intros; subst)
           | H : _ /\ _ |- _ => destruct H
           | H : exists _, _ |- _ => destruct H
           | H : _ |- _ => apply map.split_empty in H
           | _ => rewrite map.split_empty
           | _ => exists map.empty
           | _ => tauto
           | _ => split
           end.
  Qed.

  Lemma iff1_sep_cancel_both p1 p2 q1 q2 :
    Lift1Prop.iff1 p1 p2 ->
    Lift1Prop.iff1 q1 q2 ->
    Lift1Prop.iff1 (sep p1 q1) (sep p2 q2).
  Proof.
    intros Hp Hq. rewrite Hp, Hq. reflexivity.
  Qed.
End Separation.

(* These lemmas should be moved to bedrock2, not coqutil *)
Section WeakestPrecondition.
  Import Bitwidth bedrock2.WeakestPrecondition.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  (* "expr" should not be Compilers.expr; can remove once upstreamed *)
  Local Notation expr := WeakestPrecondition.expr.

  Section Load.
    Lemma load_empty :
      forall s (m:mem) a post,
        load s map.empty a post -> load s m a post.
    Proof.
      intros *.
      cbv [load Memory.load Memory.load_Z Memory.load_bytes].
      rewrite getmany_of_tuple_empty; intros;
        repeat match goal with
               | H : exists _, _ |- _ => destruct H
               | H : _ /\ _ |- _ => destruct H
               | _ => congruence
               end.
      cbv [Memory.bytes_per]; break_match; try congruence.
      change 0%nat with (Z.to_nat 0).
      pose proof word.width_pos.
      rewrite Z2Nat.inj_iff by (try apply Z.div_pos; lia).
      rewrite Z.eq_sym_iff.
      apply Z.lt_neq, Z.div_str_pos; lia.
    Qed.
  End Load.

  Section Get.
    Lemma get_put_same (l : locals) x y (post:_->Prop) :
      post y -> get (map.put l x y) x post.
    Proof.
      cbv [get]; intros.
      exists y; rewrite map.get_put_same; tauto.
    Qed.

    Lemma get_put_diff (l : locals) x1 x2 y (post:_->Prop) :
      x1 <> x2 ->
      get l x1 post ->
      get (map.put l x2 y) x1 post.
    Proof.
      cbv [get]; intros.
      match goal with H : exists _, _ |- _ =>
                      destruct H end.
      eexists; rewrite map.get_put_diff; eauto.
    Qed.

    (* TODO: make module around Maps to stop name collision *)
    Lemma WP_get_only_differ_undef :
      forall e vset (locals locals' : locals) post,
        map.only_differ locals vset locals' ->
        map.undef_on locals vset ->
        get locals e post ->
        get locals' e post.
    Proof.
      cbv [get]; intros.
      match goal with H : exists _, _ |- _ => destruct H end.
      destruct_head'_and. eexists; split; try eassumption; eapply get_only_differ_undef; eauto.
    Qed.
  End Get.

  Section Expr.
    Lemma expr_empty :
      forall e m (locals : locals) post,
        expr map.empty locals e post ->
        expr m locals e post.
    Proof.
      induction e;
        cbn [expr expr_body];
        cbv [dlet.dlet literal get];
        intros; eauto.
      { eapply IHe; eauto.
        eapply Proper_expr; [ repeat intro | eassumption ].
        eauto using load_empty. }
      { eapply IHe1; eauto.
        eapply Proper_expr; [ repeat intro | eassumption ].
        cbv beta in *. eapply IHe2; eauto. }
      { eapply IHe1; eauto.
        eapply Proper_expr; [ repeat intro | eassumption ].
        cbv beta in *.
        destr (word.eqb a (word.of_Z 0)); eauto. }
    Qed.

    Lemma expr_untouched mem1 mem2 (l1 l2 : locals) vars v P :
      map.only_differ l2 vars l1 ->
      ~ vars v ->
      expr mem1 l1 (expr.var v) P <->
      expr mem2 l2 (expr.var v) P.
    Proof.
      cbv [map.only_differ
             elem_of
             expr
             expr_body
             get].
      let H := fresh in
      intro H; specialize (H v).
      split; intros;
        repeat match goal with
               | H : exists _, _ |- _ => destruct H
               | H : _ \/ _ |- _ => destruct H
               | H : _ /\ _ |- _ => destruct H
               | H : map.get _ _ = map.get _ _ |- _ =>
                 rewrite H in *
               | |- exists _, _ => eexists
               | |- _ /\ _ => split
               | _ => eassumption
               | _ => tauto
               end.
    Qed.

    Lemma expr_only_differ_undef :
      forall e m vset (locals locals' : locals) post,
        map.only_differ locals vset locals' ->
        map.undef_on locals vset ->
        expr m locals e post ->
        expr m locals' e post.
    Proof.
      induction e;
        cbn [expr expr_body]; cbv [dlet.dlet literal];
        intros; eauto using WP_get_only_differ_undef.
      { eapply IHe1; eauto.
        eapply Proper_expr; [ repeat intro | eassumption ].
        cbv beta in *. eapply IHe2; eauto. }
      { eapply IHe1; eauto.
        eapply Proper_expr; [ repeat intro | eassumption ].
        cbv beta in *. destr (word.eqb a (word.of_Z 0)); eauto. }
    Qed.
  End Expr.

  Section ListMap.
    Context {A B} (f : A -> (B -> Prop) -> Prop)
            (f_ext :
               forall a H1 H2,
                 (forall b, H1 b <-> H2 b) ->
                 f a H1 <-> f a H2).
    Lemma list_map_app_iff xs ys post :
      list_map f (xs ++ ys) post <->
      list_map
        f xs (fun xx =>
                list_map
                  f ys (fun yy => post (xx ++ yy))).
    Proof.
      revert ys post; induction xs;
        repeat match goal with
               | _ => progress intros
               | _ => progress cbn [list_map
                                      list_map_body] in *
               | _ => rewrite app_nil_l
               | _ => rewrite <-app_comm_cons
               | |- f _ _ <-> f _ _ => apply f_ext
               | _ => reflexivity
               end.
      apply IHxs.
    Qed.

    Lemma list_map_cons_iff x xs post :
      list_map f (x :: xs) post <->
      f x (fun y => list_map f xs (fun ys => post (y :: ys))).
    Proof. reflexivity. Qed.
  End ListMap.

  Section Dexpr.
    Lemma dexpr_equiv m (l : locals) n x1 x2 :
      dexpr m l (expr.var n) x1 ->
      dexpr m l (expr.var n) x2 ->
      x1 = x2.
    Proof.
      destruct 1; destruct 1; destruct_head'_and; congruence.
    Qed.

    Lemma dexpr_put_same m (l : locals) n x :
      dexpr m (map.put l n x) (expr.var n) x.
    Proof. eexists; rewrite map.get_put_same; tauto. Qed.

    Lemma dexpr_put_diff m (l : locals) n1 n2 x y :
      n1 <> n2 ->
      dexpr m l (expr.var n1) x ->
      dexpr m (map.put l n2 y) (expr.var n1) x.
    Proof.
      destruct 2; intros; eexists; rewrite map.get_put_diff; eauto.
    Qed.
  End Dexpr.

  (* TODO: some of these may be unused *)
  Section Dexprs.
    Local Ltac peel_expr :=
      progress (
          repeat
            progress match goal with
                     | H : expr ?m ?l ?e _ |- _ =>
                       match goal with
                       | |- expr m l e _ => idtac
                       | _ =>
                         apply expr_sound with (mc:=MetricLogging.EmptyMetricLog) in H;
                         destruct H as [? [_ [_ H] ] ]
                       end
                     end).

    Local Ltac propers_step :=
      match goal with
      | H : get ?l ?x _
        |- get ?l ?x _ =>
        eapply Proper_get
      | H : expr ?m ?l ?e _
        |- expr ?m ?l ?e _ =>
        eapply Proper_expr
      | H : list_map ?f ?xs _
        |- list_map ?f ?xs _ =>
        eapply Proper_list_map
      end; [ repeat intro .. | eassumption ]; cbv beta in *.

    Local Ltac propers :=
      propers_step;
      match goal with
      | _ => solve [propers]
      | H : _ |- _ => apply H; solve [eauto]
      | _ => congruence
      end.

    Lemma dexprs_cons_iff m (l : locals) e es v vs :
      dexprs m l (e :: es) (v :: vs) <->
      (expr m l e (eq v)
       /\ dexprs m l es vs).
    Proof.
      cbv [dexprs].
      revert es v vs; induction es; split; intros;
        repeat match goal with
               | _ => progress cbn [list_map
                                      list_map_body] in *
               | _ => progress cbv beta in *
               | H : _ :: _ = _ :: _ |- _ => inversion H; clear H; subst
               | |- _ /\ _ => split
               | _ => progress destruct_head'_and
               | _ => solve [propers]
               | _ => reflexivity
               | _ => peel_expr
               end.
      eapply IHes with (vs := tl vs).
      propers_step. peel_expr.
      destruct vs; cbn [tl]; propers.
    Qed.

    Lemma dexprs_cons_nil m (l : locals) e es :
      dexprs m l (e :: es) [] -> False.
    Proof.
      cbv [dexprs].
      induction es; intros;
        repeat match goal with
               | _ => progress cbn [list_map
                                      list_map_body] in *
               | _ => congruence
               | _ => solve [propers]
               | _ => apply IHes
               | _ => peel_expr
               end.
      propers_step. peel_expr. propers.
    Qed.

    Lemma dexprs_app_l m (l : locals) es1 :
      forall es2 vs,
        dexprs m l (es1 ++ es2) vs ->
        (dexprs m l es1 (firstn (length es1) vs)) /\
        (dexprs m l es2 (skipn (length es1) vs)).
    Proof.
      induction es1; intros.
      { cbn [Datatypes.length skipn firstn]; rewrite app_nil_l in *.
        split; eauto; reflexivity. }
      { destruct vs; rewrite <-app_comm_cons in *;
          [ match goal with H : _ |- _ => apply dexprs_cons_nil in H; tauto end | ].
        cbn [Datatypes.length skipn firstn].
        rewrite !dexprs_cons_iff in *.
        destruct_head'_and.
        repeat split; try eapply IHes1; eauto. }
    Qed.

    Lemma dexprs_length m (l : locals) :
      forall vs es,
        dexprs m l es vs ->
        length es = length vs.
    Proof.
      induction vs; destruct es; intros;
        repeat match goal with
               | _ => progress cbn [Datatypes.length]
               | _ => progress destruct_head'_and
               | H : _ |- _ => apply dexprs_cons_nil in H; tauto
               | H : _ |- _ => apply dexprs_cons_iff in H
               | _ => reflexivity
               | _ => congruence
               end.
      rewrite IHvs; auto.
    Qed.
  End Dexprs.
End WeakestPrecondition.


Require Import
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Lib2.FixList.
Require Export
        Coq.Lists.List.

Section SteppingList.
  Context {A : Type}. (* data type *)
  Context {B : Type}. (* bin type *)
  Context {P : Type}. (* cache pointer type *)
  Context {cache : Cache}.
  Context {transformer : Transformer B}.

  Variable fuel : nat.
  Variable A_halt : A.
  Variable A_halt_dec : forall a, {a = A_halt} + {~ a = A_halt}.
  Variable A_predicate : A -> Prop.
  Variable A_encode : A -> CacheEncode -> B * CacheEncode.
  Variable A_decode : B -> CacheDecode -> A * B * CacheDecode.
  Variable A_decode_pf : encode_decode_correct cache transformer A_predicate A_encode A_decode.

  Variable P_predicate : P -> Prop.
  Variable P_predicate_dec : forall p, {P_predicate p} + {~ P_predicate p}.
  Variable P_encode : P -> CacheEncode -> B * CacheEncode.
  Variable P_decode : B -> CacheDecode -> P * B * CacheDecode.
  Variable P_decode_pf : encode_decode_correct cache transformer P_predicate P_encode P_decode.

  Variable X_encode : bool -> CacheEncode -> B * CacheEncode.
  Variable X_decode : B -> CacheDecode -> bool * B * CacheDecode.
  Variable X_decode_pf : encode_decode_correct cache transformer (fun _ => True) X_encode X_decode.

  Variable cacheAdd : CacheAdd cache (list A * P).
  Variable cacheGet : CacheGet cache (list A) P.
  Variable cachePeek : CachePeek cache P.

  (*Fixpoint encode_list_step (l : list A) (ce : CacheEncode) : B * CacheEncode :=
    match l with
    | nil => let (b1, e1) := X_encode false ce in
             let (b2, e2) := A_encode A_halt e1 in
                 (transform b1 b2, e2)
    | cons x l' =>
      match getE ce l with
      | Some position =>
        if P_predicate_dec position
        then let (b1, e1) := X_encode true ce in
             let (b2, e2) := P_encode position e1 in
                 (transform b1 b2, e2)
        else let (b1, e1) := X_encode false ce in
             let (b2, e2) := A_encode x e1 in
             let (b3, e3) := encode_list_step l' e2 in
                 (transform (transform b1 b2) b3, addE e3 (l, peekE ce))
      | None => let (b1, e1) := X_encode false ce in
                let (b2, e2) := A_encode x e1 in
                let (b3, e3) := encode_list_step l' e2 in
                    (transform (transform b1 b2) b3, addE e3 (l, peekE ce))
      end
    end.

  Fixpoint decode'_list_step (f : nat) (b : B) (cd : CacheDecode) : list A * B * CacheDecode :=
    let (x1, e1) := X_decode b cd in
    let (br, b1) := x1 in
    match br with
    | true => let (x2, e2) := P_decode b1 e1 in
              let (ps, b2) := x2 in
              match getD cd ps with
              | Some l => (l, b2, e2)
              | None => (nil, b, cd) (* bogus *)
             end
    | false => let (x2, e2) := A_decode b1 e1 in
               let (a, b2) := x2 in
               if A_halt_dec a then
                 (nil, b2, e2)
               else
                 match f with
                 | O => (nil, b, cd) (* bogus *)
                 | S f' => let (x3, e3) := decode'_list_step f' b2 e2 in
                           let (l, b3) := x3 in
                           (a :: l, b3, addD e3 (a :: l, peekD cd))
                 end
    end.

  Definition decode_list_step := decode'_list_step fuel.

  Theorem SteppingList_decode_correct :
    encode_decode_correct
      cache transformer
      (fun ls => A_predicate A_halt /\ |ls| <= fuel /\ (forall x, In x ls -> A_predicate x /\
                                                                             ~ x = A_halt))
      encode_list_step decode_list_step.
  Proof.
    unfold encode_decode_correct.
    intros env env' xenv xenv' l l' bin' ext ext' Eeq [Ppredh [PPredlen PPredA]] Penc Pdec.
    unfold decode_list_step in *; simpl in *.
    generalize dependent l'; generalize dependent fuel; clear fuel;
      generalize dependent env; generalize dependent env';
      generalize dependent xenv; generalize dependent bin';
      generalize ext; generalize dependent ext'; generalize dependent xenv';
    induction l; intros; simpl in *.
    { destruct (X_encode false env) eqn: ?.
      destruct (A_encode A_halt c) eqn: ?.
      inversion Penc; subst; clear Penc.
      destruct (X_decode (transform (transform b b0) ext0) env') as [[? ?] ?] eqn: ?.
      rewrite <- transform_assoc in Heqp1.
      destruct (X_decode_pf _ _ _ _ _ _ _ _ _ Eeq I Heqp Heqp1) as [? [? ?]]; subst.
      destruct fuel eqn: ?; subst; simpl in *; try rewrite !transform_assoc in Heqp1.
      { rewrite Heqp1 in Pdec.
        destruct (A_decode (transform b0 ext0) c0) as [[? ?] ?] eqn: ?.
        destruct (A_decode_pf _ _ _ _ _ _ _ _ _ H Ppredh Heqp0 Heqp2) as [? [? ?]]; subst.
        destruct (A_halt_dec a); inversion Pdec; subst; intuition. }
      { rewrite Heqp1 in Pdec.
        destruct (A_decode (transform b0 ext0) c0) as [[? ?] ?] eqn: ?.
        destruct (A_halt_dec a); inversion Pdec; subst; clear Pdec.
        destruct (A_decode_pf _ _ _ _ _ _ _ _ _ H Ppredh Heqp0 Heqp2) as [? [? ?]]; intuition.
        destruct (A_decode_pf _ _ _ _ _ _ _ _ _ H Ppredh Heqp0 Heqp2) as [? [? ?]]; congruence. } }
    { destruct fuel as [| fuel']; try solve [ exfalso; intuition; inversion PPredlen ].
      destruct (getE env (a :: l)) eqn: ?.
      { destruct (P_predicate_dec p).
        { destruct (X_encode true env) eqn: ?.
          destruct (P_encode p c) eqn: ?. simpl in *.
          destruct (X_decode (transform bin' ext0) env') as [[? ?] ?] eqn: ?.
          destruct (P_decode (transform b0 ext0) c1) as [[? ?] ?] eqn: ?.
          inversion Penc; subst; clear Penc.
          rewrite <- transform_assoc in Heqp2.
          destruct (X_decode_pf _ _ _ _ _ _ _ _ _ Eeq I Heqp1 Heqp2) as [? [? ?]]; subst.
          destruct (P_decode_pf _ _ _ _ _ _ _ _ _ H p0 Heqp0 Heqp3) as [? [? ?]]; subst.
          eapply get_correct in Heqo; eauto.
          rewrite Heqp3, Heqo in Pdec.
          inversion Pdec; subst; eauto. }
        { destruct (X_encode false env) eqn: ?.
          destruct (A_encode a c) eqn: ?.
          destruct (encode_list_step l c0) eqn: ?. simpl in *.
          inversion Penc; subst; clear Penc.
          destruct (X_decode (transform (transform (transform b b0) b1) ext0) env')
            as [[? ?] ?] eqn: ?.
          rewrite <- !transform_assoc in Heqp3.
          destruct (X_decode_pf _ _ _ _ _ _ _ _ _ Eeq I Heqp0 Heqp3) as [? [? ?]]; subst.
          destruct (A_decode (transform b0 (transform b1 ext0)) c2) as [[? ?] ?] eqn: ?.
          destruct (A_decode_pf _ _ _ _ _ _ _ _ _ H (proj1 (PPredA _ (or_introl eq_refl)))
                                Heqp1 Heqp4) as [? [? ?]]; subst.
          destruct (A_halt_dec a0).
          { inversion Pdec; subst; clear Pdec.
            exfalso. specialize (PPredA _ (or_introl eq_refl)). intuition congruence. }
          { destruct (decode'_list_step fuel' (transform b1 ext0) c3) as [[? ?] ?] eqn: ?.
            inversion Pdec; subst; clear Pdec.
            destruct (IHl (fun x H => PPredA x (or_intror H)) _ _ _ _ _ _ _ H0 Heqp2 _
                          (Le.le_S_n _ _ PPredlen) _ Heqp5) as [? [? ?]]; subst.
            intuition eauto.
            erewrite peek_correct; eauto.
            eapply add_correct; eauto. } } }
      { destruct (X_encode false env) eqn: ?.
        destruct (A_encode a c) eqn: ?.
        destruct (encode_list_step l c0) eqn: ?. simpl in *.
        inversion Penc; subst; clear Penc.
        destruct (X_decode (transform (transform (transform b b0) b1) ext0) env')
          as [[? ?] ?] eqn: ?.
        rewrite <- !transform_assoc in Heqp2.
        destruct (X_decode_pf _ _ _ _ _ _ _ _ _ Eeq I Heqp Heqp2) as [? [? ?]]; subst.
        destruct (A_decode (transform b0 (transform b1 ext0)) c2) as [[? ?] ?] eqn: ?.
        destruct (A_decode_pf _ _ _ _ _ _ _ _ _ H (proj1 (PPredA _ (or_introl eq_refl)))
                              Heqp0 Heqp3) as [? [? ?]]; subst.
        destruct (A_halt_dec a0).
        { inversion Pdec; subst; clear Pdec.
          exfalso. specialize (PPredA _ (or_introl eq_refl)). intuition congruence. }
        { destruct (decode'_list_step fuel' (transform b1 ext0) c3) as [[? ?] ?] eqn: ?.
          inversion Pdec; subst; clear Pdec.
          destruct (IHl (fun x H => PPredA x (or_intror H)) _ _ _ _ _ _ _ H0 Heqp1 _
                        (Le.le_S_n _ _ PPredlen) _ Heqp4) as [? [? ?]]; subst.
          intuition eauto.
          erewrite peek_correct; eauto.
          eapply add_correct; eauto. } } }
  Qed. *)
End SteppingList.


Require Import Fiat.QueryStructure.Automation.MasterPlan.

Definition VALUE := "VALUE".
Definition MEASUREMENT_TYPE := "MEASUREMENT_TYPE".
Definition TIME := "TIME".
Definition CELL_ID := "CELL_ID".

Definition STATE := "STATE".
Definition AREA_CODE := "AREA_CODE".
Definition DETAILS := "DETAILS".
Definition DAY := "DAY".

Definition WIND := 0.
Definition HUMIDITY := 1.
Definition TEMPERATURE := 2.
Definition PRESSURE := 3.

Definition MEASUREMENTS := "MEASUREMENTS".
Definition CELLS := "CELLS".

Definition MeasurementType := nat.
Definition AreaCode        := nat.
Definition State           := string.

Definition WeatherSchema :=
  Query Structure Schema
    [ relation CELLS has
              schema <CELL_ID :: nat,
                      STATE :: State,
                      AREA_CODE :: nat,
                      DETAILS :: string>
              where attributes [STATE] depend on [AREA_CODE]; (* second clause? *)
      relation MEASUREMENTS has
              schema <CELL_ID :: nat,
                      VALUE :: Z,
                      MEASUREMENT_TYPE :: MeasurementType,
                      DAY :: nat,
                      TIME :: nat> ]
    enforcing [attribute CELL_ID for MEASUREMENTS references CELLS].

(* Try with three tables (distribution of areas per state) *)

Definition Init := "Init".
Definition AddCell := "AddCell".
Definition AddMeasurement := "AddMeasurement".
Definition CountCells := "CountCells".
Definition LocalMax := "LocalMax".

Definition WeatherSig : ADTSig :=
  ADTsignature {
      Constructor Init      : rep,
      Method AddCell        : rep * (WeatherSchema#CELLS)        -> rep * bool,
      Method AddMeasurement : rep * (WeatherSchema#MEASUREMENTS) -> rep * bool,
      Method CountCells     : rep * AreaCode                        -> rep * nat,
      Method LocalMax       : rep * AreaCode * MeasurementType    -> rep * (option Z)
    }.

Definition WeatherSpec : ADT WeatherSig :=
  Eval simpl in
    Def ADT {
    rep := QueryStructure WeatherSchema,

    Def Constructor0 Init : rep := empty,,

    Def Method1 AddCell (r : rep) (cell : WeatherSchema#CELLS) : rep * bool :=
      Insert cell into r!CELLS,

    Def Method1 AddMeasurement (r : rep) (measurement : WeatherSchema#MEASUREMENTS) : rep * bool :=
      Insert measurement into r!MEASUREMENTS,

    Def Method1 CountCells (r : rep) (area : AreaCode) : rep * nat :=
      cnt <- Count (For (cell in r!CELLS)
                        Where (area = cell!AREA_CODE)
                        Return 1);
    ret (r, cnt),

    Def Method2 LocalMax (r : rep) (areaC : AreaCode) (measType : MeasurementType) : rep * (option Z) :=
      max <- MaxZ (For (cell in r!CELLS) (measurement in r!MEASUREMENTS)
            Where (cell!AREA_CODE = areaC)
            Where (measurement!MEASUREMENT_TYPE = measType)
            Where (cell!CELL_ID = measurement!CELL_ID)
            Return measurement!VALUE);
    ret (r, max)
}%methDefParsing.

Definition SharpenedWeatherStation :
  FullySharpened WeatherSpec.
Proof.

  (* Uncomment this to see the mostly sharpened implementation *)
  (* partial_master_plan EqIndexTactics. *)
  master_plan EqIndexTactics.

Time Defined.

Time Definition WeatherStationImpl : ComputationalADT.cADT WeatherSig :=
  Eval simpl in projT1 SharpenedWeatherStation.
Print WeatherStationImpl.


Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Merges.List.List.
Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.

Module Type Var.
 Variable Var   : Set.
 Variable VarEqDec : EqDec Var.
End Var.

Module Type Label.
 Variable Label      : Set.
End Label.

Module Goto (V : Var) (L : Label).
 Section Goto.
  Definition Value := nat.
  Definition Heap := Map V.Var Value.
  Definition Pred := Heap -> Prop.

  Let varUpdate := Map.update V.Var Value V.VarEqDec.
  Let predUpdate v f (p : Pred)
    := fun s => p (varUpdate v (f (s v)) s).
  Hint Unfold predUpdate.

  Let predImplies (p1 p2 : Pred)
    := forall s, p1 s -> p2 s.
  Hint Unfold predImplies.

  Inductive Instr : Type :=
     IInc : V.Var -> Instr
   | IDec : V.Var -> Instr
  .
  Hint Constructors Instr.

  Let InstrPre (i : Instr) (post : Pred) : Pred :=
   match i with
   | IInc v => predUpdate v (fun n => S n)    post
   | IDec v => predUpdate v (fun n => pred n) post
   end.
  Hint Unfold InstrPre.

  Inductive Block : Type :=
     BlockJump : L.Label -> Instr -> Block
   | BlockJZ   : V.Var -> L.Label -> L.Label -> Block
   | BlockExit : Block.
  Hint Constructors Block.

  Variable Blocks : L.Label -> Block.
  Variable LabelPre  : L.Label -> Pred.

  Definition BlockPre (l : L.Label) (b : Block) : Prop :=
    match b with
     | BlockJump l' i
     => predImplies (LabelPre l) (InstrPre i (LabelPre l'))
     /\ predImplies (InstrPre i (LabelPre l')) (LabelPre l')

     | BlockJZ v lz lnz
     => predImplies (fun s => LabelPre l s /\ s v  = 0) (LabelPre lz)
     /\ predImplies (fun s => LabelPre l s /\ s v <> 0) (LabelPre lnz)

     | BlockExit
     => True
    end.
  Hint Unfold BlockPre.

  Hypothesis BlocksPre: forall l, BlockPre l (Blocks l).

  Inductive EvalI : Heap -> Instr -> Heap -> Prop :=
   | EvalIInc v s
      : EvalI s (IInc v) (varUpdate v (S (s v)) s)
   | EvalIDec v s
      : EvalI s (IDec v) (varUpdate v (pred (s v)) s).
  Hint Constructors EvalI.

  Inductive EvalB : Heap -> L.Label -> Heap -> L.Label -> Prop :=
   | EvalBJump l l' i s s'
      : Blocks l = BlockJump l' i
     -> EvalI s i s'
     -> EvalB s l s' l'
   | EvalBJZ'Z v l lz lnz s
      : Blocks l = BlockJZ v lz lnz
     -> s v = 0
     -> EvalB s l s lz
   | EvalBJZ'NZ v l lz lnz s
      : Blocks l = BlockJZ v lz lnz
     -> s v <> 0
     -> EvalB s l s lnz.
  Hint Constructors EvalB.

  Theorem EvalI_Hoare i s s' post
   (hPre : InstrPre i post s)
   (hEvI : EvalI s i s')
         : post s'.
  Proof.
   induction~ hEvI.
  Qed.

  Theorem BlockPre_Get l b
    : Blocks l = b
   -> BlockPre l b.
  Proof.
    intros.
    rewrite <- H.
    apply BlocksPre.
  Qed.
  Hint Immediate BlockPre_Get.

  Theorem EvalB_Hoare l l' s s'
   (hPre : LabelPre l s)
   (hEvB : EvalB s l s' l')
         : LabelPre l' s'.
  Proof.
   induction~ hEvB;
    destructs~ (BlockPre_Get H).
    eapply EvalI_Hoare; eauto.
  Qed.

  Inductive EvalBs : Heap -> L.Label -> Heap -> L.Label -> Prop :=
   | EvalBs0 l s
      : Blocks l = BlockExit
     -> EvalBs s l s l
   | EvalBs1 l s l' s' l'' s''
      : EvalB  s l s' l'
     -> EvalBs s' l' s'' l''
     -> EvalBs s l s'' l''.
  Hint Constructors EvalB.

  Theorem EvalBs_Hoare l l' s s'
   (hPre : LabelPre l s)
   (hEvB : EvalBs s l s' l')
         : LabelPre l' s'.
  Proof.
   induction~ hEvB.
    apply EvalB_Hoare in H; eauto.
  Qed.
 End Goto.
End Goto.

Module Type Program (V : Var) (L : Label).
  Module G := Goto V L.
  Parameter Blocks : L.Label -> G.Block.
  Parameter LabelPre  : L.Label -> G.Pred.
  Conjecture BlocksPre: forall l, G.BlockPre LabelPre l (Blocks l).
End Program.

Module Nowt (V : Var) (L : Label).
  Parameter v : V.Var.
  Module P' <: Program V L.
    Module G := Goto V L.
    Definition Blocks (l : L.Label) :=
      G.BlockJump l (G.IInc v).
    Definition LabelPre (_ : L.Label) (_ : G.Heap) := True.
    Theorem BlocksPre : forall l, G.BlockPre LabelPre l (Blocks l).
      simpls;
      intros; splits; eauto.
    Qed.
  End P'.
End Nowt.


(*
 * © 2019 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From SPICY Require Import
     MyPrelude.

From Frap Require Import
     Sets
     Invariant
.

From Frap Require Export Invariant.

Set Implicit Arguments.

Module Foo <: EMPTY.
End Foo.
Module Import SN := SetNotations(Foo).

Definition oneStepClosure_current {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st, invariant1 st
             -> invariant2 st.

Definition oneStepClosure_new {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st st', invariant1 st
                 -> sys.(Step) st st'
                 -> invariant2 st'.

Definition oneStepClosure {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  oneStepClosure_current sys invariant1 invariant2
  /\ oneStepClosure_new sys invariant1 invariant2.

Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
  (forall st, inv1 st -> inv2 st)
  -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
  -> oneStepClosure sys inv1 inv2.
Proof.
  unfold oneStepClosure; tauto.
Qed.

Theorem oneStepClosure_done : forall state (sys : trsys state) (invariant : state -> Prop),
  (forall st, sys.(Initial) st -> invariant st)
  -> oneStepClosure sys invariant invariant
  -> invariantFor sys invariant.
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new.
  intuition eauto using invariant_induction.
Qed.

Inductive multiStepClosure {state} (sys : trsys state)
  : (state -> Prop) -> (state -> Prop) -> (state -> Prop) -> Prop :=
| MscDone : forall inv,
    (* oneStepClosure sys inv inv *)
    multiStepClosure sys inv ({ }) inv (* enforce worklist is empty and delete premise *)
| MscStep : forall inv worklist inv' inv'',
    oneStepClosure sys worklist inv'
    (* -> (forall st st', (inv \setminus worklist) st -> sys.(Step) st st' -> inv' st') *)
    -> multiStepClosure sys (inv \cup inv') (inv' \setminus inv) inv''
    -> multiStepClosure sys inv worklist inv''.

(* add extra hypothesis that says : (inv \ wl) o step \incl inv *)
Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv worklist inv' : state -> Prop),
    multiStepClosure sys inv worklist inv'
    -> forall wl,
        (forall st, sys.(Initial) st -> inv st)
      -> wl = worklist
      -> (forall st st', (inv \setminus wl) st -> sys.(Step) st st' -> inv st')
      -> invariantFor sys inv'.
Proof.
  induction 1; simpl; intros.
  - eapply invariant_induction; subst; sets idtac; eauto.
  - subst.
    eapply IHmultiStepClosure; intros; eauto.
    + apply H1 in H2; sets idtac.
    + assert (inv st) by (sets idtac).
      unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new in H; destruct H.
      sets idtac.
      * assert (worklist st \/ ~ worklist st) as WL by sets idtac; destruct WL; eauto.
      * assert (worklist st \/ ~ worklist st) as WL by sets idtac; destruct WL; eauto.
Qed.

Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
  multiStepClosure sys sys.(Initial) sys.(Initial) inv
  -> invariantFor sys inv.
Proof.
  intros.
  eapply multiStepClosure_ok'; eauto.
  intros.
  sets idtac.
Qed.

Theorem oneStepClosure_empty : forall state (sys : trsys state),
  oneStepClosure sys (constant nil) (constant nil).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; intuition.
Qed.

Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
  (forall st', sys.(Step) st st' -> inv1 st')
  -> oneStepClosure sys (constant sts) inv2
  -> oneStepClosure sys (constant (st :: sts)) (constant (st :: nil) \cup inv1 \cup inv2).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; intuition.

  inversion H0; subst.
  unfold union; simpl; tauto.

  unfold union; simpl; eauto.

  unfold union in *; simpl in *.
  intuition (subst; eauto).
Qed.

Theorem singleton_in : forall {A} (x : A) rest,
  (constant (x :: nil) \cup rest) x.
Proof.
  unfold union; simpl; auto.
Qed.

Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
  s2 x
  -> (s1 \cup s2) x.
Proof.
  unfold union; simpl; auto.
Qed.


Require Import POCS.
Require Import VariablesAPI.
Require Import StatDbAPI.

(** * An implementation of StatDB

   StatDB is built on top of the Variables API, which maintains two variables
   [VarCount] and [VarSum]. StatDB reads and writes these two variables using
   the API provided in the VarsAPI module. [VarCount] stores the number of
   integers that [VarSum] sums up. The mean is just [VarSum]/[VarCount].

  *)

Module StatDB (v : VarsAPI) <: StatDbAPI.

  Import ListNotations.

  Definition add (v : nat) : proc unit :=
    sum <- v.read VarSum;
    count <- v.read VarCount;
    _ <- v.write VarSum (sum + v);
    _ <- v.write VarCount (count + 1);
    Ret tt.

  (** ** Exercise : complete the implementation of mean *)
  Definition mean : proc (option nat) :=
    Ret None.

  Definition init' : proc InitResult :=
    _ <- v.write VarCount 0;
    _ <- v.write VarSum 0;
    Ret Initialized.

  Definition init := then_init v.init init'.

  Definition recover : proc unit :=
    v.recover.

  (** ** Exercise : complete the implementation of the abstraction function: *)
  Definition statdb_abstraction (vars_state : VariablesAPI.State) (statdb_state : StatDbAPI.State) : Prop :=
    True.

  Definition abstr : Abstraction StatDbAPI.State :=
    abstraction_compose
      v.abstr
      {| abstraction := statdb_abstraction |}.

  Example abstr_1_ok : statdb_abstraction (VariablesAPI.mkState 0 0) nil.
  Proof. unfold statdb_abstraction; auto. Qed.

  (** ** Exercise : complete the proof for the following admitted examples *)
  Example abstr_2_nok : ~ statdb_abstraction (VariablesAPI.mkState 1 0) nil.
  Proof.
    unfold statdb_abstraction; simpl.
  Admitted.

  Example abstr_3_ok : statdb_abstraction (VariablesAPI.mkState 2 3) [1; 2].
  Proof.
    unfold statdb_abstraction; simpl.
  Admitted.

  Theorem init_ok : init_abstraction init recover abstr inited.
  Proof.
    eapply then_init_compose; eauto.
    unfold init'.

    step_proc_basic; intros.
    exists tt.
    simpl; intuition idtac.

    step_proc_basic; intros.
    exists tt.
    simpl; intuition idtac.

    step_proc_basic; intros.
    eauto.

    simpl in *; intuition subst.
    exists nil.
    unfold statdb_abstraction, inited.
    intuition auto.
  Qed.

  (** ** Exercise : complete the proof of [add] *)
  Theorem add_ok : forall v, proc_spec (add_spec v) (add v) recover abstr.
  Proof.
    unfold add.
    intros.

    apply spec_abstraction_compose; simpl.
  Admitted.

  (** ** Exercise : complete the proof of [mean] *)
  Theorem mean_ok : proc_spec mean_spec mean recover abstr.
  Proof.
    unfold mean.
    intros.

    apply spec_abstraction_compose; simpl.

  Admitted.

  Theorem recover_noop : rec_noop recover abstr no_crash.
  Proof.
    unfold rec_noop.
    intros.

    apply spec_abstraction_compose; simpl.
    step_proc_basic; intros.
    eauto.

    destruct a; simpl in *.
    intuition.
    eauto.
  Qed.

End StatDB.

Require Import VariablesImpl.
Module StatDBImpl := StatDB Vars.
Print Assumptions StatDBImpl.abstr_2_nok.
Print Assumptions StatDBImpl.abstr_3_ok.
Print Assumptions StatDBImpl.add_ok.
Print Assumptions StatDBImpl.mean_ok.


Require Export P02.

(* You can use SearchTree'_le, expand_range_SearchTree'. *)
Lemma insert_SearchTree: forall x vx s,
    SearchTree s -> SearchTree (insert x vx s).
Proof. exact FILL_IN_HERE. Qed.


(** * Coproduct of natural transformations *)
Require Import Category.Sum Functor.Sum NaturalTransformation.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Section sum.
  Definition sum
             C C' D F G F' G'
             (T : @NaturalTransformation C D F G)
             (T' : @NaturalTransformation C' D F' G')
  : NaturalTransformation (F + F') (G + G').
  Proof.
    refine (Build_NaturalTransformation
              (F + F') (G + G')
              (fun x => match x with
                          | Datatypes.inl c => T c
                          | Datatypes.inr c' => T' c'
                        end)
              _).
    abstract (
        repeat (intros [] || intro); simpl;
        auto with natural_transformation
      ).
  Defined.
End sum.

Module Export NaturalTransformationSumNotations.
  Notation "T + U" := (sum T U) : natural_transformation_scope.
End NaturalTransformationSumNotations.


Require Import ZArith.
(*Require Import Coq.Strings.String.*)
Require Import List. Import ListNotations.
Require Import NPeano.

From QuickChick Require Import QuickChick.

Require Import TestingCommon.
Require Import Indist.

Local Open Scope nat.
Local Open Scope list.

(* CH: old stuff about sets of prins
Powerset returns the set as its first element, so ignore that
Definition shrinkLabel l :=
    match powerset (Zset.elements l) with
      | [[]] => nil
      | _::t => map lab_of_list t
      | _    => nil
    end.
*)
Definition shrinkLabel l :=
  match l with
  | L       => []
  | M1 | M2 => [L]
  | H       => [L;M1;M2]
  end.

Definition shrinkBinop (b : BinOpT) : list BinOpT := nil.
Definition shrinkInstr (i : @Instr Label) : list (@Instr Label) :=
  match i with
    | Nop => nil
    | PutLab l r =>
      List.map (fun l' => PutLab l' r) (shrinkLabel l) ++ [Nop]
    | _ => [Nop]
  end.

Definition shrinkPointer (p : Pointer) : list Pointer :=
  let '(Ptr mf i) := p in
  List.map (Ptr mf) (shrink i).

Definition shrinkValue (v : Value) : list Value :=
  match v with
    | Vint i => List.map Vint (shrink i)
    | Vptr p => Vint Z0 :: List.map Vptr (shrinkPointer p)
    | Vlab l => Vint Z0 :: List.map Vlab (shrinkLabel l)
  end.

Definition shrinkAtom (a : Atom) : list Atom :=
  let '(Atm val lab) := a in
  List.map (flip Atm lab) (shrinkValue val)
  ++  List.map (Atm val) (shrinkLabel lab).

Fixpoint noopShrink (n : nat) (l : Label) (l1 l2 : list (@Instr Label))
: list (@Variation (list (@Instr Label))) :=
  match n with
    | S n' =>
      match List.nth n' l1 Nop, List.nth n' l2 Nop with
        | Nop, Nop =>
          noopShrink n' l l1 l2
        | _, _ =>
          match update_list_Z l1 (Z.of_nat n') Nop, update_list_Z l2 (Z.of_nat n') Nop with
            | Some l1', Some l2' => cons (Var l l1' l2')
                                         (noopShrink n' l l1 l2)
            | _, _ => noopShrink n' l l1 l2
          end
      end
    | _ => nil
  end.

Fixpoint noopRemove (l : Label) (l1 l2 : list (@Instr Label))
         (acc1 acc2 : list (@Instr Label)) :=
  match l1, l2 with
    | Nop :: t1, Nop :: t2 =>
      (Var l (rev_append acc1 t1)) (rev_append acc2 t2)
      :: (noopRemove l t1 t2 (Nop :: acc1) (Nop :: acc2))
    | h1 :: t1, h2 :: t2 =>
      noopRemove l t1 t2 (h1 :: acc1) (h2 :: acc2)
    | _, _ => nil
  end.

Instance shrVVal : ShrinkV Value :=
{|
  shrinkV vv :=
    match vv with
      | Var lab (Vint i) (Vint _) =>
        List.map (fun i => Var lab (Vint i) (Vint i)) (shrink i)
      | Var lab (Vptr p) (Vptr _) =>
        List.map (fun p => Var lab (Vptr p) (Vptr p)) (shrinkPointer p)
      | Var lab (Vlab l) (Vlab _) =>
        List.map (fun l => Var lab (Vlab l) (Vlab l)) (shrinkLabel l)
      | _ => nil
    end
|}.

Definition shrinkVLabeled {A B : Type} (c : B -> Label -> A) (b b' : B)
           (l lab : Label) : list (@Variation A) :=
  flat_map (fun ls =>
    if flows ls lab then
      [Var lab (c b ls) (c b ls);
       Var lab (c b' ls) (c b' ls)]
    else
      [Var lab (c b ls) (c b' ls)]
  ) (shrinkLabel l).

Instance shrVAtom : ShrinkV Atom :=
{|
  shrinkV va :=
    let '(Var lab (Atm v l) (Atm v' l')) := va in
    if flows l lab then
      List.map (fun v => let '(Var _ v1 v2) := v in
                    Var lab (Atm v1 l) (Atm v2 l')) (shrinkV (Var lab v v'))
    else
      let a1s := List.map (fun v1 => Atm v1 l) (shrinkValue v)  in
      let a2s := List.map (fun v2 => Atm v2 l) (shrinkValue v') in
      List.map (fun a => Var lab a (Atm v' l')) a1s ++
      List.map (fun a' => Var lab (Atm v l) a') a2s ++
      concat (List.map (fun a => List.map (fun a' => Var lab a a') a2s) a1s)
    ++ shrinkVLabeled Atm v v' l lab
|}.

Fixpoint shrink_datas (lab : Label) (ds ds' : list Atom) :=
  match ds, ds' with
    | h1 :: t1, h2 :: t2 =>
      Var lab t1 t2 ::
      List.map (fun x => let '(Var _ h1' h2') := x in
                    Var lab (h1':: t1) (h2'::t2)) (shrinkV (Var lab h1 h2))
      ++ List.map (fun x => let '(Var _ t1' t2') := x in
                       Var lab (h1::t1') (h2::t2')) (shrink_datas lab t1 t2)
    | _, _ => nil
  end.

Definition shrinkListAtom := shrinkListAux shrinkAtom.

(* Probably need to revisit this *)
Instance shrVFrame : ShrinkV frame :=
{|
  shrinkV vf :=
    let '(Var obs (Fr lab data1) (Fr lab2 data2)) := vf in
    if isLow lab obs then
      List.map (fun x => let '(Var _ ds1 ds2) := x in
                    Var lab (Fr lab ds1) (Fr lab2 ds2))
          (shrink_datas obs data1 data2)
    else
      List.map (fun data1' => Var lab (Fr lab data1') (Fr lab2 data2))
          (shrinkListAtom data1) ++
      List.map (fun data2' => Var lab (Fr lab data1) (Fr lab2 data2'))
          (shrinkListAtom data2)
|}.

(*
Fixpoint liftFrameMem (mf : mframe) (l : Label) (m1 m2 : mem)
         (lf : list (@Variation Frame)) :=
  match lf with
    | [] => []
    | (Var lab f1' f2') :: t =>
      match update_frame m1 mf f1', update_frame m2 mf f2' with
        | Some m1', Some m2' => (Var lab m1' m2')
                                  :: (liftFrameMem mf l m1 m2 t)
        | _, _ => liftFrameMem mf l m1 m2 t
      end
  end.

Fixpoint shr_v_mem (lim : nat) (mf : mframe) (l : Label) (m1 m2 : mem) :=
  match lim with
    | O => nil
    | S lim' =>
      match load_frame m1 mf, load_frame m2 mf with
        | Some f1, Some f2 =>
          app (liftFrameMem mf l m1 m2 (shrinkV (Var l f1 f2)))
                 (shr_v_mem lim' (Zsucc mf) l m1 m2)
        | _, _ => nil
      end
  end.

Instance shrVMem : ShrinkV mem :=
{|
  shrinkV vm :=
    match vm with
      | Var lab m1 m2 =>
        app (shr_v_mem 42 Z0 lab m1 m2)
            nil
    end
|}.
*)
(* CH: removed this crap
Fixpoint stackLength (s : Stack) :=
  match s with
    | Mty => 0
    | RetCons _ s' => 1 + stackLength s'
  end.

Function shrink_stacks (lab : Label) (sp : Stack * Stack )
         {measure (fun sp => stackLength (fst sp) + stackLength (snd sp)) sp}:=
  (* TODO: Think about shrinking individual stack info *)
  let (s1, s2) := sp in
  match s1, s2 with
    | RetCons h1 t1, RetCons h2 t2 =>
      let '(pc1, _ , _ , _ ) := h1 in
      let '(pc2, _ , _ , _ ) := h2 in
      if flows (pc_lab pc1) lab && flows (pc_lab pc2) lab then
        (* Both are low *)
        flat_map (fun vt => let '(Var lab t1' t2') := vt in
                            [ Var lab (RetCons h1 t1') (RetCons h2 t2') ;
                              Var lab t1' t2' ])
                 (shrink_stacks lab (t1, t2))
      else if flows (pc_lab pc1) lab then
        (* Mach 2 is high *)
        shrink_stacks lab (s1, t2)
      else
        (* Mach 1 is high *)
        shrink_stacks lab (t1, s2)
    | _, _ => nil
  end.
Proof.
intros; unfold fst; unfold snd; unfold stackLength; simpl; omega.
intros; unfold fst; unfold snd; unfold stackLength; simpl; omega.
intros; unfold fst; unfold snd; unfold stackLength; simpl; omega.
Defined.
*)

Instance shrVStack : ShrinkV Stack :=
{|
  shrinkV vs := []
(*
    let '(Var lab s1 s2) := vs in p
    shrink_stacks lab (s1, s2)
*)
|}.

(*
Fixpoint liftMemSState (st1 st2 : SState) (lm : list (@Variation mem)) :=
  match st1, st2 with
    | St _ p1 s1 regs1 pc1, St _ p2 s2 regs2 pc2 =>
      match lm with
        | nil => nil
        | cons (Var lab m1' m2') t =>
          cons (Var lab (St m1' p1 s1 regs1 pc1) (St m2' p2 s2 regs2 pc2))
               (liftMemSState st1 st2 t)
      end
  end.
*)

Fixpoint liftStackSState (st1 st2 : SState) (ls : list (@Variation Stack)) :=
  match st1, st2 with
    | St im1 m1 _ regs1 pc1, St im2 m2 _ regs2 pc2 =>
      match ls with
        | nil => nil
        | cons (Var lab s1' s2') t =>
          cons (Var lab (St im1 m1 s1' regs1 pc1) (St im2 m2 s2' regs2 pc2))
               (liftStackSState st1 st2 t)
      end
  end.

(*
Definition shrinkSStateMemory (v : @Variation SState) :=
  let '(Var lab st1 st2) := v   in
  let '(St _ m  p  s  regs1 pc ) := st1 in
  let '(St _ m' p' s' regs2 pc') := st2 in
  liftMemSState st1 st2 (shrinkV (Var lab m m')).
*)

Definition shrinkSStateStack (v : @Variation SState) :=
  let '(Var lab st1 st2) := v in
  let '(St _ _ s  _ _) := st1 in
  let '(St _ _ s' _ _) := st2 in
  liftStackSState st1 st2 (shrinkV (Var lab s s')).

Definition shrinkSState x :=
  (* shrinkSStateMemory x ++ *) shrinkSStateStack x.

Definition cDecr (lim r : regId) :=
  if (lim <=? r)%Z then (r - 1)%Z else r.

Definition decrRegInstr (r : regId) (i : @Instr Label) :=
  match i with
  | Lab r1 r2 => Lab (cDecr r r1) (cDecr r r2)
  | MLab r1 r2 => MLab (cDecr r r1) (cDecr r r2)
  | PcLab r1 => PcLab (cDecr r r1)
  | BCall r1 r2 r3 => BCall (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | BRet => BRet
  | PutLab l r1 => PutLab l (cDecr r r1)
  | Nop => Nop
  | Put n r1 => Put n (cDecr r r1)
  | BinOp o r1 r2 r3 => BinOp o (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | Jump r1 => Jump (cDecr r r1)
  | BNZ n r1 => BNZ n (cDecr r r1)
  | Load r1 r2 => Load (cDecr r r1) (cDecr r r2)
  | Store r1 r2 => Store (cDecr r r1) (cDecr r r2)
  | Write r1 r2 => Write (cDecr r r1) (cDecr r r2)
  | Alloc r1 r2 r3 => Alloc (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | PSetOff r1 r2 r3 => PSetOff (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | Halt => Halt
  | MSize r1 r2 => MSize (cDecr r r1) (cDecr r r2)
  | PGetOff r1 r2 => PGetOff (cDecr r r1) (cDecr r r2)
  | Mov r1 r2 => Mov (cDecr r r1) (cDecr r r2)
  end.

(* TODO
Fixpoint decrRegInFrames (m : mem) (fs : list mframe) (r : regId) :=
  match fs with
    | []   => m
    | h::t =>
      match load_frame m h with
        | Some (CFR is) =>
          match update_frame m h (CFR (map (decrRegInstr r) is)) with
            | Some m' =>
              decrRegInFrames m' t r
            | _ => decrRegInFrames m t r
          end
        | _ => decrRegInFrames m t r
      end
end.

Definition removeReg (st : SState) (r : regId) :=
  let '(St m p s rs pc) := st in
  let rn := Z.to_nat r in
  let rsHd := firstn rn rs in
  let rsTl := skipn (S rn) rs in
  St (decrRegInFrames m (allocated m) r) p s (rsHd ++ rsTl) pc.
*)
Fixpoint shrinkVRegContents (l : Label) (prev prev' rest rest' : regSet)
: list (@Variation regSet) :=
  match rest, rest' with
    | h1 :: t1, h2 :: t2 =>
      let shrunk := shrinkV (Var l h1 h2) in
      List.map (fun v' =>
        let '(Var _ h1' h2') := v' in
        Var l (rev_append prev  (h1'::t1))
              (rev_append prev' (h2'::t2))
      ) shrunk ++ shrinkVRegContents l (h1 :: prev) (h2 :: prev') t1 t2

    | _, _ => nil
  end.

Fixpoint liftRegsSState (st1 st2 : SState) (ls : list (@Variation regSet)) :=
  match st1, st2 with
    | St im1 m1 s1 _ pc1, St im2 m2 s2 _ pc2 =>
      match ls with
        | nil => nil
        | cons (Var lab regs1' regs2') t =>
          cons (Var lab (St im1 m1 s1 regs1' pc1) (St im2 m2 s2 regs2' pc2))
               (liftRegsSState st1 st2 t)
      end
  end.

Definition shrinkVRegs (v : @Variation SState) :=
    let '(Var l st st') := v in
    let '(St _ _ _ regs _) := st in
    let '(St _ _ _ regs' _) := st' in
(*    let regsNo := List.length regs - 1 in
    let allRegs := map Z.of_nat (seq 0 regsNo) in
    let sts  := map (removeReg st ) allRegs in
    let sts' := map (removeReg st') allRegs in
    map (fun x : (SState * SState) =>
           let (st1,st2) := x in Var l st1 st2) (combine sts sts') ++*)
    (liftRegsSState st st' (shrinkVRegContents l nil nil regs regs')).

Definition shrinkVSState (x : @Variation SState) :=
  shrinkSState x
(*  ++ concat (map shrinkSStateMemory (shrinkSStateMemory x))
  ++ concat (map shrinkSStateMemory (shrinkSStateStack x))
  ++ concat (map shrinkSStateStack  (shrinkSStateMemory x))*)
  ++ shrinkVRegs x.
(*
Definition shrinkObsVar v :=
    let '(V lab st st' mf fm1 fm2) := v in
    let x := obsVarToVar v in
    map (varToObsVar mf fm1 fm2) (shrinkVSState x).
*)


(** * Excerpt taken from Vellvm *)

From Coq Require Import
     Relations
     Morphisms.

From ITree Require Import
     ITree
     Eq.Eq
     Events.Exception
     ITreeFacts.

Require Import Paco.paco.

(* Definition currently used in Vellvm.
     A lot of wiggle room w.r.t. notions of equivalences over it, or even w.r.t
     the definition of its monadic operations.
     It is not quite a monad transformer (bind is not associative to the left)
 *)
Definition PropT (E: Type -> Type) (X: Type): Type :=
  itree E X -> Prop.

Definition eutt_closed {E X} (P: itree E X -> Prop): Prop :=
  Proper (eutt eq ==> iff) P.

Global Polymorphic Instance Eq1_PropT {E} : Eq1 (PropT E) :=
  fun a PA PA' =>
    (forall x y, x ≈ y -> (PA x <-> PA' y)) /\
    eutt_closed PA /\ eutt_closed PA'.

Global Instance Functor_Prop {E}
  : Functor.Functor (PropT E) :=
  {| Functor.fmap := fun A B f PA b => exists (a: itree E A), PA a /\ b = Functor.fmap f a |}.

Inductive Returns {E} {A: Type} (a: A) : itree E A -> Prop :=
| ReturnsRet: forall t, t ≈ Ret a -> Returns a t
| ReturnsTau: forall t u, t ≈ Tau u -> Returns a u -> Returns a t
| ReturnsVis: forall {X} (e: E X) (x: X) t k, t ≈ Vis e k -> Returns a (k x) -> Returns a t
.
Hint Constructors Returns: core.

Inductive interp_PropTF {E F} (h_spec : forall T, E T -> itree F T -> Prop)
          {R : Type} (RR : relation R) (sim : itree E R -> itree F R -> Prop)
  : itree' E R -> itree F R -> Prop :=
| Interp_PropT_Ret : forall r1 r2 (REL: RR r1 r2)
                       (t2 : itree F R)
                       (eq2 : t2 ≈ (Ret r2)),
    interp_PropTF h_spec RR sim (RetF r1) t2

| Interp_PropT_Tau : forall t1 t2 (HS: sim t1 t2), interp_PropTF h_spec RR sim (TauF t1) t2

| Interp_PropT_Vis : forall A (e : E A) (k1 : A -> itree E R)
                       (t2 : itree F R)
                       (ta :itree F A)  (k2 : A -> itree F R) (HTA: h_spec A e ta)
                       (eq2 : t2 ≈ (bind ta k2))
                       (HK : forall (a : A), Returns a ta ->  sim (k1 a) (k2 a)),
    interp_PropTF h_spec RR sim (VisF e k1) t2.

Hint Constructors interp_PropTF : core.

Lemma interp_PropTF_mono E F h_spec R RR  (t0 : itree' E R) (t1 : itree F R) sim sim'
      (IN : interp_PropTF h_spec RR sim t0 t1)
      (LE : sim <2= sim') :
  (interp_PropTF h_spec RR sim' t0 t1).
Proof.
  induction IN; eauto.
Qed.

Hint Resolve interp_PropTF_mono : paco.

Definition interp_PropT_ E F h_spec R RR sim (t0 : itree E R) (t1 : itree F R) :=
  interp_PropTF h_spec RR sim (observe t0) t1.
Hint Unfold interp_PropT_ : core.

Lemma interp_PropT__mono E F h_spec R RR : monotone2 (interp_PropT_ E F h_spec R RR).
Proof.
  do 2 red. intros. eapply interp_PropTF_mono; eauto.
Qed.
Hint Resolve interp_PropT__mono : paco.

Definition interp_prop {E F} (h_spec : E ~> PropT F) :
  forall R (RR: relation R), itree E R -> PropT F R :=
  fun R (RR: relation R) =>  paco2 (interp_PropT_ E F h_spec R RR) bot2.

Definition trigger_prop {E} : E ~> PropT E :=
  fun R e => fun t => t = trigger e.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e379m19_15limbs.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.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (mult lv1 lv2)) (plus Zero (plus (mult lv1 lv2) lv0))).
Admitted.
QuickChick conj19eqsynthconj1.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e291m19_11limbs.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.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus lv0 lv1) (plus (plus lv2 lv0) (mult lv3 lv2))).
Admitted.
QuickChick conj12synthconj6.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_4limbs.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.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv2 (plus lv0 lv1))).
Admitted.
QuickChick conj18synthconj1.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 lv2)) (plus (plus lv1 lv2) lv0)).
Admitted.
QuickChick conj14synthconj1.


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

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

Print Assumptions sub.


Require Import Paths Fibrations Contractible Equivalences Univalence Funext.

(** For compatibility with Coq 8.2. *)
Unset Automatic Introduction.

(** Here we prove that univalence implies function extensionality.  We
   keep this file separate from the statements of Univalence and
   Funext, since it has a tendency to produce universe
   inconsistencies.  With truly polymorphic universes this ought not
   to be a problem.

   Since this file makes the point that univalence implies funext,
   further development can avoid including this file and simply assume
   function extensionality as an axiom alongside univalence, in the
   knowledge that it is actually no additional requirement. *)

Section UnivalenceImpliesFunext.

  Hypothesis univalence : univalence_statement.

  Hypothesis eta_rule : eta_statement.

  (** Exponentiation preserves equivalences, i.e., if [w] is an
     equivalence then so is post-composition by [w]. *)

  Theorem equiv_exponential : forall {A B} (w : A <~> B) C,
    (C -> A) <~> (C -> B).
  Proof.
    intros A B w C.
    exists (fun h => w o h).
    generalize A B w.
    apply equiv_induction.
    assumption.
    intro D.
    apply (projT2 (eta_equiv eta_rule C D)).
  Defined.

  (** We are ready to prove functional extensionality, starting with the
     naive non-dependent version. *)

  Theorem univalence_implies_funext : funext_statement.
  Proof.
    intros A B f g p.
    (* It suffices to find a path [eta f == eta g]. *)
    apply equiv_injective with (w := eta_equiv eta_rule A B).
    simpl.
    (* Consider the following maps. *)
    pose (d := fun x : A => existT (fun xy => fst xy == snd xy) (f x, f x) (idpath (f x))).
    pose (e := fun x : A => existT (fun xy => fst xy == snd xy) (f x, g x) (p x)).
    (* If we compose [d] and [e] with [free_path_target], we get [eta
       f] and [eta g], respectively. So, if we had a path from [d] to
       [e], we would get one from [eta f] to [eta g]. *)
    pose (src_compose := equiv_exponential (free_path_source B) A).
    pose (trg_compose := equiv_exponential (free_path_target B) A).
    path_via (projT1 trg_compose e).
    path_via (projT1 trg_compose d).
    (* But we can get a path from [d] to [e] because [src o d = eta f
       = src o e] and composition with [src] is an equivalence. *)
    apply equiv_injective with (w := src_compose).
    apply idpath.
  Defined.

  (** Now we use this to prove weak funext, which as we know implies
     (with dependent eta) also the strong dependent funext. *)

  Theorem univalence_implies_weak_funext : weak_funext_statement.
  Proof.
    intros X P allcontr.
    assert (eqpt : @paths (X -> Type) (fun x => unit) P).
    apply univalence_implies_funext.
    intro x.
    apply opposite, equiv_to_path, contr_equiv_unit, allcontr.
    assumption.
    assert (contrunit : is_contr (forall x:X, unit)).
    exists (fun _ => tt).
    intro f.
    apply univalence_implies_funext.
    intro x.
    assert (alltt : forall y:unit, y == tt).
    induction y; apply idpath.
    apply alltt.
    exact (transport (P := fun Q: X -> Type => is_contr (forall x, Q x)) eqpt contrunit).
    (* Oh noes!  Universe inconsistency! *)
  Admitted.

End UnivalenceImpliesFunext.