(* in Coq 8.8.0 with "-no-is" *)

(* 除去規則が自動的に定義されるのを止める。 *)
Unset Elimination Schemes.

(* タクティックを使う。 *)
Declare ML Module "ltac_plugin".

(* 証明の仕方を設定する。 *)
Export Set Default Proof Mode "Classic".

(* 関数型の記法 *)
Notation "x -> y" := (forall (_ : x), y)
 (at level 99, right associativity, y at level 200)
.

(* 等式を表す型
  Haskellでの(:~:)に対応する。 *)
Inductive eq (A : Type) (a : A) : A -> Type :=
| eq_refl : eq A a a
.

(* eqの除去規則 *)
Definition eq_elim
 (A : Type) (x : A) (P : forall y : A, eq A x y -> Type)
 (c : P x (eq_refl A x)) (y : A) (p : eq A x y)
 : P y p
:=
 match p as p' in eq _ _ y' return P y' p' with
 | eq_refl _ _ => c
 end
.

Definition eq_elim_nodep
 (A : Type) (x : A) (P : A -> Type)
 (c : P x) (y : A) (p : eq A x y)
 : P y
:=
 eq_elim A x (fun y' _ => P y') c y p
.

Definition eq_sym
 (A : Type) (x y : A) (p : eq A x y) : eq A y x
:=
 eq_elim_nodep A x (fun y' => eq A y' x) (eq_refl A x) y p
.

Definition eq_trans
 (A : Type) (x y z : A) (p : eq A y z) (q : eq A x y) : eq A x z
.
Proof.
 refine (
  eq_elim_nodep A y (fun z' => eq A x z') _ z p
 ).
 refine (
  eq_elim_nodep A x (fun y' => eq A x y') _ y q
 ).
 refine (
  eq_refl A x
 ).
Defined.

(* Heteroな等式を表す型
  Haskellでの(:~~:)に対応する *)
Inductive JMeq (A : Type) (a : A) : forall B : Type, B -> Type :=
| JMeq_refl : JMeq A a A a
.

(* JMeqの除去規則 *)
Definition JMeq_elim
 (A : Type) (a : A) (P : forall (B : Type) (b : B), JMeq A a B b -> Type)
 (c : P A a (JMeq_refl A a)) (B : Type) (b : B) (p : JMeq A a B b)
 : P B b p
:=
 match p as p' in JMeq _ _ B' b' return P B' b' p' with
 | JMeq_refl _ _ => c
 end
.

Definition JMeq_elim_nodep
 (A : Type) (a : A) (P : forall (B : Type), B -> Type)
 (c : P A a) (B : Type) (b : B) (p : JMeq A a B b)
 : P B b
:=
 JMeq_elim A a (fun B' b' _ => P B' b') c B b p
.

Definition JMeq_sym
 (A B : Type) (a : A) (b : B) (p : JMeq A a B b) : JMeq B b A a
:=
 JMeq_elim_nodep A a (fun B' b' => JMeq B' b' A a) (JMeq_refl A a) B b p
.

Definition JMeq_trans
 (A B C : Type) (a : A) (b : B) (c : C) (p : JMeq B b C c) (q : JMeq A a B b)
 : JMeq A a C c
.
Proof.
 refine (
  JMeq_elim_nodep B b (fun C' c' => JMeq A a C' c') _ C c p
 ).
 refine (
  JMeq_elim_nodep A a (fun B' b' => JMeq A a B' b') _ B b q
 ).
 refine (
  JMeq_refl A a
 ).
Defined.

(* JMeqからeqを導く
  証明不可能で公理として追加するしかない。
  Coq.Logic.JMeq.JMeq_eqとしてライブラリに存在。 *)
Definition JMeq_eq
 (A : Type) (x y : A) (p : JMeq A x A y) : eq A x y
.
Proof.
Abort.

(* JMeqのeqのような依存無しの除去規則 *)
Definition JMeq_elim_eqlike_nodep
 (A : Type) (x : A) (P : A -> Type)
 (c : P x) (y : A) (p : JMeq A x A y)
 : P y
.
Proof.
Abort.

(* JMeqのeqのような除去規則 *)
Definition JMeq_elim_eqlike
 (A : Type) (x : A) (P : forall y : A, JMeq A x A y -> Type)
 (c : P x (JMeq_refl A x)) (y : A) (p : JMeq A x A y)
 : P y p
.
Proof.
Abort.

(* axiom UIP (UIP axiom, the axiom of uniqueness of identity proofs)
  全てのeqは等しいという公理。
  https://ncatlab.org/nlab/show/axiom+UIP *)
Definition UIP (A : Type) (x y : A) (p q : eq A x y) : eq (eq A x y) p q.
Proof.
Abort.

(* axiom K
  https://ncatlab.org/nlab/show/axiom+K+%28type+theory%29 *)
Definition K
 (A : Type) (x : A) (P : eq A x x -> Type)
 (c : P (eq_refl A x)) (p : eq A x x)
 : P p
.
Proof.
Abort.

(* UIPの等しい対象がeq_reflになったバージョン
  Kから簡単に導ける。
  http://adam.chlipala.net/cpdt/html/Equality.html (Heterogeneous Equality) *)
Definition UIP_refl
 (A : Type) (x : A) (p : eq A x x) : eq (eq A x x) (eq_refl A x) p
.
Proof.
Abort.

(* UIPをJMeqを使って定義したバージョン *)
Definition UIP' (A : Type) (x y : A) (p q : eq A x y) : JMeq (eq A x y) p (eq A x y) q.
Proof.
 refine (
  eq_elim
   A x (fun y' p' => JMeq (eq A x y') p' (eq A x y) q)
   _ y p
 ).
 refine (
  eq_elim
   A x (fun y' q' => JMeq (eq A x x) (eq_refl A x) (eq A x y') q')
   _ y q
 ).
 refine (
  JMeq_refl (eq A x x) (eq_refl A x)
 ).
Defined.

(* UIP_reflをJMeqで定義したバージョン *)
Definition UIP'_refl
 (A : Type) (x : A) (p : eq A x x) : JMeq (eq A x x) (eq_refl A x) (eq A x x) p
.
Proof.
 refine (
  eq_elim
   A x (fun x' p' => JMeq (eq A x x) (eq_refl A x) (eq A x x') p')
   _ x p
 ).
 refine (
  JMeq_refl (eq A x x) (eq_refl A x)
 ).
Defined.

Definition JMeq_UIP
 (A B : Type) (a : A) (b : B) (p q : JMeq A a B b) : eq (JMeq A a B b) p q
.
Proof.
Abort.

Definition JMeq_K
 (A : Type) (x : A) (P : JMeq A x A x -> Type)
 (c : P (JMeq_refl A x)) (p : JMeq A x A x)
 : P p
.
Proof.
Abort.

Definition JMeq_UIP_refl
 (A : Type) (x : A) (p : JMeq A x A x) : eq (JMeq A x A x) (JMeq_refl A x) p
.
Proof.
Abort.

Definition JMeq_UIP'
 (A B : Type) (a : A) (b : B) (p q : JMeq A a B b)
 : JMeq (JMeq A a B b) p (JMeq A a B b) q
.
Proof.
 refine (
  JMeq_elim
   A a (fun B' b' p' => JMeq (JMeq A a B' b') p' (JMeq A a B b) q)
   _ B b p
 ).
 refine (
  JMeq_elim
   A a (fun B' b' q' => JMeq (JMeq A a A a) (JMeq_refl A a) (JMeq A a B' b') q')
   _ B b q
 ).
 refine (
  JMeq_refl (JMeq A a A a) (JMeq_refl A a)
 ).
Defined.

Definition JMeq_UIP'_refl
 (A : Type) (x : A) (p : JMeq A x A x)
 : JMeq (JMeq A x A x) (JMeq_refl A x) (JMeq A x A x) p
.
Proof.
 refine (
  JMeq_elim
   A x (fun A' x' p' => JMeq (JMeq A x A x) (JMeq_refl A x) (JMeq A x A' x') p')
   _ A x p
 ).
 refine (
  JMeq_refl (JMeq A x A x) (JMeq_refl A x)
 ).
Defined.

(* eqからJMeqを導く *)
Definition eq_JMeq
 (A : Type) (x y : A) (p : eq A x y) : JMeq A x A y
:=
 eq_elim_nodep A x (fun y' => JMeq A x A y') (JMeq_refl A x) y p
.

(* JMeq_eqを仮定して他の公理を導く *)
Section Declare_JMeq_eq.
 Variable JMeq_eq : forall A x y, JMeq A x A y -> eq A x y.

 Definition JMeq_elim_eqlike_nodep_from_
  (A : Type) (x : A) (P : A -> Type)
  (c : P x) (y : A) (p : JMeq A x A y)
  : P y
 .
 Proof.
  refine (
   eq_elim_nodep A x P c y (JMeq_eq A x y p)
  ).
 Defined.

 (* 証明不可能？ *)
 Definition JMeq_elim_eqlike
  (A : Type) (x : A) (P : forall y : A, JMeq A x A y -> Type)
  (c : P x (JMeq_refl A x)) (y : A) (p : JMeq A x A y)
  : P y p
 .
 Proof.
 Abort.

 Definition UIP (A : Type) (x y : A) (p q : eq A x y) : eq (eq A x y) p q.
 Proof.
  refine (JMeq_eq (eq A x y) p q _).
  refine (UIP' A x y p q).
 Defined.

 Definition K
  (A : Type) (x : A) (P : eq A x x -> Type)
  (c : P (eq_refl A x)) (p : eq A x x)
  : P p
 .
 Proof.
   refine (
    eq_elim_nodep
     (eq A x x) (eq_refl A x) (fun p' => P p')
     c p (UIP A x x (eq_refl A x) p)
   ).
 Defined.

 Definition UIP_refl
  (A : Type) (x : A) (p : eq A x x) : eq (eq A x x) (eq_refl A x) p
 .
 Proof.
  refine (JMeq_eq (eq A x x) (eq_refl A x) p _).
  refine (UIP'_refl A x p).
 Defined.

 Definition JMeq_UIP
  (A B : Type) (a : A) (b : B) (p q : JMeq A a B b) : eq (JMeq A a B b) p q
 .
 Proof.
  refine (JMeq_eq (JMeq A a B b) p q _).
  refine (JMeq_UIP' A B a b p q).
 Defined.

 Definition JMeq_K
  (A : Type) (x : A) (P : JMeq A x A x -> Type)
  (c : P (JMeq_refl A x)) (p : JMeq A x A x)
  : P p
 .
 Proof.
  refine (
   eq_elim_nodep
    (JMeq A x A x) (JMeq_refl A x) P
    c p (JMeq_UIP A A x x (JMeq_refl A x) p)
  ).
 Defined.

 Definition JMeq_UIP_refl
  (A : Type) (x : A) (p : JMeq A x A x) : eq (JMeq A x A x) (JMeq_refl A x) p
 .
 Proof.
  refine (JMeq_eq (JMeq A x A x) (JMeq_refl A x) p _).
  refine (JMeq_UIP'_refl A x p).
 Defined.

 (* JMeq_eqがどう簡約されるか *)
 Definition reduce_JMeq_eq
  (A : Type) (x : A) : eq (eq A x x) (JMeq_eq A x x (JMeq_refl A x)) (eq_refl A x)
 .
 Proof.
  refine (eq_sym (eq A x x) (eq_refl A x) (JMeq_eq A x x (JMeq_refl A x)) _).
  refine (UIP_refl A x (JMeq_eq A x x (JMeq_refl A x))).
 Defined.

 (* JMeq_eqを適用してeq_JMeqを適用すると元に戻る
   証明不可能？ *)
 Definition JMeq_eq_JMeq
  (A : Type) (x y : A) (p : JMeq A x A y)
  : eq (JMeq A x A y) (eq_JMeq A x y (JMeq_eq A x y p)) p
 .
 Proof.
 Abort.

 Definition eq_JMeq_eq
  (A : Type) (x y : A) (p : eq A x y)
  : eq (eq A x y) (JMeq_eq A x y (eq_JMeq A x y p)) p
 .
 Proof.
  refine (
   eq_elim
    A x (fun y' p' => eq (eq A x y') (JMeq_eq A x y' (eq_JMeq A x y' p')) p')
    _ y p
  ).
  refine (
   reduce_JMeq_eq A x
  ).
 Defined.

 Section Declare_JMeq_elim_eqlike.
  Variable JMeq_elim_eqlike
   : forall A x (P : forall y, JMeq A x A y -> Type),
   P x (JMeq_refl A x) -> forall y p, P y p.

  Definition JMeq_eq_JMeq
   (A : Type) (x y : A) (p : JMeq A x A y)
   : eq (JMeq A x A y) (eq_JMeq A x y (JMeq_eq A x y p)) p
  .
  Proof.
   refine (
    JMeq_elim_eqlike
     A x (fun y' p' => eq (JMeq A x A y') (eq_JMeq A x y' (JMeq_eq A x y' p')) p')
     _ y p
   ).
   refine (
    eq_elim_nodep
     (eq A x x) (eq_refl A x)
     (fun p' => eq (JMeq A x A x) (eq_JMeq A x x p') (JMeq_refl A x))
     _ (JMeq_eq A x x (JMeq_refl A x))
     (eq_sym (eq A x x) (JMeq_eq A x x (JMeq_refl A x)) (eq_refl A x) (reduce_JMeq_eq A x))
   ).
   refine (
    eq_refl (JMeq A x A x) (JMeq_refl A x)
   ).
  Defined.
 End Declare_JMeq_elim_eqlike.

 Section Declare_JMeq_eq_JMeq.
  (* この仮定をさらに弱められるかどうかは分かんない *)
  Variable JMeq_eq_JMeq
   : forall A x y p, eq (JMeq A x A y) (eq_JMeq A x y (JMeq_eq A x y p)) p.

  Definition JMeq_elim_eqlike
   (A : Type) (x : A) (P : forall y : A, JMeq A x A y -> Type)
   (c : P x (JMeq_refl A x)) (y : A) (p : JMeq A x A y)
   : P y p
  .
  Proof.
   refine (
    eq_elim
     (JMeq A x A y) (eq_JMeq A x y (JMeq_eq A x y p)) (fun p' _ => P y p')
     _ p (JMeq_eq_JMeq A x y p)
   ).
   refine (
    eq_elim A x (fun y' p' => P y' (eq_JMeq A x y' p')) _ y (JMeq_eq A x y p)
   ).
   refine c.
  Defined.
 End Declare_JMeq_eq_JMeq.
End Declare_JMeq_eq.

(* JMeq_elim_nodep_eqlikeを仮定して他の公理を導く *)
Section Declare_JMeq_elim_nodep_eqlike.
 Variable JMeq_elim_nodep_eqlike
  : forall A x P, P x -> forall y, JMeq A x A y -> P y.

 Definition JMeq_eq_from_JMeq_elim_nodep_eqlike
  (A : Type) (x y : A) (p : JMeq A x A y) : eq A x y
 .
 Proof.
  refine (
   JMeq_elim_nodep_eqlike
    A x (fun y' => eq A x y')
    (eq_refl A x) y p
  ).
 Defined.

 (* 証明不可能？ *)
 Definition reduce_JMeq_elim_nodep_eqlike
  (A : Type) (x : A) (P : A -> Type) (c : P x)
  : eq (P x) (JMeq_elim_nodep_eqlike A x P c x (JMeq_refl A x)) c
 .
 Proof.
 Abort.
End Declare_JMeq_elim_nodep_eqlike.

(* JMeqを使って定義されたeq
  Coq.Logic.JMeq.JMeq_homとしてライブラリに存在。 *)
Definition JMeqH (A : Type) (x y : A) := JMeq A x A y.

(* eqと違い、示せる *)
Definition JMeq_JMeqH
 (A : Type) (x y : A) (p : JMeq A x A y) : JMeqH A x y
:=
 p
.

Inductive ex (A : Type) (P : A -> Type) : Type :=
| ex_pair : forall x : A, P x -> ex A P
.

Definition ex_elim
 (A : Type) (P : A -> Type) (Q : ex A P -> Type)
 (c : forall (x : A) (xH : P x), Q (ex_pair A P x xH)) (x : ex A P)
 : Q x
:=
 match x as x' return Q x' with
 | ex_pair _ _ a aH => c a aH
 end
.

Definition ex_elim_nodep
 (A : Type) (P : A -> Type) (Q : Type)
 (c : forall (x : A), P x -> Q) (x : ex A P)
 : Q
:=
 match x with
 | ex_pair _ _ a aH => c a aH
 end
.

Definition eq_elim_nopoint
 (A : Type) (P : forall (x y : A), eq A x y -> Type)
 (c : forall a : A, P a a (eq_refl A a)) (x y : A) (p : eq A x y)
 : P x y p
:=
 match p as p' in eq _ _ y' return P x y' p' with
 | eq_refl _ _ => c x
 end
.

Definition eq_elim_nopoint_nodep
 (A : Type) (P : A -> A -> Type)
 (c : forall a : A, P a a) (x y : A) (p : eq A x y)
 : P x y
:=
 match p with
 | eq_refl _ _ => c x
 end
.

(* eqを使って定義されたJMeqもどき *)
Definition eqJM
 (A : Type) (a : A) (B : Type) (b : B)
:=
 ex
  (eq Type A B)
  (fun p => (eq_elim_nopoint_nodep Type (fun A' B' => A' -> B' -> Type) eq A B p) a b)
.

(* 証明不可能？ *)
Definition eqJM_JMeq
 (A B : Type) (a : A) (b : B) (p : eqJM A a B b) : JMeq A a B b
.
Proof.
Abort.

Definition JMeq_eqJM
 (A B : Type) (a : A) (b : B) (p : JMeq A a B b) : eqJM A a B b
.
Proof.
 refine (
  JMeq_elim_nodep A a (eqJM A a) _ B b p
 ).
 refine (
  ex_pair
   (eq Type A A)
   (fun p => (eq_elim_nopoint_nodep Type (fun A' A'' => A' -> A'' -> Type) eq A A p) a a)
   (eq_refl Type A)
   _
 ).
 refine (
  eq_refl A a
 ).
Defined.

(* https://homotopytypetheory.org/2012/11/21/on-heterogeneous-equality/ *)

Definition pointed_type : Type := ex Type (fun A => A).

Definition unpointed (A : pointed_type) : Type :=
 ex_elim_nodep Type (fun A => A) Type (fun A a => A) A
.

Definition base_point (A : pointed_type) : unpointed A :=
 ex_elim Type (fun A => A) (fun A => unpointed A) (fun A a => a) A
.

Definition at_home (A : Type) (a : A) : pointed_type := ex_pair Type (fun A => A) A a.

Definition ptEq_JMeq
 (A B : pointed_type) (p : eq pointed_type A B)
 : JMeq (unpointed A) (base_point A) (unpointed B) (base_point B)
.
Proof.
 refine (
  eq_elim_nodep
   pointed_type A (fun B' => JMeq (unpointed A) (base_point A) (unpointed B') (base_point B'))
   _ B p
 ).
 refine (
  JMeq_refl (unpointed A) (base_point A)
 ).
Defined.

Definition eqPt (A : Type) (a : A) (B : Type) (b : B) :=
 eq pointed_type (at_home A a) (at_home B b)
.

Definition JMeq_eqPt
 (A B : Type) (a : A) (b : B) (p : JMeq A a B b) : eqPt A a B b
.
Proof.
 refine (
  JMeq_elim_nodep A a (fun B' b' => eqPt A a B' b') _ B b p
 ).
 refine (
  eq_refl pointed_type (at_home A a)
 ).
Defined.

Definition eqPt_JMeq
 (A B : Type) (a : A) (b : B) (p : eqPt A a B b) : JMeq A a B b
.
Proof.
 pose (pA := at_home A a).
 pose (pB := at_home B b).
 change (JMeq (unpointed pA) (base_point pA) (unpointed pB) (base_point pB)).
 refine (ptEq_JMeq pA pB p).
Defined.

(* この後さらにhequivであることがわかる　*)

Inductive JMeqE (A : Type) (a : A) : forall B : Type, B -> eq Type A B -> Type :=
| JMeqE_refl : JMeqE A a A a (eq_refl Type A)
.


Require Import coqutil.sanity.
Require Import coqutil.Datatypes.HList.
Require Import coqutil.Datatypes.List.
Require Import coqutil.Datatypes.PropSet.

Module map.
  Class map {key value} := mk {
    rep : Type;

    (* fundamental operation, all others are axiomatized in terms of this one *)
    get: rep -> key -> option value;

    empty : rep;
    put : rep -> key -> value -> rep;
    remove : rep -> key -> rep;
    fold{R: Type}: (R -> key -> value -> R) -> R -> rep -> R;
  }.
  Arguments map : clear implicits.
  Global Coercion rep : map >-> Sortclass.
  Global Hint Mode map + + : typeclass_instances.
  Local Hint Mode map - - : typeclass_instances.

  Class ok {key value : Type} {map : map key value}: Prop := {
    map_ext : forall m1 m2, (forall k, get m1 k = get m2 k) -> m1 = m2;
    get_empty : forall k, get empty k = None;
    get_put_same : forall m k v, get (put m k v) k = Some v;
    get_put_diff : forall m k v k', k <> k' -> get (put m k' v) k = get m k;
    get_remove_same : forall m k, get (remove m k) k = None;
    get_remove_diff : forall m k k', k <> k' -> get (remove m k') k = get m k;
    fold_spec{R: Type} : forall (P: rep -> R -> Prop) (f: R -> key -> value -> R) r0,
        P empty r0 ->
        (forall k v m r, get m k = None -> P m r -> P (put m k v) (f r k v)) ->
        forall m, P m (fold f r0 m);
    (* Folding over a map preserves relations: *)
    fold_parametricity: forall {A B : Type} (R : A -> B -> Prop)
                               (fa: A -> key -> value -> A) (fb: B -> key -> value -> B),
        (forall a b k v, R a b -> R (fa a k v) (fb b k v)) ->
        forall a0 b0, R a0 b0 -> forall m, R (fold fa a0 m) (fold fb b0 m);

  }.
  Arguments ok {_ _} _.

  Section WithMap. Local Set Default Proof Using "All".
    Context {key value : Type} {map : map key value} {map_ok : ok map}.

    Definition update (m : map) (k : key) (ov : option value) :=
      match ov with
      | None => remove m k
      | Some v => put m k v
      end.
    Definition putmany: map -> map -> map := fold put.
    Definition extends (m1 m2 : map) := forall x w, get m2 x = Some w -> get m1 x = Some w.
    Definition agree_on (P : set key) m1 m2 := forall k, elem_of k P -> get m1 k = get m2 k.
    Definition only_differ(m1: map)(ks: set key)(s2: map) :=
      forall x, elem_of x ks \/ get m1 x = get s2 x.
    Definition undef_on m P := agree_on P m empty.
    Definition injective(m: map): Prop :=
      forall k1 k2 v,
        map.get m k1 = Some v -> map.get m k2 = Some v -> k1 = k2.
    Definition not_in_range(m: map)(l: list value): Prop :=
      List.Forall (fun v => forall k, map.get m k <> Some v) l.
    Definition disjoint (a b : map) :=
      forall k v1 v2, get a k = Some v1 -> get b k = Some v2 -> False.
    Definition sub_domain(m1 m2: map): Prop :=
      forall k v1, map.get m1 k = Some v1 -> exists v2, map.get m2 k = Some v2.
    Definition same_domain(m1 m2: map): Prop := sub_domain m1 m2 /\ sub_domain m2 m1.
    Definition forall_keys(P : key -> Prop)(m : map): Prop :=
      forall k v, map.get m k = Some v -> P k.
    Definition forall_values(P: value -> Prop)(m: map): Prop :=
      forall k v, map.get m k = Some v -> P v.
    Definition forallb(f: key -> value -> bool): map -> bool :=
      map.fold (fun res k v => andb res (f k v)) true.
    Definition singleton(k: key)(v: value): map := map.put map.empty k v.

    Definition split m m1 m2 := m = (putmany m1 m2) /\ disjoint m1 m2.

    Definition getmany_of_list (m : map) (keys : list key) : option (list value) :=
      List.option_all (List.map (get m) keys).

    Fixpoint putmany_of_list (l : list (key*value)) (init : rep) {struct l} : map :=
      match l with
      | nil => init
      | cons (k,v) l =>
        putmany_of_list l (put init k v)
      end.
    Fixpoint of_list (l : list (key * value)) : rep :=
      match l with
      | nil => map.empty
      | cons (k,v) l => put (of_list l) k v
      end.

    Definition keys(m : map): list key := fold (fun acc k v => cons k acc) nil m.

    Definition tuples(m: map): list (key * value) := fold (fun l k v => cons (k, v) l) nil m.

    Fixpoint putmany_of_list_zip (keys : list key) (values : list value) (init : rep) {struct keys} : option map :=
      match keys, values with
      | nil, nil => Some init
      | cons k keys, cons v values =>
        putmany_of_list_zip keys values (put init k v)
      | _, _ => None
      end.
    Definition of_list_zip keys values := putmany_of_list_zip keys values empty.

    Fixpoint putmany_of_disjoint_list_zip (keys : list key) (values : list value) (init : rep)
             {struct keys} : option map :=
      match keys, values with
      | nil, nil => Some init
      | cons k keys, cons v values =>
        match putmany_of_disjoint_list_zip keys values init with
        | Some m => match get m k with
                    | Some _ => None
                    | None => Some (put m k v)
                    end
        | None => None
        end
      | _, _ => None
      end.
    Definition of_disjoint_list_zip keys values := putmany_of_disjoint_list_zip keys values empty.

    Import PrimitivePair.

    Definition getmany_of_tuple(m: map){sz: nat}(keys: tuple key sz): option (tuple value sz) :=
      tuple.option_all (tuple.map (get m) keys).

    Fixpoint putmany_of_tuple {sz : nat} : tuple key sz -> tuple value sz -> map -> map :=
      match sz with
      | O => fun keys values init => init
      | S sz' => fun '(pair.mk k ks) '(pair.mk v vs) init =>
                   put (putmany_of_tuple ks vs init) k v
      end.
    Definition of_tuple {sz : nat} (keys: tuple key sz) (values: tuple value sz) :=
      putmany_of_tuple keys values empty.
  End WithMap.
End map. Local Notation map := map.map.
Global Coercion map.rep : map >-> Sortclass.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                Adjunction Example : Cartesian         		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Diagonal.
Require Export CCC.
Require Export Terminal1.

Set Implicit Arguments.
Unset Strict Implicit.

(* Diag(C) a un RAdj -> C admet les produits *)

Section diag_hasprod1.

Variable C : Category.

SubClass HasBinProd1 := RightAdj (Diag C).

Structure IsCartesian1 : Type :=
  {Car_terminal1 :> Terminal1 C; Car_BP1 :> HasBinProd1}.

Variable H : HasBinProd1.

 Section diag_prod1.

 Variable a b : C.

 Let ua' := CoUnit H (Build_POb a b).

 Definition Obj_prod1 := CoUA_ob ua'.

 Definition Proj1_prod1 := Hom_l (CoUA_mor ua').

 Definition Proj2_prod1 := Hom_r (CoUA_mor ua').

  Section together1_def.

  Variable c : C.

  Definition Together1 (f : c --> a) (g : c --> b) :=
    CoUA_diese ua' (Build_Pmor (u:=Build_POb c c) (t:=Build_POb a b) f g).

  Lemma Together1_l : Map2_congl_law Together1.
  Proof.
  unfold Map2_congl_law in |- *; intros f g g' H'.
  unfold Together1 in |- *.
  apply (Codiese_map ua' (a':=c)).
  simpl in |- *; unfold Equal_Pmor in |- *; simpl in |- *.
  split.
  apply Refl.
  trivial.
  Qed.

  Lemma Together1_r : Map2_congr_law Together1.
  Proof.
  unfold Map2_congr_law in |- *; intros f f' g H'.
  unfold Together1 in |- *.
  apply (Codiese_map ua' (a':=c)).
  simpl in |- *; unfold Equal_Pmor in |- *; simpl in |- *.
  split.
  trivial.
  apply Refl.
  Qed.

  Definition Op_together1 := Build_Map2 Together1_l Together1_r.

  End together1_def.

 Lemma Prf_eq1_prod1 : Eq1_prod_law Proj1_prod1 Op_together1.
 Proof.
 unfold Eq1_prod_law in |- *; intros c f g.
 unfold Together_prod, Op_together1, Together1, Proj1_prod1, Ap2 in |- *;
  simpl in |- *.
 generalize
  (Prf_isCoUA_law1 ua' (Build_Pmor (u:=Build_POb c c) (t:=Build_POb a b) f g)).
 unfold CoUA_eq in |- *; simpl in |- *.
 unfold Equal_Pmor in |- *; simpl in |- *.
 simple induction 1.
 intros H2 H3.
 apply H2.
 Qed.

 Lemma Prf_eq2_prod1 : Eq2_prod_law Proj2_prod1 Op_together1.
 Proof.
 unfold Eq2_prod_law in |- *; intros c f g.
 unfold Together_prod, Op_together1, Together1, Proj2_prod1, Ap2 in |- *;
  simpl in |- *.
 generalize
  (Prf_isCoUA_law1 ua' (Build_Pmor (u:=Build_POb c c) (t:=Build_POb a b) f g)).
 unfold CoUA_eq in |- *; simpl in |- *.
 unfold Equal_Pmor in |- *; simpl in |- *.
 simple induction 1.
 intros H2 H3.
 apply H3.
 Qed.

 Lemma Prf_unique_together1 :
  Unique_together_law Proj1_prod1 Proj2_prod1 Op_together1.
 Proof.
 unfold Unique_together_law in |- *; intros c h.
 unfold Together_prod, Ap2 in |- *; simpl in |- *; unfold Together1 in |- *.
 apply Sym.
 apply
  (Prf_isCoUA_law2 ua'
     (f:=Build_Pmor (u:=Build_POb c c) (t:=Build_POb a b)
           (h o Proj1_prod1) (h o Proj2_prod1)) (g:=h)).
 unfold CoUA_eq in |- *; simpl in |- *.
 unfold Equal_Pmor in |- *; simpl in |- *; split.
 apply Refl.
 apply Refl.
 Qed.

 End diag_prod1.

 Definition BP1_to_BP : HasBinProd C :=
   fun a b : C =>
   Build_BinProd (Prf_eq1_prod1 (a:=a) (b:=b)) (Prf_eq2_prod1 (a:=a) (b:=b))
     (Prf_unique_together1 (a:=a) (b:=b)).

End diag_hasprod1.

Coercion BP1_to_BP : HasBinProd1 >-> HasBinProd.

Coercion Car1_to_Car (C : Category) (H : IsCartesian1 C) :=
  Build_IsCartesian H H.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal17.

From lfind Require Import LFind.
Lemma lfind_state  (x:lst) (y:lst):@eq lst (rev (rev (append x y))) (append (rev (rev x)) (rev (rev y))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal17_theorem0_39_lem/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (x:lst) (y:lst) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


(* *********************************************************************)
(*                                                                     *)
(*              The L2C verified compiler                              *)
(*                                                                     *)
(*            L2C Group, Tsinghua University                           *)
(*                                                                     *)
(*  Copyright Tsinghua University.  All rights reserved.  This file is *)
(*  distributed under the terms of the GNU General Public License as   *)
(*  published by the Free Software Foundation, either version 2 of the *)
(*  License, or (at your option) any later version.  This file is also *)
(*  distributed under the terms of the INRIA Non-Commercial License    *)
(*  Agreement.                                                         *)
(*                                                                     *)
(* *********************************************************************)

Require Import Axioms.
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Lvalues.
Require Import Values.
Require Export Memdata.
Require Export Memtype.
Require Import Memory.
Require Import Maps.
Require Import Lenv.
Require Import Globalenvs.
Require Import Cltypes.
Require Import Ctemp.
Require Import ExtraList.

Section MEMORY.

Transparent Mem.alloc Mem.free Mem.store Mem.load Mem.storebytes Mem.loadbytes.

Theorem range_perm_valid_block2:
  forall m b lo hi,
  Mem.range_perm m b lo hi Cur Nonempty ->
  lo < hi ->
  Mem.valid_block m b.
Proof.
  intros.
  assert (Mem.perm m b lo Cur Nonempty).
    apply H. omega.
  eauto with mem.
Qed.

Theorem range_perm_alloc_other2:
  forall m1 lo hi m2 b,
  Mem.alloc m1 lo hi = (m2, b) ->
  forall b' ofs n p,
  0 < n ->
  Mem.range_perm m1 b' ofs (ofs + n) Cur p ->
  Mem.range_perm m2 b' ofs (ofs + n) Cur p.
Proof.
  intros. red; intros. apply H1 in H2.
  eapply Mem.perm_alloc_1; eauto.
Qed.

Theorem range_perm_alloc_inv2:
  forall m1 lo hi m2 b,
  Mem.alloc m1 lo hi = (m2, b) ->
  forall b' ofs n p,
  Mem.range_perm m2 b' ofs (ofs + n) Cur p ->
  0 < n ->
  if eq_block b' b
  then lo <= ofs /\ ofs + n <= hi
  else Mem.range_perm m1 b' ofs (ofs + n) Cur p.
Proof.
  intros.
  unfold eq_block. destruct (peq b' b). subst b'.
  assert (Mem.perm m2 b ofs Cur p). apply H0. omega.
  assert (Mem.perm m2 b (ofs + n - 1) Cur p). apply H0. omega.
  exploit Mem.perm_alloc_inv. apply H. eexact H2. rewrite peq_true. intro.
  exploit Mem.perm_alloc_inv. apply H. eexact H3. rewrite peq_true. intro.
  intuition omega.
  red; intros.
  exploit Mem.perm_alloc_inv. apply H. apply H0. eauto. rewrite peq_false; auto.
Qed.

Lemma getN_repeat_undef:
  forall n lo, Mem.getN n lo (ZMap.init Undef) = list_repeat n Undef.
Proof.
  induction n; simpl; intros; auto.
  f_equal; auto. unfold ZMap.init, PMap.init,ZMap.get,PMap.get.
  simpl. rewrite PTree.gempty. auto.
Qed.

Theorem loadbytes_alloc_same:
  forall m1 lo hi m2 b,
  Mem.alloc m1 lo hi = (m2, b) ->
  Mem.loadbytes m2 b lo (hi-lo) = Some (list_repeat (nat_of_Z (hi-lo)) Undef ).
Proof.
  intros. unfold Mem.loadbytes.
  injection H; intros. rewrite <-H1.
  rewrite pred_dec_true; simpl.
  rewrite H0. rewrite PMap.gss; auto.
  rewrite getN_repeat_undef; auto.

  red. unfold Mem.perm. simpl. rewrite H0.
  rewrite PMap.gss. intros.
  replace (lo + (hi - lo)) with hi in H2; try omega.
  destruct (zle lo ofs); try omega.
  destruct (zlt ofs hi); try omega.
  simpl. constructor.
Qed.

Theorem loadbytes_alloc_unchanged:
  forall m1 m2 lo hi b b' ofs n,
  Mem.alloc m1 lo hi = (m2, b) ->
  Mem.valid_block m1 b' ->
  Mem.loadbytes m2 b' ofs n = Mem.loadbytes m1 b' ofs n.
Proof.
  intros.
  assert(n <= 0 \/ 0 < n). omega.
  destruct H1.
  repeat rewrite Mem.loadbytes_empty; auto.

  unfold Mem.loadbytes.
  destruct (Mem.range_perm_dec m2 b' ofs (ofs + n) Cur Readable).
  exploit range_perm_alloc_inv2; eauto. destruct (eq_block b' b); intros.
  +subst b'. elimtype False.
   apply Mem.alloc_result in H. red in H0. subst.
   apply Plt_strict in H0. auto.
  +rewrite pred_dec_true; auto.
   injection H; intros. rewrite <- H4; simpl.
   rewrite H3. rewrite PMap.gso; auto.
  +rewrite pred_dec_false. auto.
   red; intros. red in n0. apply n0.
   eapply range_perm_alloc_other2; eauto.
Qed.

Theorem loadbytes_alloc_other:
  forall m1 m2 lo hi b b' ofs n bytes,
  Mem.alloc m1 lo hi = (m2, b) ->
  Mem.loadbytes m1 b' ofs n = Some bytes ->
  Mem.loadbytes m2 b' ofs n = Some bytes.
Proof.
  intros.
  assert(n <= 0 \/ 0 < n). omega.
  destruct H1.
  rewrite Mem.loadbytes_empty in *; auto.

  rewrite <- H0.
  eapply loadbytes_alloc_unchanged; eauto.
  apply Mem.loadbytes_range_perm in H0.
  apply range_perm_valid_block2 with ofs (ofs+n); try omega.
  eauto with mem.
Qed.

Theorem range_perm_free_3:
  forall m1 bf lo hi m2,
  Mem.free m1 bf lo hi = Some m2 ->
  forall b ofs n p,
  Mem.range_perm m1 b ofs (ofs + n) Cur p ->
  b <> bf \/ lo >= hi \/ ofs + n <= lo \/ hi <= ofs ->
  Mem.range_perm m2 b ofs (ofs + n) Cur p.
Proof.
  intros.
  red; intros. eapply Mem.perm_free_1; eauto.
  destruct (zlt lo hi). intuition. right. omega.
Qed.

Theorem range_perm_free_inv_3:
  forall m1 bf lo hi m2 b ofs p n,
  Mem.free m1 bf lo hi = Some m2 ->
  Mem.range_perm m2 b ofs (ofs + n) Cur p  ->
  Mem.range_perm m1 b ofs (ofs + n) Cur p .
Proof.
  intros. generalize H; intros A.
  apply Mem.free_result in H. subst.
  red; intros. generalize (H0 ofs0 H).

  unfold Mem.perm, Mem.unchecked_free; simpl.
  assert(b = bf \/ b <> bf). tauto. destruct H1.
  subst b. rewrite PMap.gss in *.
  destruct (zle lo ofs0); simpl in *.
  destruct (zlt ofs0 hi); simpl in *. tauto.
  congruence. auto.
  rewrite PMap.gso in *; auto.
Qed.

Theorem loadbytes_free:
  forall m1 bf lo hi m2 b ofs n,
  Mem.free m1 bf lo hi = Some m2 ->
  b <> bf ->
  Mem.loadbytes m2 b ofs n = Mem.loadbytes m1 b ofs n.
Proof.
  intros.
  assert(n <= 0 \/ 0 < n). omega.
  destruct H1.
  repeat rewrite Mem.loadbytes_empty; auto.

  unfold Mem.loadbytes.
  destruct (Mem.range_perm_dec m2 b ofs (ofs + n) Cur Readable).
  rewrite pred_dec_true.
  generalize H; intros A.
  apply Mem.free_result in A. rewrite A.
  simpl. auto.

  eapply range_perm_free_inv_3; eauto.
  rewrite pred_dec_false; auto.
  red; intro; elim n0.
  eapply range_perm_free_3; eauto.
Qed.

Theorem range_perm_drop_5:
  forall m b lo hi p m' n b' ofs p',
  Mem.drop_perm m b lo hi p = Some m' ->
  b' <> b \/ ofs + n <= lo \/ hi <= ofs \/ perm_order p p' ->
  0 <= n ->
  Mem.range_perm m b' ofs (ofs + n) Cur p'  ->
  Mem.range_perm m' b' ofs (ofs + n) Cur p' .
Proof.
  intros.
  red; intros.
  destruct (peq b' b). subst b'.
  destruct (zlt ofs0 lo). eapply Mem.perm_drop_3; eauto.
  destruct (zle hi ofs0). eapply Mem.perm_drop_3; eauto.
  apply Mem.perm_implies with p. eapply Mem.perm_drop_1; eauto. omega.
  intuition.
  eapply Mem.perm_drop_3; eauto.
Qed.

Theorem range_perm_drop_6:
  forall m b lo hi p m' n b' ofs p',
  Mem.drop_perm m b lo hi p = Some m' ->
  Mem.range_perm m' b' ofs (ofs + n) Cur p' ->
  Mem.range_perm m b' ofs (ofs + n) Cur p'.
Proof.
  intros. red; intros. eapply Mem.perm_drop_4; eauto.
Qed.

Theorem loadbytes_drop:
  forall m b lo hi p m' n b' ofs,
  Mem.drop_perm m b lo hi p = Some m' ->
  b' <> b \/ ofs + n <= lo \/ hi <= ofs \/ perm_order p Readable ->
  Mem.loadbytes m' b' ofs n = Mem.loadbytes m b' ofs n.
Proof.
  intros.
  destruct (zle n 0).
  repeat rewrite Mem.loadbytes_empty; auto.
  unfold Mem.loadbytes.
  destruct (Mem.range_perm_dec m b' ofs (ofs + n) Cur Readable).
  rewrite pred_dec_true.
  unfold Mem.drop_perm in H. destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inv H.
  simpl. auto.
  eapply range_perm_drop_5; eauto. omega.
  rewrite pred_dec_false. auto.
  red; intros; elim n0. eapply range_perm_drop_6; eauto.
Qed.

Lemma alloc_range_perm:
  forall m1 m2 hi i p,
  Mem.alloc m1 0 hi = (m2, i) ->
  Mem.range_perm m2 i 0 hi Cur p.
Proof.
  unfold Mem.range_perm. simpl; intros.
  apply Mem.perm_alloc_2 with _ _ _ _ _ ofs Cur in H; auto.
  unfold Mem.perm in *. unfold Mem.perm_order' in *.
  destruct (PMap.get i (Mem.mem_access m2) ofs Cur) eqn:?; try congruence.
  inv H; constructor.
Qed.

Lemma range_perm_sube:
  forall m l o1 n1 o2 n2 p,
  Mem.range_perm m l o1 n1 Cur p ->
  o1 <= o2 /\ n2 <= n1 ->
  Mem.range_perm m l o2 n2 Cur p.
Proof.
  intros. red. intros. apply H. omega.
Qed.

Lemma loadbytes_valid_block:
  forall m b o n mv,
  Mem.loadbytes m b o n = Some mv ->
  0 < n ->
  Plt b (Mem.nextblock m).
Proof.
  intros. apply Mem.loadbytes_range_perm in H.
  apply range_perm_valid_block2 with o (o+n); try omega.
  eauto with mem.
Qed.

Lemma alloc_loadbytes_same:
  forall m t m1 b1,
  Mem.alloc m 0 (sizeof t) = (m1, b1) ->
  Mem.loadbytes m1 b1 0 (sizeof t) = Some (alloc (sizeof t)).
Proof.
  intros. apply loadbytes_alloc_same in H.
  rewrite Z.sub_0_r in H; auto.
Qed.

Lemma free_list_nextblock_eq:
  forall l m m1,
  Mem.free_list m l = Some m1 ->
  Mem.nextblock m1 = Mem.nextblock m.
Proof.
  induction l; intros; inv H; auto.
  destruct a. destruct p.
  destruct (Mem.free _ _ _ _) eqn:?; try congruence.
  rewrite IHl with m0 _; auto.
  apply Mem.nextblock_free in Heqo; auto.
Qed.

Lemma free_list_loadbytes_eq:
  forall bl m m',
  Mem.free_list m bl = Some m' ->
  forall b o n, ~ In b (map (fun x => fst (fst x)) bl) ->
  Mem.loadbytes m' b o n = Mem.loadbytes m b o n.
Proof.
  induction bl; simpl; intros.
  +inv H; auto.
  +destruct a. destruct p.
   destruct (Mem.free _ _ _ _) eqn:?; try congruence.
   erewrite IHbl with (m:=m0); eauto.
   erewrite loadbytes_free; eauto.
Qed.

Lemma free_list_range_perm:
  forall bl m m',
  Mem.free_list m bl = Some m' ->
  forall b o n p ,
  ~ In b (map (fun x => fst (fst x)) bl) ->
  Mem.range_perm m b o n Cur p ->
  Mem.range_perm m' b o n Cur p.
Proof.
  induction bl; simpl; intros.
  +inv H; auto.
  +destruct a. destruct p0.
   destruct (Mem.free _ _ _ _) eqn:?; try congruence.
   apply IHbl with m0; auto.
   red; intros. eapply Mem.perm_free_1; eauto.
Qed.

Lemma free_list_range_perm_inv:
  forall bl m m',
  Mem.free_list m bl = Some m' ->
  forall b o n p ,
  Mem.range_perm m' b o n Cur p ->
  Mem.range_perm m b o n Cur p.
Proof.
  induction bl; simpl; intros.
  +inv H; auto.
  +destruct a. destruct p0.
   destruct (Mem.free _ _ _ _) eqn:?; try congruence.
   apply IHbl with (m:=m0) in H0; eauto.
   red; intros. eapply Mem.perm_free_3; eauto.
Qed.

End MEMORY.

Section GLOBALENVS.

Variable ge: Genv.t fundef type.

Fixpoint loadbytes_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) {struct il} : Prop :=
  match il with
  | nil => True
  | Init_int8 n :: il' =>
      Mem.loadbytes m b p 1 = Some (encode_val Mint8unsigned (Vint n))
      /\ loadbytes_store_init_data m b (p + 1) il'
  | Init_int16 n :: il' =>
      Mem.loadbytes m b p 2 = Some (encode_val Mint16unsigned (Vint n))
      /\ loadbytes_store_init_data m b (p + 2) il'
  | Init_int32 n :: il' =>
      Mem.loadbytes m b p 4 = Some (encode_val Mint32 (Vint n))
      /\ loadbytes_store_init_data m b (p + 4) il'
  | Init_int64 n :: il' =>
      Mem.loadbytes m b p 8 = Some (encode_val Mint64 (Vlong n))
      /\ loadbytes_store_init_data m b (p + 8) il'
  | Init_float32 n :: il' =>
      Mem.loadbytes m b p 4 = Some (encode_val Mfloat32 (Vsingle n))
      /\ loadbytes_store_init_data m b (p + 4) il'
  | Init_float64 n :: il' =>
      Mem.loadbytes m b p 8 = Some (encode_val Mfloat64 (Vfloat n))
      /\ loadbytes_store_init_data m b (p + 8) il'
  | Init_addrof symb ofs :: il' =>
      loadbytes_store_init_data m b (p + 4) il'
  | Init_space n :: il' =>
      Mem.loadbytes m b p (Zmax n 0) = Some (list_repeat (nat_of_Z (Zmax n 0)) (Byte Byte.zero))
      /\ loadbytes_store_init_data m b (p + Zmax n 0) il'
  end.

Lemma store_init_data_outside_bytes:
  forall  b a m p m',
  Genv.store_init_data ge m b p a = Some m' ->
  forall n b' q,
  b' <> b \/ q + n <= p \/ p + Genv.init_data_size a <= q->
  Mem.loadbytes m' b' q n = Mem.loadbytes m b' q n.
Proof.
  intros.
  destruct a; simpl in *;
  try (eapply Mem.loadbytes_store_other; eauto; intuition; fail).
  congruence.
  destruct (Genv.find_symbol ge i); try congruence.
  eapply Mem.loadbytes_store_other; eauto; intuition.
Qed.

Lemma store_init_data_list_outside_bytes:
  forall  b il m p m',
  Genv.store_init_data_list ge m b p il = Some m' ->
  forall n b' q,
  b' <> b \/ q + n <= p ->
  Mem.loadbytes m' b' q n = Mem.loadbytes m b' q n.
Proof.
  induction il; simpl.
  intros; congruence.
  intros until m'. caseEq (Genv.store_init_data ge m b p a); try congruence.
  intros m1 A B n b' q C. transitivity (Mem.loadbytes m1 b' q n).
  eapply IHil; eauto. generalize (Genv.init_data_size_pos a). intuition omega.
  eapply store_init_data_outside_bytes; eauto.
  destruct C; auto.
Qed.

Lemma store_init_data_list_bytes:
  forall b il m p m',
  Genv.store_init_data_list ge m b p il = Some m' ->
  Mem.loadbytes m b p (Genv.init_data_list_size il) = Some (list_repeat (nat_of_Z (Genv.init_data_list_size il)) (Byte Byte.zero)) ->
  loadbytes_store_init_data m' b p il.
Proof.
  assert (A: forall chunk v m b p m1 il m',
    Mem.store chunk m b p v = Some m1 ->
    Genv.store_init_data_list ge m1 b (p + size_chunk chunk) il = Some m' ->
    Mem.loadbytes m' b p (size_chunk chunk) = Some (Memdata.encode_val chunk v)).
  intros. transitivity (Mem.loadbytes m1 b p (size_chunk chunk)).
  eapply store_init_data_list_outside_bytes; eauto. right. omega.
  eapply Mem.loadbytes_store_same; eauto.

  induction il; simpl.
  auto.
  intros until m'. caseEq (Genv.store_init_data ge m b p a); try congruence.
  intros m1 B C C1.
  generalize (Genv.init_data_list_size_pos il) (Genv.init_data_size_pos a).
  intros. apply Mem.loadbytes_split in C1; try omega.
  destruct C1 as [? [? [C1 [C2 C3]]]].
  rewrite Z2Nat.inj_add in C3; try omega. rewrite list_repeat_app in C3.
  apply app_length_equal_inv in C3.
  destruct C3. subst.

  exploit IHil; eauto.

  unfold nat_of_Z. rewrite <-C2.
  eapply store_init_data_outside_bytes; eauto.
  right. omega.

  intro D.
  destruct a; simpl in B; intuition.
  eapply (A Mint8unsigned (Vint i)); eauto.
  eapply (A Mint16unsigned (Vint i)); eauto.
  eapply (A Mint32 (Vint i)); eauto.
  eapply (A Mint64 (Vlong i)); eauto.
  eapply (A Mfloat32 (Vsingle f)); eauto.
  eapply (A Mfloat64 (Vfloat f)); eauto.
  inv B.

  simpl in *.
  unfold nat_of_Z. rewrite <-C1.
  eapply store_init_data_list_outside_bytes; eauto.
  right. omega.

  left. rewrite length_list_repeat.
  apply Mem.loadbytes_length in C1. auto.
Qed.

Lemma loadbytes_store_init_data_invariant:
  forall m m' b,
  (forall ofs n, Mem.loadbytes m' b ofs n = Mem.loadbytes m b ofs n) ->
  forall il p,
  loadbytes_store_init_data m b p il -> loadbytes_store_init_data m' b p il.
Proof.
  induction il; intro p; simpl.
  auto.
  repeat rewrite H. destruct a; intuition.
  rewrite H; auto.
Qed.

Lemma store_zeros_outside_bytes:
  forall m b z n m',
  Globalenvs.store_zeros m b z n = Some m' ->
  forall n b' p,
  b' <> b -> Mem.loadbytes m' b' p n = Mem.loadbytes m b' p n.
Proof.
  intros until n. functional induction (Globalenvs.store_zeros m b z n); intros.
  inv H; auto.
  rewrite IHo; auto. eapply Mem.loadbytes_store_other; eauto.
  inv H.
Qed.

Lemma init_data_list_size_pos:
  forall l, Genv.init_data_list_size l >= 0.
Proof.
  induction l; simpl; auto.
  omega.
  generalize (Genv.init_data_size_pos a); intros. omega.
Qed.

Lemma alloc_globals_genv_alloc_funcs:
  forall l m,
  (forall a, In a l -> exists f, snd a = Gfun f) ->
  exists m', Genv.alloc_globals ge m l = Some m'.
Proof.
  induction l; simpl; intros.
  +exists m. auto.
  +destruct H with a; auto. destruct a. simpl in *. subst.
   destruct (Mem.alloc m 0 1) eqn:?.
   destruct Mem.range_perm_drop_2 with m0 b 0 1 Nonempty; auto.
   red; intros. eapply Mem.perm_alloc_2; eauto.
   rewrite e. eauto.
Qed.

Lemma store_init_data_perm:
  forall prm b' q a b m p m',
  Genv.store_init_data ge m b p a = Some m' ->
  Mem.perm m b' q Cur prm -> Mem.perm m' b' q Cur prm.
Proof.
  intros.
  destruct a; simpl in H; eauto with mem.
  congruence.
  destruct (Genv.find_symbol ge i); try congruence. eauto with mem.
Qed.

Lemma range_perm_store_zeros:
  forall b m p n,
  Mem.range_perm m b p (p+n) Cur Writable ->
  0 <= n ->
  exists m', Globalenvs.store_zeros m b p n = Some m'.
Proof.
  intros until n. functional induction (Globalenvs.store_zeros m b p n); intros.
  +eauto.
  +apply IHo; try omega. red; intros.
   eapply Mem.perm_store_1; eauto.
   apply H; auto. omega.
  +destruct Mem.valid_access_store with m Mint8unsigned b p Vzero as [m' ?]; auto.
   red. split.
   red; intros. apply H. simpl in *. omega.
   simpl. red. exists p. omega.
   congruence.
Qed.

Lemma loadbytes_alloc_globals:
  forall n b p vl m m',
  Genv.alloc_globals ge m vl = Some m' ->
  Mem.valid_block m b ->
  Mem.loadbytes m' b p n = Mem.loadbytes m b p n.
Proof.
  induction vl; simpl; intros until m'.
  congruence.
  unfold Genv.alloc_global. destruct a. destruct g.
  +intros. destruct (Mem.alloc m 0 1) eqn:?.
   destruct (Mem.drop_perm m0 b0 0 1 Nonempty) eqn:?; try congruence.
   rewrite IHvl with m1 m'; auto.
   transitivity (Mem.loadbytes m0 b p n).
   -eapply loadbytes_drop; eauto.
    left. apply Mem.alloc_result in Heqp0. red in H0. subst.
    red; intros. subst. apply Plt_strict in H0. auto.
   -eapply loadbytes_alloc_unchanged; eauto.
   -apply Mem.nextblock_drop in Heqo. apply Mem.nextblock_alloc in Heqp0.
    unfold Mem.valid_block in *. rewrite Heqo,Heqp0.
    apply Plt_trans with (Mem.nextblock m); auto.
    apply Plt_succ.
  +set (init := gvar_init v).
   set (sz := Genv.init_data_list_size init).
   caseEq (Mem.alloc m 0 sz). intros m1 b1 ALLOC.
   caseEq (store_zeros m1 b1 0 sz); try congruence. intros m2 STZ.
   caseEq (Genv.store_init_data_list ge m2 b1 0 init); try congruence. intros m3 STORE.
   caseEq (Mem.drop_perm m3 b1 0 sz (Genv.perm_globvar v)); try congruence. intros m4 DROP REC VALID.
   assert (b <> b1). apply Mem.valid_not_valid_diff with m; eauto with mem.
   transitivity (Mem.loadbytes m4 b p n).
   apply IHvl; auto. red.
   rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP).
   rewrite (Genv.store_init_data_list_nextblock _ _ _ _ _ STORE).
   rewrite (Genv.store_zeros_nextblock _ _ _ _ STZ).
   change (Mem.valid_block m1 b). eauto with mem.
   transitivity (Mem.loadbytes m3 b p n).
   eapply loadbytes_drop; eauto.
   transitivity (Mem.loadbytes m2 b p n).
   eapply store_init_data_list_outside_bytes; eauto.
   transitivity (Mem.loadbytes m1 b p n).
   eapply store_zeros_outside_bytes; eauto.
  eapply loadbytes_alloc_unchanged; eauto.
Qed.

Lemma add_global_funs_find_var_info:
  forall b l (g:Genv.t fundef type),
  (forall a, In a l -> exists f, snd a = Gfun f) ->
  Genv.find_var_info (Genv.add_globals g l) b = Genv.find_var_info g b.
Proof.
  induction l; simpl; intros; auto.
  rewrite IHl; auto.
  destruct H with a as [f ?]; auto.
  destruct a; simpl in *. subst.
  unfold Genv.add_global, Genv.find_var_info. simpl. auto.
Qed.

Lemma store_init_data_list_var_idem:
  forall (g1 g2:Genv.t fundef type) l m o b,
  init_data_types l ->
  Genv.store_init_data_list g1 m b o l = Genv.store_init_data_list g2 m b o l.
Proof.
  induction l; simpl; intros; auto.
  inv H.
  destruct a; simpl in *; auto; try destruct (Mem.store _ _ _ _ _); auto.
  tauto.
Qed.

Lemma range_perm_store_init_data:
  forall b a ofs m,
  Mem.range_perm m b ofs (ofs+ Genv.init_data_size a) Cur Writable ->
  forall mv mv1, store_init_data mv ofs a = Some mv1 ->
  exists m', Genv.store_init_data ge m b ofs a = Some m'.
Proof.
  intros. generalize H0. intros.
  destruct a; simpl in *; try (eapply store_valid_access in H1; eauto; destruct H1).
  destruct Mem.valid_access_store with m Mint8unsigned b ofs (Vint i) as [m' ?]; eauto.
   split; auto.
  destruct Mem.valid_access_store with m Mint16unsigned b ofs (Vint i) as [m' ?]; eauto.
   split; auto.
  destruct Mem.valid_access_store with m Mint32 b ofs (Vint i) as [m' ?]; eauto.
   split; auto.
  congruence.
  destruct Mem.valid_access_store with m Mfloat32 b ofs (Vsingle f) as [m' ?]; eauto.
   split; auto.
  destruct Mem.valid_access_store with m Mfloat64 b ofs (Vfloat f) as [m' ?]; eauto.
   split; auto.
  eauto.
  congruence.
Qed.

Lemma range_perm_store_init_data_list:
  forall b l ofs m,
  Mem.range_perm m b ofs (ofs+(Genv.init_data_list_size l)) Cur Writable ->
  forall mv mv1, store_init_datas mv ofs l = Some mv1 ->
  exists m', Genv.store_init_data_list ge m b ofs l = Some m'.
Proof.
  induction l; simpl; intros; eauto.
  destruct (store_init_data _ _ _) eqn:?; try congruence.
  generalize (Genv.init_data_size_pos a) (init_data_list_size_pos l); intros.
  destruct range_perm_store_init_data with b a ofs m mv m0 as [m1 ?]; auto.
  red; intros. apply H. omega.
  rewrite H3. destruct IHl with (ofs + Genv.init_data_size a) m1 m0 mv1 as [m' ?]; eauto.
  red; intros. eapply store_init_data_perm; eauto.
  apply H. omega.
Qed.

Lemma alloc_global_var_idem:
  forall i v m (g1 g2:Genv.t fundef type),
  init_data_types (gvar_init v) ->
  Genv.alloc_global g1 m (i, Gvar v) = Genv.alloc_global g2 m (i, Gvar v).
Proof.
  simpl. intros.
  destruct (Mem.alloc _ _ _).
  destruct (Globalenvs.store_zeros _ _ _ _); auto.
  rewrite store_init_data_list_var_idem with (g2:=g2); auto.
Qed.

Lemma alloc_globals_vars_idem:
  forall l m (g1 g2:Genv.t fundef type),
  (forall a, In a l -> exists v, snd a = Gvar v /\ init_data_types (gvar_init v)) ->
  Genv.alloc_globals g1 m l = Genv.alloc_globals g2 m l.
Proof.
  induction l; simpl; intros; auto.
  destruct H with a as [v [? ?]]; auto.
  destruct a; simpl in H0; subst.
  rewrite alloc_global_var_idem with (g2:=g2); auto.
  destruct (Genv.alloc_global _ _ _);auto.
Qed.

Lemma find_symbol_add_globals_new:
  forall id l (g:Genv.t fundef type),  ~ In id (map fst l) ->
  Genv.find_symbol (Genv.add_globals g l) id = Genv.find_symbol g id.
Proof.
  induction l; simpl; intros; auto.
  rewrite IHl; auto.
  unfold Genv.find_symbol, Genv.add_global.
  simpl. rewrite PTree.gso; auto.
Qed.

Lemma find_var_info_add_globals_new:
  forall i l (g:Genv.t fundef type),
  Plt i (Genv.genv_next g) ->
  Genv.find_var_info (Genv.add_globals g l) i = Genv.find_var_info g i.
Proof.
  induction l; simpl; intros; auto.
  rewrite IHl; auto.
  unfold Genv.find_var_info, Genv.add_global.
  +simpl. destruct a. destruct g0; simpl; auto.
   rewrite PTree.gso; auto. red; intros; subst.
   apply Plt_strict in H; auto.
  +destruct a. apply Plt_trans with (Genv.genv_next g); auto.
   destruct g0; simpl; apply Plt_succ; auto.
Qed.

Lemma alloc_globals_bytes:
  forall id ty init vl (g:Genv.t fundef type) m m',
  Genv.genv_next g = Mem.nextblock m ->
  Genv.alloc_globals ge m vl = Some m' ->
  list_norepet (map fst vl) ->
  In (id, Gvar (mkglobvar ty init true false)) vl ->
  (forall a, In a vl -> exists v, snd a = Gvar v) ->
  exists b, Genv.find_symbol (Genv.add_globals g vl) id = Some b
         /\ Genv.find_var_info (Genv.add_globals g vl) b = Some (mkglobvar ty init true false)
         /\ loadbytes_store_init_data m' b 0 init.
Proof.
  induction vl; simpl; intros.
  contradiction.
  inv H1. destruct H3 with a as [? A]; auto.
  destruct a; simpl in *. subst.
  destruct (Mem.alloc _ _ _) eqn:?.
  destruct (Globalenvs.store_zeros _ _ _ _) eqn:?; try congruence.
  destruct (Genv.store_init_data_list _ _ _ _ _) eqn:?; try congruence.
  destruct (Mem.drop_perm _ _ _ _ _) eqn:?; try congruence.
  exploit Mem.alloc_result; eauto. intro A1.
  exploit Mem.nextblock_alloc; eauto. intros A2.
  cut ( Pos.succ (Genv.genv_next g) = Mem.nextblock m3). intros A3.
  destruct H2.
  +inv H1. exists (Mem.nextblock m); repeat split.
   -rewrite find_symbol_add_globals_new; auto.
    unfold Genv.find_symbol,Genv.add_global.
    simpl; rewrite PTree.gss; auto. congruence.
   -rewrite <-H. rewrite find_var_info_add_globals_new; auto.
    unfold Genv.find_var_info, Genv.add_global; simpl.
    rewrite PTree.gss; auto. simpl.
    apply Plt_succ.
   -apply loadbytes_store_init_data_invariant with m2.
    intros. transitivity (Mem.loadbytes m3 (Mem.nextblock m) ofs n).
    *eapply loadbytes_alloc_globals; eauto.
     red. rewrite <-A3, H. apply Plt_succ.
    *eapply loadbytes_drop; eauto. repeat right. constructor.
    *generalize (Genv.init_data_list_size_pos init). intros.
     eapply store_init_data_list_bytes; eauto.
     simpl in *. rewrite <-nat_of_Z_eq with (z:=Genv.init_data_list_size init) at 1; auto.
     eapply Genv.store_zeros_loadbytes; eauto; try omega.
     rewrite nat_of_Z_eq; try omega.
  +eapply IHvl; eauto.
  +rewrite (Mem.nextblock_drop _ _ _ _ _ _ Heqo1).
   rewrite (Genv.store_init_data_list_nextblock _ _ _ _ _ Heqo0).
   rewrite (Genv.store_zeros_nextblock _ _ _ _ Heqo).
   rewrite A2, H. auto.
Qed.

End GLOBALENVS.


Require Import PerformanceExperiments.Harness.
Require Export PerformanceExperiments.rewrite_under_binders_common.

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 0 3
     | SuperFast => List.map (fun x => x * 50) (seq 1 4)
     | Fast => List.map (fun x => x * 10) (seq 1 20)
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Ltac time_solve_goal0 n :=
  (time "noop-repeat-setoid_rewrite-regression-cubic" repeat setoid_rewrite <- plus_n_O);
  (time "noop-repeat-rewrite_strat-topdown-regression-cubic" repeat rewrite_strat topdown <- plus_n_O);
  (time "noop-repeat-rewrite_strat-bottomup-regression-cubic" repeat rewrite_strat bottomup <- plus_n_O).

Ltac run0 sz := Harness.runtests args_of_size default_describe_goal mkgoal_noop redgoal time_solve_goal0 sz.

(*
Goal True.
  run0 Fast.
 *)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Computation of resource bounds for Linear code. *)

Require Import Coqlib.
Require Import AST.
Require Import Op.
Require Import Locations.
Require Import Linear.
Require Import Conventions.

(** * Resource bounds for a function *)

(** The [bounds] record capture how many local and outgoing stack slots
  and callee-save registers are used by a function. *)

(** We demand that all bounds are positive or null.
  These properties are used later to reason about the layout of
  the activation record. *)

Record bounds : Type := mkbounds {
  bound_local: Z;
  bound_int_callee_save: Z;
  bound_float_callee_save: Z;
  bound_outgoing: Z;
  bound_stack_data: Z;
  bound_local_pos: bound_local >= 0;
  bound_int_callee_save_pos: bound_int_callee_save >= 0;
  bound_float_callee_save_pos: bound_float_callee_save >= 0;
  bound_outgoing_pos: bound_outgoing >= 0;
  bound_stack_data_pos: bound_stack_data >= 0
}.

(** The following predicates define the correctness of a set of bounds
    for the code of a function. *)

Section WITHIN_BOUNDS.

Variable b: bounds.

Definition mreg_within_bounds (r: mreg) :=
  index_int_callee_save r < bound_int_callee_save b
  /\ index_float_callee_save r < bound_float_callee_save b.

Definition slot_within_bounds (sl: slot) (ofs: Z) (ty: typ) :=
  match sl with
  | Local => ofs + typesize ty <= bound_local b
  | Outgoing => ofs + typesize ty <= bound_outgoing b
  | Incoming => True
  end.

Definition instr_within_bounds (i: instruction) :=
  match i with
  | Lgetstack sl ofs ty r => slot_within_bounds sl ofs ty /\ mreg_within_bounds r
  | Lsetstack r sl ofs ty => slot_within_bounds sl ofs ty
  | Lop op args res => mreg_within_bounds res
  | Lload chunk addr args dst => mreg_within_bounds dst
  | Lcall sig ros => size_arguments sig <= bound_outgoing b
  | Lbuiltin ef args res =>
      forall r, In r res \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r
  | Lannot ef args =>
      forall sl ofs ty, In (S sl ofs ty) args -> slot_within_bounds sl ofs ty
  | _ => True
  end.

End WITHIN_BOUNDS.

Definition function_within_bounds (f: function) (b: bounds) : Prop :=
  forall instr, In instr f.(fn_code) -> instr_within_bounds b instr.

(** * Inference of resource bounds for a function *)

(** The resource bounds for a function are computed by a linear scan
  of its instructions. *)

Section BOUNDS.

Variable f: function.

(** In the proof of the [Stacking] pass, we only need to bound the
  registers written by an instruction.  Therefore, this function
  returns these registers, ignoring registers used only as
  arguments. *)

Definition regs_of_instr (i: instruction) : list mreg :=
  match i with
  | Lgetstack sl ofs ty r => r :: nil
  | Lsetstack r sl ofs ty => r :: nil
  | Lop op args res => res :: nil
  | Lload chunk addr args dst => dst :: nil
  | Lstore chunk addr args src => nil
  | Lcall sig ros => nil
  | Ltailcall sig ros => nil
  | Lbuiltin ef args res => res ++ destroyed_by_builtin ef
  | Lannot ef args => nil
  | Llabel lbl => nil
  | Lgoto lbl => nil
  | Lcond cond args lbl => nil
  | Ljumptable arg tbl => nil
  | Lreturn => nil
  end.

Fixpoint slots_of_locs (l: list loc) : list (slot * Z * typ) :=
  match l with
  | nil => nil
  | S sl ofs ty :: l' => (sl, ofs, ty) :: slots_of_locs l'
  | R r :: l' => slots_of_locs l'
  end.

Definition slots_of_instr (i: instruction) : list (slot * Z * typ) :=
  match i with
  | Lgetstack sl ofs ty r => (sl, ofs, ty) :: nil
  | Lsetstack r sl ofs ty => (sl, ofs, ty) :: nil
  | Lannot ef args => slots_of_locs args
  | _ => nil
  end.

Definition max_over_list {A: Type} (valu: A -> Z) (l: list A) : Z :=
  List.fold_left (fun m l => Zmax m (valu l)) l 0.

Definition max_over_instrs (valu: instruction -> Z) : Z :=
  max_over_list valu f.(fn_code).

Definition max_over_regs_of_instr (valu: mreg -> Z) (i: instruction) : Z :=
  max_over_list valu (regs_of_instr i).

Definition max_over_slots_of_instr (valu: slot * Z * typ -> Z) (i: instruction) : Z :=
  max_over_list valu (slots_of_instr i).

Definition max_over_regs_of_funct (valu: mreg -> Z) : Z :=
  max_over_instrs (max_over_regs_of_instr valu).

Definition max_over_slots_of_funct (valu: slot * Z * typ -> Z) : Z :=
  max_over_instrs (max_over_slots_of_instr valu).

Definition int_callee_save (r: mreg) := 1 + index_int_callee_save r.

Definition float_callee_save (r: mreg) := 1 + index_float_callee_save r.

Definition local_slot (s: slot * Z * typ) :=
  match s with (Local, ofs, ty) => ofs + typesize ty | _ => 0 end.

Definition outgoing_slot (s: slot * Z * typ) :=
  match s with (Outgoing, ofs, ty) => ofs + typesize ty | _ => 0 end.

Definition outgoing_space (i: instruction) :=
  match i with Lcall sig _ => size_arguments sig | _ => 0 end.

Lemma max_over_list_pos:
  forall (A: Type) (valu: A -> Z) (l: list A),
  max_over_list valu l >= 0.
Proof.
  intros until valu. unfold max_over_list.
  assert (forall l z, fold_left (fun x y => Zmax x (valu y)) l z >= z).
  induction l; simpl; intros.
  omega. apply Zge_trans with (Zmax z (valu a)).
  auto. apply Zle_ge. apply Zmax1. auto.
Qed.

Lemma max_over_slots_of_funct_pos:
  forall (valu: slot * Z * typ -> Z), max_over_slots_of_funct valu >= 0.
Proof.
  intros. unfold max_over_slots_of_funct.
  unfold max_over_instrs. apply max_over_list_pos.
Qed.

Lemma max_over_regs_of_funct_pos:
  forall (valu: mreg -> Z), max_over_regs_of_funct valu >= 0.
Proof.
  intros. unfold max_over_regs_of_funct.
  unfold max_over_instrs. apply max_over_list_pos.
Qed.

Program Definition function_bounds :=
  mkbounds
    (max_over_slots_of_funct local_slot)
    (max_over_regs_of_funct int_callee_save)
    (max_over_regs_of_funct float_callee_save)
    (Zmax (max_over_instrs outgoing_space)
          (max_over_slots_of_funct outgoing_slot))
    (Zmax f.(fn_stacksize) 0)
    (max_over_slots_of_funct_pos local_slot)
    (max_over_regs_of_funct_pos int_callee_save)
    (max_over_regs_of_funct_pos float_callee_save)
    _ _.
Next Obligation.
  apply Zle_ge. eapply Zle_trans. 2: apply Zmax2.
  apply Zge_le. apply max_over_slots_of_funct_pos.
Qed.
Next Obligation.
  apply Zle_ge. apply Zmax2.
Qed.

(** We now show the correctness of the inferred bounds. *)

Lemma max_over_list_bound:
  forall (A: Type) (valu: A -> Z) (l: list A) (x: A),
  In x l -> valu x <= max_over_list valu l.
Proof.
  intros until x. unfold max_over_list.
  assert (forall c z,
            let f := fold_left (fun x y => Zmax x (valu y)) c z in
            z <= f /\ (In x c -> valu x <= f)).
    induction c; simpl; intros.
    split. omega. tauto.
    elim (IHc (Zmax z (valu a))); intros.
    split. apply Zle_trans with (Zmax z (valu a)). apply Zmax1. auto.
    intro H1; elim H1; intro.
    subst a. apply Zle_trans with (Zmax z (valu x)).
    apply Zmax2. auto. auto.
  intro. elim (H l 0); intros. auto.
Qed.

Lemma max_over_instrs_bound:
  forall (valu: instruction -> Z) i,
  In i f.(fn_code) -> valu i <= max_over_instrs valu.
Proof.
  intros. unfold max_over_instrs. apply max_over_list_bound; auto.
Qed.

Lemma max_over_regs_of_funct_bound:
  forall (valu: mreg -> Z) i r,
  In i f.(fn_code) -> In r (regs_of_instr i) ->
  valu r <= max_over_regs_of_funct valu.
Proof.
  intros. unfold max_over_regs_of_funct.
  apply Zle_trans with (max_over_regs_of_instr valu i).
  unfold max_over_regs_of_instr. apply max_over_list_bound. auto.
  apply max_over_instrs_bound. auto.
Qed.

Lemma max_over_slots_of_funct_bound:
  forall (valu: slot * Z * typ -> Z) i s,
  In i f.(fn_code) -> In s (slots_of_instr i) ->
  valu s <= max_over_slots_of_funct valu.
Proof.
  intros. unfold max_over_slots_of_funct.
  apply Zle_trans with (max_over_slots_of_instr valu i).
  unfold max_over_slots_of_instr. apply max_over_list_bound. auto.
  apply max_over_instrs_bound. auto.
Qed.

Lemma int_callee_save_bound:
  forall i r,
  In i f.(fn_code) -> In r (regs_of_instr i) ->
  index_int_callee_save r < bound_int_callee_save function_bounds.
Proof.
  intros. apply Zlt_le_trans with (int_callee_save r).
  unfold int_callee_save. omega.
  unfold function_bounds, bound_int_callee_save.
  eapply max_over_regs_of_funct_bound; eauto.
Qed.

Lemma float_callee_save_bound:
  forall i r,
  In i f.(fn_code) -> In r (regs_of_instr i) ->
  index_float_callee_save r < bound_float_callee_save function_bounds.
Proof.
  intros. apply Zlt_le_trans with (float_callee_save r).
  unfold float_callee_save. omega.
  unfold function_bounds, bound_float_callee_save.
  eapply max_over_regs_of_funct_bound; eauto.
Qed.

Lemma local_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Local, ofs, ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_local function_bounds.
Proof.
  intros.
  unfold function_bounds, bound_local.
  change (ofs + typesize ty) with (local_slot (Local, ofs, ty)).
  eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma outgoing_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Outgoing, ofs, ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_outgoing function_bounds.
Proof.
  intros. change (ofs + typesize ty) with (outgoing_slot (Outgoing, ofs, ty)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_r. eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma size_arguments_bound:
  forall sig ros,
  In (Lcall sig ros) f.(fn_code) ->
  size_arguments sig <= bound_outgoing function_bounds.
Proof.
  intros. change (size_arguments sig) with (outgoing_space (Lcall sig ros)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_l. apply max_over_instrs_bound; auto.
Qed.

(** Consequently, all machine registers or stack slots mentioned by one
  of the instructions of function [f] are within bounds. *)

Lemma mreg_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall r, In r (regs_of_instr i) ->
  mreg_within_bounds function_bounds r.
Proof.
  intros. unfold mreg_within_bounds. split.
  eapply int_callee_save_bound; eauto.
  eapply float_callee_save_bound; eauto.
Qed.

Lemma slot_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall sl ty ofs, In (sl, ofs, ty) (slots_of_instr i) ->
  slot_within_bounds function_bounds sl ofs ty.
Proof.
  intros. unfold slot_within_bounds.
  destruct sl.
  eapply local_slot_bound; eauto.
  auto.
  eapply outgoing_slot_bound; eauto.
Qed.

Lemma slots_of_locs_charact:
  forall sl ofs ty l, In (sl, ofs, ty) (slots_of_locs l) <-> In (S sl ofs ty) l.
Proof.
  induction l; simpl; intros.
  tauto.
  destruct a; simpl; intuition congruence.
Qed.

(** It follows that every instruction in the function is within bounds,
    in the sense of the [instr_within_bounds] predicate. *)

Lemma instr_is_within_bounds:
  forall i,
  In i f.(fn_code) ->
  instr_within_bounds function_bounds i.
Proof.
  intros;
  destruct i;
  generalize (mreg_is_within_bounds _ H); generalize (slot_is_within_bounds _ H);
  simpl; intros; auto.
(* call *)
  eapply size_arguments_bound; eauto.
(* builtin *)
  apply H1. apply in_or_app; auto.
(* annot *)
  apply H0. rewrite slots_of_locs_charact; auto.
Qed.

Lemma function_is_within_bounds:
  function_within_bounds f function_bounds.
Proof.
  intros; red; intros. apply instr_is_within_bounds; auto.
Qed.

End BOUNDS.


(************************************************************
* Lambda-calculus with exceptions,                          *
* Pretty-big-step semantics                                 *
*************************************************************)

Set Implicit Arguments.
Require Export LambdaExn_Syntax.
Export BehaviorsWithoutErrors.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : beh.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Semantics *)

(** Grammar of outcomes, isomorphic to:
      Inductive out :=
        | out_ret : val -> out
        | out_exn : val -> out
        | out_div : out.
    *)

Inductive out :=
  | out_beh : beh -> out
  | out_div : out.

Coercion out_beh : beh >-> out.
Implicit Types o : out.
Notation "'out_exn' v" := (out_beh (beh_exn v)) (at level 60).

(** Grammar of extended terms *)

Inductive ext : Type :=
  | ext_trm : trm -> ext
  | ext_app_1 : out -> trm -> ext
  | ext_app_2 : val -> out -> ext
  | ext_try_1 : out -> trm -> ext
  | ext_raise_1 : out -> ext.

Coercion ext_trm : trm >-> ext.
Implicit Types e : ext.

(** Abort behavior *)

Inductive abort : out -> Prop :=
  | abort_exn : forall v, abort (out_exn v)
  | abort_div : abort out_div.

(** Evaluation judgment *)

Inductive red : ext -> out -> Prop :=
  | red_val : forall v,
      red v v
  | red_abs : forall x t,
      red (trm_abs x t) (val_clo x t)
  | red_app : forall t1 t2 o1 o,
      red t1 o1 ->
      red (ext_app_1 o1 t2) o ->
      red (trm_app t1 t2) o
  | red_app_1_abort : forall o1 t2,
      abort o1 ->
      red (ext_app_1 o1 t2) o1
  | red_app_1 : forall v1 t2 o o2,
      red t2 o2 ->
      red (ext_app_2 v1 o2) o ->
      red (ext_app_1 v1 t2) o
  | red_app_2_abort : forall v1 o2,
      abort o2 ->
      red (ext_app_2 v1 o2) o2
  | red_app_2 : forall x t3 v2 o,
      red (subst x v2 t3) o ->
      red (ext_app_2 (val_clo x t3) v2) o
  | red_try : forall t1 t2 o1 o,
      red t1 o1 ->
      red (ext_try_1 o1 t2) o ->
      red (trm_try t1 t2) o
  | red_try_1_val : forall v1 t2,
      red (ext_try_1 v1 t2) v1
  | red_try_1_exn : forall t2 o v,
      red (trm_app t2 v) o ->
      red (ext_try_1 (out_exn v) t2) o
  | red_try_1_div : forall t2,
      red (ext_try_1 out_div t2) out_div
  | red_raise : forall t1 o1 o,
      red t1 o1 ->
      red (ext_raise_1 o1) o ->
      red (trm_raise t1) o
  | red_raise_1_abort : forall o1,
      abort o1 ->
      red (ext_raise_1 o1) o1
  | red_raise_1 : forall v,
      red (ext_raise_1 v) (out_exn v)
  | red_rand : forall k,
      (ParamDeterministic -> k = 0) ->
      red trm_rand (val_int k).

(** Coevaluation judgment:
    copy-paste of the above definition,
    simply replacing [red] with [cored] *)

CoInductive cored : ext -> out -> Prop :=
  | cored_val : forall v,
      cored v v
  | cored_abs : forall x t,
      cored (trm_abs x t) (val_clo x t)
  | cored_app : forall t1 t2 o1 o,
      cored t1 o1 ->
      cored (ext_app_1 o1 t2) o ->
      cored (trm_app t1 t2) o
  | cored_app_1_abort : forall o1 t2,
      abort o1 ->
      cored (ext_app_1 o1 t2) o1
  | cored_app_1 : forall v1 t2 o o2,
      cored t2 o2 ->
      cored (ext_app_2 v1 o2) o ->
      cored (ext_app_1 v1 t2) o
  | cored_app_2_abort : forall v1 o2,
      abort o2 ->
      cored (ext_app_2 v1 o2) o2
  | cored_app_2 : forall x t3 v2 o,
      cored (subst x v2 t3) o ->
      cored (ext_app_2 (val_clo x t3) v2) o
  | cored_try : forall t1 t2 o1 o,
      cored t1 o1 ->
      cored (ext_try_1 o1 t2) o ->
      cored (trm_try t1 t2) o
  | cored_try_1_val : forall v1 t2,
      cored (ext_try_1 v1 t2) v1
  | cored_try_1_exn : forall t2 o v,
      cored (trm_app t2 v) o ->
      cored (ext_try_1 (out_exn v) t2) o
  | cored_try_1_div : forall t2,
      cored (ext_try_1 out_div t2) out_div
  | cored_raise : forall t1 o1 o,
      cored t1 o1 ->
      cored (ext_raise_1 o1) o ->
      cored (trm_raise t1) o
  | cored_raise_1_abort : forall o1,
      abort o1 ->
      cored (ext_raise_1 o1) o1
  | cored_raise_1 : forall v,
      cored (ext_raise_1 v) (out_exn v)
  | cored_rand : forall k,
      (ParamDeterministic -> k = 0) ->
      cored trm_rand (val_int k).

(** Definition of divergence *)

Definition diverge e := cored e out_div.

(*==========================================================*)
(* * Proofs *)

(************************************************************)
(* ** Basic properties of the semantics *)

Hint Constructors red cored abort.

(** Proof that [cored] contains [red] *)

Theorem red_cored : forall e o,
  red e o -> cored e o.
Proof. introv H. induction* H. Qed.

(** Proof that [red e out_div -> False] *)

Definition ext_not_diverge e :=
  let n o := o <> out_div in
  match e with
  | ext_trm _ => True
  | ext_app_1 o1 t2 => n o1
  | ext_app_2 v1 o2 => n o2
  | ext_try_1 o1 t2 => n o1
  | ext_raise_1 o1 => n o1
  end.

Hint Unfold ext_not_diverge.

Hint Extern 1 (_ <> _) => congruence.

Lemma red_not_div : forall e o,
  red e o -> ext_not_diverge e -> o <> out_div.
Proof. introv H. induction* H. Qed.

Lemma red_trm_not_div' : forall t o,
  red (ext_trm t) o -> o <> out_div.
Proof. introv H. apply* red_not_div. Qed.

Lemma red_trm_not_div : forall t,
  red (ext_trm t) out_div -> False.
Proof. introv M. applys* red_trm_not_div' M. Qed.

(** Proof that [cored] implies [red] or [diverge] *)

Ltac doi_base :=
  match goal with IH: forall _, _ |- _ =>
    eapply IH
  end;
  [ eauto | instantiate; intros ?;
    match goal with N: ~ red _ _ |- _  => false N end ].

Ltac doi := doi_base; eauto.

Ltac testi H :=
  match type of H with cored ?e ?o => tests: (red e o) end.

Lemma cored_not_red_diverge : forall e o,
  cored e o -> ~ red e o -> diverge e.
Proof.
  unfold diverge. cofix IH. introv C R.
  inverts C; try solve [ false* R ].
  testi H.
    (*details:
    constructors.
     eassumption.
     eapply IH. eassumption. intros M. applys R. constructors. eassumption. eassumption.
    *)
    constructors*.
    (* details:
    constructors.
      applys IH. eassumption. eassumption.
      constructors. auto.
    *)
    constructors~. apply* IH.
  testi H.
    constructors*.
    constructors~. apply* IH.
  constructors*.
  testi H.
    destruct o1.
      constructors*.
      constructors*.
    constructors~. apply* IH.
  constructors. doi.
  testi H.
    constructors*.
    constructors~. apply* IH.
Qed.

Corollary cored_not_diverge_red : forall e o,
  cored e o -> ~ diverge e -> red e o.
Proof.
  introv C D. apply not_not_inv. intros R.
  apply D. applys* cored_not_red_diverge.
Qed.

Corollary cored_to_diverge_or_red : forall e o,
  cored e o -> diverge e \/ red e o.
Proof.
  introv C. apply or_classic_l. intros.
  applys* cored_not_red_diverge.
Qed.

(************************************************************)
(* ** Determinacy *)

(** Definition of [deterministic] *)

Definition deterministic :=
  forall e o1 o2, red e o1 -> cored e o2 -> o1 = o2.

(** Proof that the language is deterministic *)

Ltac off :=
  try solve [ match goal with
    H: abort _ |- _ => tryfalse_invert H
  end | false ].

Lemma red_cored_deterministic :
  ParamDeterministic -> deterministic.
Proof.
  introv Det R C. gen o2. induction R; intros;
   inverts C; off; auto; try solve [ false; auto ].
  rewrite~ <- IHR2. erewrite* IHR1.
  rewrite~ <- IHR2. erewrite* IHR1.
  rewrite~ <- IHR2. erewrite* IHR1.
  rewrite~ <- IHR2. erewrite* IHR1.
  rewrite H, H0; auto.
Qed.

(** Corollary: [red] is deterministic *)

Corollary red_deterministic :
  ParamDeterministic ->
  forall e o1 o2, red e o1 -> red e o2 -> o1 = o2.
Proof.
  introv D R1 R2. hint red_cored.
  applys* red_cored_deterministic.
Qed.

(** Corollary: termination and divergence are exclusive
    for terms *)

Corollary red_not_diverge_trm :
  ParamDeterministic ->
  forall t o, red t o -> diverge t -> False.
Proof.
  introv D R1 R2. forwards M: red_cored_deterministic D R1 R2.
  applys* red_trm_not_div' M.
Qed.

(** Note that for extended terms, the above result holds only
    for those satisfying [ext_not_diverge] *)

Remark red_not_diverge_ext :
  ParamDeterministic ->
  forall e o, red e o -> diverge e -> ext_not_diverge e -> False.
Proof.
  introv D R1 R2 N. forwards M: red_cored_deterministic D R1 R2.
  applys* red_not_div M.
Qed.

(************************************************************)
(* ** Induction principle on the height of a derivation *)

(** Ideally, would be automatically generated by Coq *)

Hint Constructors red cored.

(** Copy-paste of the definition of [red], plus a depth counter *)

Inductive redh : nat -> ext -> out -> Prop :=
  | redh_val : forall n v,
      redh (S n) v v
  | redh_abs : forall n x t,
      redh (S n) (trm_abs x t) (val_clo x t)
  | redh_app : forall n t1 t2 o1 o2,
      redh n t1 o1 ->
      redh n (ext_app_1 o1 t2) o2 ->
      redh (S n) (trm_app t1 t2) o2
  | redh_app_1_abort : forall n o1 t2,
      abort o1 ->
      redh (S n) (ext_app_1 o1 t2) o1
  | redh_app_1_clo : forall n v1 t2 o o2,
      redh n t2 o2 ->
      redh n (ext_app_2 v1 o2) o ->
      redh (S n) (ext_app_1 v1 t2) o
  | redh_app_2_abort : forall n v1 o2,
      abort o2 ->
      redh (S n) (ext_app_2 v1 o2) o2
  | redh_app_2_beta : forall n x t3 v2 o,
      redh n (subst x v2 t3) o ->
      redh (S n) (ext_app_2 (val_clo x t3) v2) o
  | redh_try : forall n t1 t2 o1 o,
      redh n t1 o1 ->
      redh n (ext_try_1 o1 t2) o ->
      redh (S n) (trm_try t1 t2) o
  | redh_try_1_val : forall n v1 t2,
      redh (S n) (ext_try_1 v1 t2) v1
  | redh_try_1_exn : forall n t2 o v,
      redh n (trm_app t2 v) o ->
      redh (S n) (ext_try_1 (out_exn v) t2) o
  | redh_try_1_div : forall n t2,
      redh (S n) (ext_try_1 out_div t2) out_div
  | redh_raise : forall n t1 o1 o,
      redh n t1 o1 ->
      redh n (ext_raise_1 o1) o ->
      redh (S n) (trm_raise t1) o
  | redh_raise_1_abort : forall n o1,
      abort o1 ->
      redh (S n) (ext_raise_1 o1) o1
  | redh_raise_1 : forall n v,
      redh (S n) (ext_raise_1 v) (out_exn v)
  | redh_rand : forall n k,
      (ParamDeterministic -> k = 0) ->
      redh (S n) trm_rand (val_int k).

Hint Constructors redh.
Hint Extern 1 (_ < _) => math.

Lemma redh_lt : forall n n' e o,
  redh n e o -> n < n' -> redh n' e o.
Proof.
  introv H. gen n'. induction H; introv L;
   (destruct n' as [|n']; [ false; math | autos* ]).
Qed.

Lemma red_redh : forall e o,
  red e o -> exists n, redh n e o.
Proof.
  hint redh_lt. introv H. induction H; try induct_height.
Qed.

Lemma redh_red : forall n e o,
  redh n e o -> red e o.
Proof. introv H. induction* H. Qed.

(************************************************************)
(* ** Equivalence with the traditional big-step semantics *)

Require Import LambdaExn_Big.
Hint Constructors bigred.

(** [bigred] to [red] *)

Lemma bigred_red : forall t b,
  bigred t b -> red t b.
Proof. introv H. induction H; simpls*. Qed.

(** [red] to [bigred] *)

Lemma red_bigred : forall t b,
  red t b -> bigred t b.
Proof.
  introv R. forwards (n&R'): red_redh (rm R).
  gen b t. induction n using peano_induction.
  asserts IH: (forall m t b, redh m t b -> m < n -> bigred t b).
    intros. apply* H.
  clear H. introv R. inverts R as; auto.
  introv R1 R2. inverts R2 as.
    introv O. inverts* O.
    introv R2 R3. inverts R3 as.
      introv O. inverts* O.
      autos*.
  introv R1 R2. inverts* R2.
  introv R1 R2. inverts R2 as.
    introv O. inverts* O.
    autos*.
Qed.

(** [bigdiv] to [diverge] *)

Lemma bigdiv_diverge : forall t,
  bigdiv t -> diverge t.
Proof.
  asserts M: (forall t b, bigred t b -> cored t b).
    intros. apply red_cored. apply~ bigred_red.
  unfold diverge. cofix IH. introv H.
  inverts H; try solve [constructors*].
Qed.

(** [diverge] to [bigdiv] *)

Lemma diverge_bigdiv : forall t,
  diverge t -> bigdiv t.
Proof.
  hint red_bigred.
  cofix IH. introv R. inverts R as.
  introv R1 R2. destruct~ (cored_to_diverge_or_red R1).
    apply* bigdiv_app_1.
    inverts R2 as.
      intros. apply~ bigdiv_app_1.
      introv R2 R3. destruct~ (cored_to_diverge_or_red R2).
        apply* bigdiv_app_2.
        inverts R3 as.
          intros. apply* bigdiv_app_2.
          introv R3. apply* bigdiv_app_3.
  introv R1 R2. destruct~ (cored_to_diverge_or_red R1).
    constructors*.
    inverts R2.
      apply* bigdiv_try_2.
      apply* bigdiv_try_1.
  introv R1 R2. destruct~ (cored_to_diverge_or_red R1).
    constructors*.
    inverts R2. constructors*.
Qed.

(*************************************************************)
(* ** Bonus: an inversion principle for divergence *)

CoInductive div : ext -> Prop :=
  | div_app_div : forall t1 t2,
      div t1 ->
      div (trm_app t1 t2)
  | div_app : forall t1 t2 o1,
      red t1 o1 ->
      div (ext_app_1 o1 t2) ->
      div (trm_app t1 t2)
  | div_app_1_abort : forall t2,
      div (ext_app_1 out_div t2)
  | div_app_1_div : forall v1 t2,
      div t2 ->
      div (ext_app_1 v1 t2)
  | div_app_1_clo : forall v1 t2 o o2,
      red t2 o2 ->
      div (ext_app_2 v1 o2) ->
      div (ext_app_1 v1 t2)
  | div_app_2_abort : forall v1,
      div (ext_app_2 v1 out_div)
  | div_app_2_beta : forall x t3 v2,
      div (subst x v2 t3)  ->
      div (ext_app_2 (val_clo x t3) v2)
  | div_try_div : forall t1 t2 o1 o,
      div t1 ->
      div (trm_try t1 t2)
  | div_try : forall t1 t2 o1 o,
      red t1 o1 ->
      div (ext_try_1 o1 t2) ->
      div (trm_try t1 t2)
  | div_try_1_exn : forall t2 v,
      div (trm_app t2 v) ->
      div (ext_try_1 (out_exn v) t2)
  | div_try_1_div : forall t2,
      div (ext_try_1 out_div t2)
  | div_raise_div : forall t1,
      div t1 ->
      div (trm_raise t1)
  | div_raise : forall t1 o1,
      red t1 o1 ->
      div (ext_raise_1 o1) ->
      div (trm_raise t1)
  | div_raise_1_div :
      div (ext_raise_1 out_div).

Lemma div_diverge : forall e,
  div e -> diverge e.
Proof.
  hint red_cored.
  unfold diverge. cofix IH. introv R.
  inverts R; try solve [constructors*].
Qed.

Lemma diverge_div : forall e,
  diverge e -> div e.
Proof.
  sets C: cored_to_diverge_or_red.
  unfold diverge. cofix IH. introv R. inverts R as.
  introv R1 R2. lets [?|?]: C R1.
    apply* div_app_div.
    apply* div_app.
  introv _. constructors.
  introv R1 R2. lets [?|?]: C R1.
    apply* div_app_1_div.
    apply* div_app_1_clo.
  introv _. constructors.
  introv R. constructors*.
  introv R1 R2. lets [?|?]: C R1.
    apply* div_try_div.
    apply* div_try.
  introv R. constructors*.
  constructors*.
  introv R1 R2. lets [?|?]: C R1.
    apply* div_raise_div.
    apply* div_raise.
  constructors*.
Qed.


Require Import Bedrock.Heaps Bedrock.Reflect.
Require Bedrock.SepExpr Bedrock.Expr Bedrock.Unfolder.
Require Bedrock.Decidables.
Import Expr.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.

Set Implicit Arguments.

Module Make (ST : SepTheoryX.SepTheoryXType).
  Module SEP := SepExpr.Make ST.
  Module U := Unfolder.Make SEP.
  Module PACK := U.PACK.

  (** Just some test separation logic predicates **)
  Section Tests.
    Variables pc state : Type.

    Variable f : nat -> ST.hprop pc state nil.
    Variable h : bool -> unit -> ST.hprop pc state nil.
    Variable g : bool -> nat -> nat -> nat.

    Ltac isConst e :=
      match e with
        | true => true
        | false => true
        | O => true
        | S ?e => isConst e
        | _ => false
      end.

    Definition nat_type := {|
      Impl := nat;
      Eq := fun x y => match equiv_dec x y with
                         | left pf => Some pf
                         | _ => None
                       end
      |}.

    Definition bool_type := {|
      Impl := bool;
      Eq := fun x y => match equiv_dec x y with
                         | left pf => Some pf
                         | _ => None
                       end
      |}.

    Definition unit_type := {|
      Impl := unit;
      Eq := fun x y => match equiv_dec x y with
                         | left pf => Some pf
                         | _ => None
                       end
      |}.

    Definition types0 := nat_type :: bool_type :: unit_type :: nil.

    Definition env0 : PACK.TypeEnv (Env.listToRepr ({| Impl := pc ; Eq := fun _ _ => None |} :: {| Impl := state ; Eq := fun _ _ => None |} :: nil) EmptySet_type) (tvType 0) (tvType 1) :=
      {| PACK.Types := Env.nil_Repr EmptySet_type
       ; PACK.Funcs := fun ts => Env.nil_Repr (Default_signature _)
       ; PACK.Preds := fun ts => Env.nil_Repr (SEP.Default_predicate _ _ _)
      |}.

    Fixpoint assumptionProver (types : list type) (Hs : list (expr types)) (P : expr types) :=
      match Hs with
        | nil => false
        | H :: Hs' => match expr_seq_dec H P with
                        | Some _ => true
                        | None => assumptionProver Hs' P
                      end
      end.

    Hypothesis Hemp : forall cs, ST.himp cs (ST.emp pc state) (ST.emp pc state).
    Hypothesis Hf : forall cs, ST.himp cs (f 0) (ST.emp _ _).
    Hypothesis Hh : forall cs, ST.himp cs (h true tt) (ST.star (h true tt) (f 13)).

    Hypothesis Hf0 : forall n cs, ST.himp cs (f n) (ST.emp _ _).
    Hypothesis Hh0 : forall b u cs, ST.himp cs (h b u) (ST.star (h (negb b) tt) (f 13)).

    Hypothesis Hf1 : forall n, n <> 0 -> forall cs, ST.himp cs (f n) (ST.emp _ _).
    Hypothesis Hh1 : forall b u, b = false -> u <> tt -> forall cs, ST.himp cs (h b u) (ST.star (h b tt) (f 13)).

    (** * Creating hint databases *)

    Ltac prepare := U.prepareHints ltac:(fun x => x) pc state isConst env0.

    Definition hints_tt : U.hints.
      prepare tt tt ltac:(fun x => refine x).
    Defined.
    (*Print hints_tt.*)

    Definition hints_emp : U.hints.
      prepare Hemp Hemp ltac:(fun x => refine x).
    Defined.
    (*Print hints_emp.*)

    Definition hints_Hf : U.hints.
      prepare Hf Hemp ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hf. *)

    Definition hints_Hh : U.hints.
      prepare (Hemp, Hf) (Hemp, Hf, Hh) ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hh. *)

    Definition hints_Hf0 : U.hints.
      prepare Hf0 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hf0. *)

    Definition hints_glom : U.hints.
      prepare (Hemp, Hf, Hh, Hf0) (Hemp, Hf0, tt) ltac:(fun x => refine x).
    Defined.
    (* Print hints_glom. *)

    Definition hints_Hh0 : U.hints.
      prepare Hh0 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hh0. *)

    Definition hints_Hf1 : U.hints.
      prepare Hf1 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hf1. *)

    Definition hints_Hh1 : U.hints.
      prepare Hh1 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hh1. *)

    (** * Simplifying some goals *)

    Import U.
    Import SEP.

    Ltac exec hs := cbv beta iota zeta delta [SEP.hash forallEach Vars UVars Heap
      forward backward unfoldForward unfoldBackward fmFind Unfolder.FM.fold
        SEP.impures SEP.pures SEP.other
        Unfolder.FM.add star_SHeap multimap_join liftSHeap
        SepExpr.FM.empty SepExpr.FM.map SepExpr.FM.find ExprUnify.empty_Subst
        app rev_append map length Compare_dec.lt_eq_lt_dec
        findWithRest findWithRest' find Forward Backward
        Types PcType StateType Hints Lhs Rhs
        equiv_dec ExprUnify.exprUnifyArgs ExprUnify.fold_left_2_opt
        ExprUnify.exprUnify exprSubstU sheapSubstU EqDec_tvar tvar_rec tvar_rect sumbool_rec sumbool_rect
        eq_rec_r eq_rec eq_rect eq_sym f_equal ExprUnify.get_Eq
        nth_error value error Eq liftExpr Decidables.seq_dec ExprUnify.Subst_lookup SHeap_empty
        exists_subst ExprUnify.env_of_Subst fst snd tvarD sexprD
        Impl sheapD starred fold_right applyD
        SEP.SDomain SEP.SDenotation exprD Domain Range Denotation
        ExprUnify.Subst Compare_dec.lt_dec Compare_dec.le_dec Foralls plus minus
        Compare_dec.le_gt_dec Compare_dec.le_lt_dec
        ExprUnify.Subst_replace SemiDec_expr expr_seq_dec
        lookupAs projT1 projT2 Unfolder.allb andb Hyps
        substExpr substSexpr tvar_val_sdec

        hs
        Peano_dec.eq_nat_dec nat_eq_eqdec nat_rec nat_rect
        bool_eqdec Bool.bool_dec bool_rec bool_rect
        unit_eqdec unit_rec unit_rect
        assumptionProver EquivDec_nat EquivDec_bool substV Impl_
        SEP.hash'
        Prover.Prove Provers.reflexivityProver
        Prover.Summarize
        Provers.reflexivityProve expr_seq_dec
    ].

    Ltac unfolder' hs n := U.unfolder isConst hs n.
    Ltac unfolder hs := unfolder' hs 10; exec hs.
    Ltac unfolder_noexec hs := unfolder' hs 10.

    Theorem f_easy : forall cs, ST.himp cs (f 0) (ST.emp _ _).
      Time unfolder hints_Hf.
      reflexivity.
    Qed.

    Theorem f_easy2 : forall cs, ST.himp cs (ST.star (f 0) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf.
      reflexivity.
    Qed.

    Theorem f_easy3 : forall cs, ST.himp cs (ST.star (f 0) (ST.star (f 0) (f 0))) (ST.emp _ _).
      Time unfolder hints_Hf.
      reflexivity.
    Qed.

    Hypothesis Hh' : forall cs, ST.himp cs (h true tt) (ST.emp _ _).

    Definition hints_Hf_Hh' : U.hints.
      prepare (Hf, Hh') tt ltac:(fun x => refine x).
    Defined.

    Theorem f_and_h : forall cs, ST.himp cs (ST.star (h true tt) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf_Hh'.
      reflexivity.
    Qed.

    Theorem f0 : forall cs, ST.himp cs (f 42) (ST.emp _ _).
      Time unfolder hints_Hf0.
      reflexivity.
    Qed.

    Theorem f04 : forall cs, ST.himp cs (ST.star (ST.star (f 42) (f 42)) (ST.star (f 42) (f 42))) (ST.emp _ _).
      Time unfolder hints_Hf0.
      reflexivity.
    Qed.

    Hypothesis fex : forall cs, ST.himp cs (f 0) (ST.ex (fun b => h b tt)).
    Hypothesis hgo : forall b u cs, ST.himp cs (h b u) (ST.emp _ _).

    Definition hints_fex : U.hints.
      prepare (fex, hgo) tt ltac:(fun x => refine x).
    Defined.

    Theorem test_fex : forall cs, ST.himp cs (f 0) (ST.emp _ _).
      Time unfolder hints_fex.
      reflexivity.
    Qed.

    (** Backward time! *)

    Hypothesis Hb_f : forall cs, ST.himp cs (ST.emp _ _) (f 0).

    Definition hints_Hb_f : U.hints.
      prepare tt Hb_f ltac:(fun x => refine x).
    Defined.

    Theorem test_Hb_f : forall cs, ST.himp cs (ST.emp _ _) (f 0).
      Time unfolder hints_Hb_f.
      reflexivity.
    Qed.

    Theorem test_Hb_f3 : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 0) (ST.star (f 0) (f 0))).
      Time unfolder hints_Hb_f.
      reflexivity.
    Qed.

    Hypothesis f02 : forall cs, ST.himp cs (f 0) (f 2).
    Hypothesis f21 : forall cs, ST.himp cs (f 2) (f 1).

    Definition hints_f2 : U.hints.
      prepare f02 f21 ltac:(fun x => refine x).
    Defined.

    Theorem test_f2 : forall cs, ST.himp cs (f 0) (f 1).
      Time unfolder hints_f2.
      reflexivity.
    Qed.

    Theorem test_f2' : forall cs, ST.himp cs (ST.star (f 0) (ST.star (f 0) (f 0))) (ST.star (ST.star (f 1) (f 1)) (f 1)).
      Time unfolder hints_f2.
      reflexivity.
    Qed.

    Hypothesis Hb_f0 : forall n cs, ST.himp cs (ST.emp _ _) (f n).

    Definition hints_Hb_f0 : U.hints.
      prepare tt Hb_f0 ltac:(fun x => refine x).
    Defined.

    Theorem test_Hb_f0 : forall cs, ST.himp cs (ST.emp _ _) (f 42).
      Time unfolder hints_Hb_f0.
      reflexivity.
    Qed.

    Theorem test_Hb_f0' : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 42) (f 19)).
      Time unfolder hints_Hb_f0.
      reflexivity.
    Qed.

    Hypothesis fexb : forall cs, ST.himp cs (ST.ex (fun b => ST.star (h b tt) (h b tt))) (f 0).
    Hypothesis hgob : forall u b cs, ST.himp cs (ST.emp _ _) (h b u).

    Definition hints_fexb : U.hints.
      prepare tt (fexb, hgob) ltac:(fun x => refine x).
    Defined.

    Theorem test_fexb : forall cs, ST.himp cs (ST.emp _ _) (f 0).
      Time unfolder hints_fexb.
      exists true; reflexivity.
    Qed.

    Theorem test_fexb' : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 0) (f 0)).
      Time unfolder hints_fexb.
      repeat exists true; reflexivity.
    Qed.

    Hypothesis fexb' : forall cs, ST.himp cs (ST.ex (fun u => h true u)) (f 1).

    Definition hints_fexb' : U.hints.
      prepare tt (fexb, fexb', hgob) ltac:(fun x => refine x).
    Defined.

    Theorem test_fexb'' : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 0) (f 1)).
      Time unfolder hints_fexb'.
      exists true; exists tt; reflexivity.
    Qed.

    (** * Pure conjuncts *)

    Ltac easy := intros; hnf; PropXTac.propxFo.

    Theorem simple : forall cs, ST.himp cs (ST.inj (PropX.Inj True)) (ST.inj (PropX.Inj (pc := pc) (state := state) (1 = 1))).
      Time unfolder hints_tt.
    Abort.

    Hypothesis Hf1' : False -> forall cs, ST.himp cs (f 0) (ST.emp _ _).

    Definition hints_Hf1' : U.hints.
      prepare Hf1' tt ltac:(fun x => refine x).
    Defined.

    Theorem test_Hf1' : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj False)) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf1'.
    Abort.

    Theorem test_Hf1'_bad : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj True)) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf1'.
    Abort.

    Hypothesis Hf_eq0 : 0 = 0 -> forall cs, ST.himp cs (f 0) (ST.emp _ _).

    Definition hints_Hf_eq0 : U.hints.
      prepare Hf_eq0 tt ltac:(fun x => refine x).
    Defined.

    Theorem test_Hf_eq0 : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (0 = 0))) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf_eq0.
    Abort.

    Theorem test_Hf_eq0_wrong : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (0 <> 0))) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf_eq0.
    Abort.

    Hypothesis Hf_eqn : forall n, n = n -> forall cs, ST.himp cs (f n) (ST.emp _ _).

    Definition hints_Hf_eqn : U.hints.
      prepare Hf_eqn tt ltac:(fun x => refine x).
    Defined.

    Theorem test_Hf_eqn : forall n cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (n = n))) (f n)) (ST.emp _ _).
      Time unfolder hints_Hf_eqn.
    Abort.

    Theorem test_Hf_eqn_wrong : forall n cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (n <> n))) (f n)) (ST.emp _ _).
      Time unfolder hints_Hf_eqn.
      (* Also broken by change to [himp] *)
    Abort.

    (** Reflection performance testing *)

    Fixpoint many_f n :=
      match n with
        | O => f 0
        | S n' => ST.star (f 0) (many_f n')
      end.

    Theorem test_many : forall cs, ST.himp cs (many_f 19) (ST.emp _ _).
      simpl.
      Time unfolder' hints_Hf 20; exec hints_Hf.
      easy.
    Qed.

  End Tests.

End Make.


From st Require Import STLCmu.types STLCmuST.types.
From st.prelude Require Export generic autosubst.

Fixpoint embed (τ : STLCmu.types.type) : STLCmuST.types.type :=
  match τ with
  | STLCmu.types.TUnit => TUnit
  | STLCmu.types.TBool => TBool
  | STLCmu.types.TInt => TInt
  | STLCmu.types.TProd τ1 τ2 => TProd (embed τ1) (embed τ2)
  | STLCmu.types.TSum τ1 τ2 => TSum (embed τ1) (embed τ2)
  | STLCmu.types.TArrow τ1 τ2 => TArrow (embed τ1) (embed τ2)
  | STLCmu.types.TRec τb => TRec (embed τb)
  | STLCmu.types.TVar X => TVar X
  end.

Notation "[| τ |]" := (embed τ) (at level 4, τ at next level).

Lemma etype_ren_gen τ :
  forall k l, [| τ.[upn l (ren (+k))] |] = [|τ|].[upn l (ren (+k))].
Proof.
  induction τ; intros k l; try by asimpl.
  - asimpl. by rewrite IHτ1 IHτ2.
  - asimpl. by rewrite IHτ1 IHτ2.
  - asimpl. by rewrite IHτ1 IHτ2.
  - simpl. specialize (IHτ k (S l)). by rewrite IHτ.
  - asimpl. do 2 rewrite (iter_up l X (ren (+k))).
    destruct (lt_dec X l); by asimpl.
Qed.

Lemma embed_TRec_comm_gen (τb : STLCmu.types.type) : forall (τ : STLCmu.types.type) k,
  [| τb.[upn k (τ .: ids)] |] = [|τb|].[upn k ([|τ|] .: ids)].
Proof.
  induction τb; intros τ' k; try by asimpl.
  - asimpl. by rewrite IHτb1 IHτb2.
  - asimpl. by rewrite IHτb1 IHτb2.
  - asimpl. by rewrite IHτb1 IHτb2.
  - simpl. specialize (IHτb τ' (S k)). by rewrite IHτb.
  - asimpl.
    rewrite (iter_up k X (τ' .: ids)) (iter_up k X ([|τ'|] .: ids)).
    destruct (lt_dec X k).
      + by asimpl.
      + destruct (decide (X - k = 0)); asimpl. rewrite e. asimpl.
        cut ([| τ'.[upn 0 (ren (+k))] |] = ([| τ' |]).[upn 0 (ren (+k))]).
        by asimpl. by rewrite etype_ren_gen.
        destruct (X - k). exfalso; lia. by asimpl.
Qed.

Lemma embed_TRec_comm (τb : STLCmu.types.type) :
  [| τb.[STLCmu.types.TRec τb/]|] = [|τb|].[TRec [|τb|]/].
Proof.
  cut ([| (τb.[upn 0 ((STLCmu.types.TRec τb) .: ids)])|] = [|τb|].[upn 0 ([|(STLCmu.types.TRec τb)|] .: ids)]).
  by asimpl. apply embed_TRec_comm_gen.
Qed.

Lemma embed_pres_closed τ : ∀n, Closed_n n τ → Closed_n n [|τ|].
Proof.
  induction τ.
  1-3: intros; intro σ; asimpl; try done.
  1-3: intros; intro σ; asimpl; rewrite IHτ1; first rewrite IHτ2; first done; clear σ; closed_solver.
  intros; intro σ; asimpl. rewrite IHτ. done. clear σ. closed_solver.
  intros. simpl.
  rewrite (@ids_lt_Closed_n type _ _ _ _ _ X n).
  by apply (ids_lt_Closed_n X n).
  intros x y eq. by inversion eq.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

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

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export terms2.

Lemma isprogram_equality_implies {o} :
  forall (bterms : list (@BTerm o)),
    isprogram (oterm (Can NEquality) bterms) ->
    {t1 : NTerm $ {t2 : NTerm $ {t3 : NTerm $
     bterms = [bterm [] t1, bterm [] t2, bterm [] t3]
     # isprogram t1
     # isprogram t2
     # isprogram t3}}}.
Proof.
  introv isp.
  apply isprogram_ot_iff in isp; simpl in isp; repnd.
  repeat (destruct bterms; allsimpl; cpx).
  allunfold @num_bvars.
  destruct b; allsimpl; cpx.
  destruct l; allsimpl; cpx.
  destruct b0; allsimpl; cpx.
  repeat (destruct l; allsimpl; cpx).
  destruct b1; allsimpl; cpx.
  repeat (destruct l; allsimpl; cpx).
  generalize (isp (bterm [] n)) (isp (bterm [] n0)) (isp (bterm [] n1)); intros isp1 isp2 isp3.
  repeat (autodimp isp1 hyp).
  repeat (autodimp isp2 hyp).
  repeat (autodimp isp3 hyp).
  apply isprogram_bt_nobnd in isp1.
  apply isprogram_bt_nobnd in isp2.
  apply isprogram_bt_nobnd in isp3.
  exists n n0 n1; sp.
Qed.


Require Import Hask.Prelude.
(* Require Import Hask.Control.Iso. *)
Require Import Hask.Control.Monad.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.
Set Asymmetric Patterns.

Inductive LogicT (M : Type -> Type) `{Monad M} (A : Type) :=
  LogicT_ : forall {R : Type}, ((A -> M R -> M R) -> M R -> M R) -> LogicT M A.

Inductive LogicT' (M : Type -> Type) `{Monad M} (A : Type) :=
  LogicT_' : forall {R : Type}, ((A -> R -> M R) -> R -> M R) -> LogicT' M A.

Definition fromLogicT (M : Type -> Type) `{Monad M} (A : Type)
  (l : LogicT M A) : LogicT' M A :=
  match l with
    LogicT_ _ await =>
      LogicT_' M A (fun yield =>
        await (compose (join[M]) \o (@fmap M _ _ _) \o yield) \o pure)
  end.

Definition toLogicT (M : Type -> Type) `{Monad M} (A : Type)
  (l : LogicT' M A) : LogicT M A :=
  match l with
    LogicT_' _ await =>
      LogicT_ M A (fun yield => join \o fmap (await (fun x => yield x \o pure)))
  end.

(* The condition J2 was given by Jones and Duponcheel as a condition in their
   treatment of "compatible" monads.  I'm not yet certain what part it plays
   here.
*)
(* #[export] *)
(* Instance LogicT_Restricted_Isomorphism (M : Type -> Type) `{Monad M} (A : Type) *)
(*   (J2 : forall A B (f : M A -> M B), join \o fmap f = f \o join) *)
(*   : LogicT' M A ≅ LogicT M A := *)
(* { iso_to   := toLogicT M A *)
(* ; iso_from := fromLogicT M A *)
(* }. *)
(* jww (2015-06-17): NYI
Proof.
  intros.
  - extensionality x.
    unfold id.
    destruct x.
    unfold compose.
    simpl. f_equal.
    unfold flip, bind.
    extensionality p. extensionality q.
    unfold compose.
    rewrite <- app_fmap_compose_x.
    rewrite monad_law_3_x.
    f_equal.
    extensionality p0. extensionality q0.
    unfold compose.
    rewrite <- app_fmap_compose_x.
    rewrite monad_law_3_x.
    reflexivity.
  - extensionality x.
    unfold id. destruct x.
    unfold compose. simpl.
    unfold compose at 5.
    f_equal. extensionality x.
    rewrite <- fun_composition.
    rewrite comp_assoc.
    rewrite J2.
    rewrite <- comp_assoc.
    rewrite monad_law_2.
    rewrite comp_id_right.
    f_equal. extensionality y.
    unfold compose at 2.
    unfold compose at 1.
    extensionality x0.
    assert ((join[M]) ((fmap[M] (x y \o pure[M])) x0) =
            (join[M] \o fmap[M] (x y \o pure[M])) x0).
      auto. rewrite H0. clear H0.
    rewrite <- fun_composition.
    rewrite comp_assoc.
    rewrite J2.
    rewrite <- comp_assoc.
    rewrite monad_law_2.
    reflexivity.
Defined.
*)