(*
Copyright © 2006-2008 Russell O’Connor
Copyright © 2020 Vincent Semeria

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Export Coq.QArith.QArith.
Require Import CoRN.algebra.RSetoid.
Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.abstract_algebra.

Local Open Scope Q_scope.

Set Implicit Arguments.

(**
* Metric Space

We define a metric space over a setoid X by a ball relation B
where B e x y means that the distance between the two points
x and y is less than or equal to the rational number e ( d(x,y) <= e ).

We do not take the usual definition of a distance function d : X^2 -> R_+,
because constructively this function would have to be computable.
For example this would prevent us to define metrics on functions
d(f,g) := inf_x d(f(x), g(x))
where the infinimum does not always exist constructively.
By using ball propositions instead, we make the distance function partial,
it is not always defined. For topological applications, it is often enough
to bound the distance instead of computing it exactly, this is
precisely what the balls do.

Interestingly, this definition by balls also handles infinite distances,
by proving that forall e, not (B e x y). It generalizes the usual distance functions.

This definition uses rational numbers instead of real numbers,
which is simpler. It allows to define the real numbers as a certain metric
space, namely the Cauchy completion of the rational numbers.

Lastly, this definition could include one other property of the distance functions
e < d -> {B d x y}+{~B e x y}.
But those properties are only used late in the proofs, so we move them
as additional definitions in module Classification.v (stability and locatedness).
*)

Record is_MetricSpace {X : Type} (B: Q -> relation X) : Prop :=
{ msp_refl: forall e, 0 <= e -> Reflexive (B e)
; msp_sym: forall e, Symmetric (B e)
; msp_triangle: forall e1 e2 a b c, B e1 a b -> B e2 b c -> B (e1 + e2) a c
; msp_closed: forall e a b, (forall d, 0 < d -> B (e + d) a b) -> B e a b
; msp_nonneg : forall e a b, B e a b -> 0 <= e
; msp_stable : forall e a b, (~~B e a b) -> B e a b
}.

Record MetricSpace : Type :=
{ msp_car :> Type
; ball : Q -> msp_car -> msp_car -> Prop
; ball_e_wd : forall (e d : Q) (x y : msp_car),
    e == d -> (ball e x y <-> ball d x y)
; msp : is_MetricSpace ball
}.

(* begin hide *)
Arguments ball [m].

Definition msp_eq {m:MetricSpace} (x y : msp_car m) : Prop
  := ball 0 x y.

#[global]
Instance msp_Equiv (m : MetricSpace) : Equiv m := @msp_eq m.

Add Parametric Morphism {m:MetricSpace} : (@ball m)
    with signature Qeq ==> (@msp_eq m) ==> (@msp_eq m) ==> iff as ball_wd.
Proof.
  unfold msp_eq. split.
  - intros.
    assert (0+(x+0) == y).
    { rewrite Qplus_0_r, Qplus_0_l. exact H. }
    apply (ball_e_wd m y0 y1 H3).
    clear H H3 y.
    apply (msp_triangle (msp m)) with (b:=x0).
    apply (msp_sym (msp m)), H0.
    apply (msp_triangle (msp m)) with (b:=x1).
    exact H2. exact H1.
  - intros.
    assert (0+(y+0) == x).
    { rewrite Qplus_0_r, Qplus_0_l, H. reflexivity. }
    apply (ball_e_wd m x0 x1 H3).
    clear H H3 x.
    apply (msp_triangle (msp m)) with (b:=y0).
    exact H0. clear H0 x0.
    apply (msp_triangle (msp m)) with (b:=y1).
    exact H2.
    apply (msp_sym (msp m)), H1.
Qed.

Lemma msp_eq_refl : forall {m:MetricSpace} (x : m),
    msp_eq x x.
Proof.
  intros. apply (msp_refl (msp m) (Qle_refl 0)).
Qed.

Lemma msp_eq_sym : forall {m:MetricSpace} (x y : m),
    msp_eq x y -> msp_eq y x.
Proof.
  intros. apply (msp_sym (msp m)), H.
Qed.

Lemma msp_eq_trans : forall {m:MetricSpace} (x y z : m),
    msp_eq x y -> msp_eq y z -> msp_eq x z.
Proof.
  unfold msp_eq. intros.
  rewrite <- (ball_wd m (Qplus_0_r 0)
                     x x (msp_eq_refl x)
                     z z (msp_eq_refl z)).
  exact (msp_triangle (msp m) _ _ _ y _ H H0).
Qed.

Add Parametric Relation {m:MetricSpace} : (msp_car m) msp_eq
    reflexivity proved by (msp_eq_refl)
    symmetry proved by (msp_eq_sym)
    transitivity proved by (msp_eq_trans)
      as msp_eq_rel.
(* end hide *)

#[global]
Instance msp_Setoid (m : MetricSpace) : Setoid m := {}.

Definition msp_as_RSetoid : MetricSpace -> RSetoid
  := fun m => Build_RSetoid (msp_Setoid m).

Section Metric_Space.

(*
** Ball lemmas
*)

Variable X : MetricSpace.

(** These lemmas give direct access to the ball axioms of a metric space
*)

Lemma ball_refl : forall e (a:X), 0 <= e -> ball e a a.
Proof.
 intros. apply (msp_refl (msp X) H).
Qed.

Lemma ball_sym : forall e (a b:X), ball e a b -> ball e b a.
Proof.
 apply (msp_sym (msp X)).
Qed.

Lemma ball_triangle : forall e1 e2 (a b c:X),
    ball e1 a b -> ball e2 b c -> ball (e1 + e2) a c.
Proof.
 apply (msp_triangle (msp X)).
Qed.

Lemma ball_closed :  forall e (a b:X),
    (forall d, 0 < d -> ball (e + d) a b) -> ball e a b.
Proof.
 apply (msp_closed (msp X)).
Qed.

Lemma ball_eq : forall (a b:X), (forall e, 0 < e -> ball e a b) -> msp_eq a b.
Proof.
  intros. apply ball_closed.
  intros. rewrite Qplus_0_l.
  apply H, H0.
Qed.

Lemma ball_eq_iff : forall (a b:X),
    (forall e, 0 < e -> ball e a b) <-> msp_eq a b.
Proof.
 split.
  apply ball_eq.
 intros H e epos.
 rewrite H. apply ball_refl.
 apply Qlt_le_weak, epos.
Qed.

(** The ball constraint on a and b can always be weakened.  Here are
two forms of the weakening lemma.
*)

Lemma ball_weak : forall e d (a b:X),
    0 <= d -> ball e a b -> ball (e + d) a b.
Proof.
 intros e d a b dpos B1.
 eapply ball_triangle.
  apply B1.
 apply ball_refl. exact dpos.
Qed.

Hint Resolve ball_refl ball_triangle ball_weak : metric.

Lemma ball_weak_le : forall (e d:Q) (a b:X),
    e <= d ->  ball e a b -> ball d a b.
Proof.
 intros e d a b Hed B1.
 setoid_replace d with (e + (d-e)) by ring.
 apply (ball_triangle _ _ _ b). exact B1.
 apply ball_refl.
 unfold Qminus. rewrite <- Qle_minus_iff. exact Hed.
Qed.

(* If d(x,y) is infinite and d(x,z) is finite, then d(z,y) is infinite. *)
Lemma ball_infinite
  : forall (x y z : X) (e : Q),
    (forall d : Q, ~ball d x y)
    -> ball e x z
    -> (forall d : Q, ~ball d z y).
Proof.
  intros. intro abs.
  apply (H (e+d)).
  exact (ball_triangle e d x z y H0 abs).
Qed.

Lemma ball_stable : forall e (x y : X),
    ~~(ball e x y) -> ball e x y.
Proof.
  intros. apply (msp_stable (msp X)), H.
Qed.

End Metric_Space.
(* begin hide *)
#[global]
Hint Resolve ball_refl ball_sym ball_triangle ball_weak : metric.
(* end hide *)


From Hammer Require Import Hammer.

Require Import Rdefinitions.

Fixpoint pow (r:R) (n:nat) : R :=
match n with
| O => 1
| S n => Rmult r (pow r n)
end.


(*|
########################################################
How can I write a function of the following form in Coq?
########################################################

:Link: https://stackoverflow.com/q/47947777
|*)

(*|
Question
********

.. code-block:: coq

    f x = f (g subtermOfX)

Is recursion only allowed if the arg to the function is a direct
subterm of the arg passed so that Coq can see that it actually
terminates?
|*)

(*|
Answer
******

It's possible to write such function ``f`` if function ``g`` preserves
the property of being a subterm.

Some of the standard functions have this property, e.g. ``pred``,
``sub``:
|*)

From Coq Require Import Arith List.
Import ListNotations.

Fixpoint foo (x : nat) : nat :=
  match x with
  | O => 42
  | S x' => foo (pred x')       (* foo (x' - 1) works too *)
  end.

(*|
On the other hand some (standard) functions do not have this property,
but can be rewritten to remedy this deficiency. E.g. the standard
``tl`` function does not preserve the subterm property, so the
following fails:
|*)

Fail Fixpoint bar (xs : list nat) : list nat :=
  match xs with
  | [] => []
  | x :: xs' => bar (tl xs')
  end. (* .fails *)

(*| but if we redefine the tail function like so |*)

Fixpoint new_tl {A : Type} (xs : list A) :=
  match xs with
  | [] => xs                    (* `tl` returns `[]` here *)
  | _ :: xs' => xs'
  end.

(*| we can recover the desired property: |*)

Fixpoint bar (xs : list nat) : list nat :=
  match xs with
  | [] => []
  | x :: xs' => bar (new_tl xs')
  end.

(*|
The only difference between ``tl`` and ``new_tl`` is that in the case
of empty input list ``tl`` returns ``[]``, but ``new_tl`` returns the
original list.
|*)


Require Export XR_R2.
Require Export XR_Rplus_lt_compat.
Require Export XR_Rlt_0_1.

Local Open Scope R_scope.

Lemma R2_neq_R0 : R2 <> R0.
Proof.
  unfold not.
  intro eq.
  apply Rlt_irrefl with R0.
  pattern R0 at 2 ; rewrite <- eq.
  unfold R2.
  rewrite <- Rplus_0_l with R0.
  apply Rplus_lt_compat.
  { exact Rlt_0_1. }
  { exact Rlt_0_1. }
Qed.


Require Import Heaps.
Require Import StateTransformerConstructions.
Require Import Tactics.
Require Import Framework.
Require Import SeparationAlgebras.
Require Import Language.
Require Import Setof.
Require Import Utf8.
Require Import SetoidClass.

Module SLSASafetyParams
  (Import ht : HeapTypes)
  (Import hp : THeaps ht)
  (Import ha : THeapAtomics ht hp)
  (Import hst : THeapStateTransformers ht hp ha)
  <: SASafetyParams ha hst.

  (* The separation algebra is stores, with disjoint
      union as composition.
  *)
  Definition M := store.
  Definition M_setoid : Setoid M := store_setoid.

  (* First, overwrite is a setoid morphism. *)
  Instance overwrite_morphism : Proper
      (equiv ==> equiv ==> equiv) overwrite.
   split; intro; simpl; apply fun_equiv; rewr auto.
  Qed.

  (* Pointwise disjointness of partial functions. *)
  Definition pw_disjoint {A B} (f1 f2 : A -> option B) :=
    forall a, f1 a = None \/ f2 a = None.

  (* Which is a setoid morphism, wrt extensional
      equivalence.
  *)
  Instance pw_disjoint_morphism {A B} :
    Proper (equiv ==> equiv ==> iff)
      (pw_disjoint (A:=A) (B:=B)).
   cbv; intuition; use_foralls; rewr trivial.
  Qed.

  (* Disjointness of stores *)
  Definition st_disjoint (s1 s2 : store) :=
    pw_disjoint (heap s1) (heap s2) /\
    pw_disjoint (vars s1) (vars s2).

  Instance st_disjoint_morphism :
    Proper (equiv ==> equiv ==> iff)
      st_disjoint.
   repeat intro.
   unfold st_disjoint.
   rewr auto.
  Qed.

  (* Disjoint union of stores. *)
  Definition sepop : partial_op store :=
    fun s1 s2 =>
      {|
        defined := st_disjoint s1 s2;
        val := overwrite s1 s2
      |}.

  Instance sepop_morph :
    Proper (equiv ==> equiv ==> equiv)
      sepop.
   unfold sepop.
   split; simpl; rewr auto.
  Qed.

  (* Overwrite is commutative when disjoint *)
  Lemma disjoint_over_comm {A B} :
    forall x y : A -> option B,
      pw_disjoint x y ->
        pw_over x y == pw_over y x.
   cbv; intros.
   use_foralls.
   intuition.
    rewrite H1; destruct (y a); reflexivity.
    rewrite H1; destruct (x a); reflexivity.
  Qed.

  (* Disjoint union is commutative. *)
  Lemma sepop_comm : forall x y,
    sepop x y == sepop y x.
   split.
    cbv; firstorder.

    simpl; unfold st_disjoint.
    intuition; apply disjoint_over_comm;
    trivial.
  Qed.

  (* And associative. *)
  Lemma sepop_assoc : forall m1 m2 m3,
          lift_op sepop (sepop m1 m2) (lift_val m3)
           == lift_op sepop (lift_val m1) (sepop m2 m3).
   intros; split.
   cbv;intuition;use_foralls;intuition;
   repeat match goal with
       [H : ?X = None, H0 : context [?X] |- _] => rewrite H in H0
     | [H : context [match ?X with Some b => Some b | None => None end] |- _] => destruct X; intuition
     | [ |- context [match ?X with Some b => _ | None => _ end]] => destruct X; intuition
     end; intuition.

   intros; split; intro a;
   simpl; unfold pw_over.
   destruct (heap m1 a); intuition.
   destruct (vars m1 a); intuition.
  Qed.

  (* The unit is the empty store. *)
  Definition is_unit :=
    (fun s => (forall a, heap s a = None) /\ (forall b, vars s b = None)).

  Instance is_unit_morph : Proper (equiv ==> iff) is_unit.
   repeat intro.
   unfold is_unit;
   split; intros;
   use_foralls;
   rewr intuition.
  Qed.

  Definition sepop_unit : Setof (A:=store) :=
    {| elem := is_unit |}.

  Local Notation "a ∈ u" := (elem u a) (at level 50).

  (* There is only one unit, up to equivalence: *)
  Definition the_unit : store :=
   {|
     heap := fun _ : Loc => None;
     vars := fun _ : Var => None;
     heapBound := 0;
     heapFree := fun (m : nat) (_ : 0 <= m) => eq_refl
   |}.

  Lemma the_unit_is_unit : the_unit ∈ sepop_unit.
   cbv; easy.
  Qed.

  Hint Resolve the_unit_is_unit.

  (* There is a unit for every store *)
  Lemma sepop_unit_exists : forall m, exists i, i ∈ sepop_unit /\
                                          sepop i m == lift_val m.
   exists the_unit.
   cbv; intuition.
  Qed.

  (* There are no other units *)
  Lemma sepop_unit_min : forall m1 m2 i, i ∈ sepop_unit ->
                            (sepop i m1) == lift_val m2 ->
                             m1 == m2.
   cbv; intuition;
   use_foralls;
   rewr trivial.
  Qed.

  (* We now have a separation algebra *)
  Instance separationAlgebra : SepAlg sepop :=
    { sa_comm := sepop_comm;
      sa_assoc := sepop_assoc;
      sa_unit := sepop_unit;
      sa_unit_exists := sepop_unit_exists;
      sa_unit_min := sepop_unit_min
    }.

  (* Some convenient definitions and notations. *)
  Definition singlevar x v : Setof (A:=store) :=
    singleton (svstore x v).

  Infix "=>=" := singlevar (at level 25).

  Definition singleloc l v : Setof (A:=store) :=
    singleton (slstore l v).

  Infix "|->" := singleloc (at level 25).

  Infix "*" := (saop sepop).

  Notation "∃ x @ p" :=
     (setof_union (fun z => exists x, z == p))
     (at level 50).

  Coercion loc_val : Loc >-> Val.

  (* Now the axioms *)
  Definition axioms (p : (Setof (A:=M))) (c : Atomic) (q : (Setof (A:=M))) : Prop :=
   (∃ x, ∃ y, ∃ v, ∃ u, p = ( x =>= u * y =>= v) /\
                   c = assn x y /\
                   q = ( x =>= v * y =>= v)) \/
   (∃ x, ∃ v, ∃ l:Loc, ∃ u, p = ( x =>= l * l |-> u ) /\
                    c = mut_val x v /\
                    q = ( x =>= l * l |-> v ) ) \/
   (∃ x, ∃ y, ∃ l:Loc, ∃ v, ∃ u,
              p = ( x =>= l * l |-> u * y =>= v ) /\
              c = mut_var x y /\
              q = ( x =>= l * l |-> v * y =>= v)) \/
   (∃ x, ∃ y, ∃ l:Loc, ∃ v, ∃ u,
              p = ( x =>= l * l |-> v * y =>= u ) /\
              c = lu_var y x /\
              q = ( x =>= l * l |-> v * y =>= v)) \/
   (∃ x, ∃ y, ∃ u, ∃ v,
         p = ( x =>= u * y =>= v ) /\
         c = mkref x y /\
         q = ∃ l @ (x =>= loc_val l * l |-> v * y =>= v) )
                   .

  (* Erasure. *)
  Definition erase : M -> Setof (A:=State) :=
    fun p : M => singleton (sOK p).

  (* Now a whole lot of definitions, lemmas and tactics for proving
     atomic soundness.
  *)
  Instance sOK_morphism : Proper (equiv ==> equiv) sOK.
   firstorder.
  Qed.

  Instance pw_over_morphism2 {A B} : Proper (equiv ==> equiv ==> eq ==> eq) (pw_over (A:=A) (B:=B)).
   repeat intro.
   subst.
   apply pw_over_morphism; trivial.
  Qed.

Lemma saop__use {x y z} : saop__ sepop x y z ->
       defined (sepop x y) /\ val (sepop x y) == z.
firstorder.
Qed.

Ltac saop__tac := repeat match goal with
    [H : saop__ sepop _ _ _ |- _] =>
      generalize (saop__use H); clear H; intro H;
      destruct H
    end.

Ltac saoptac := match goal with
    [|- ?X ∈ saop _ _ _] => exists X; intuition end.

Ltac singleel := repeat
  match goal with
   [H : elem (singleton ?Y) ?X |- _] =>
      generalize (single_elem H); clear H; intro H
  end.

Notation "[[ a ]]" := (interp a).
Infix "⊆" := subsetof (at level 50).
Notation "└  a  ┘" := (erase a).

Ltac nicedestr := repeat match goal with
  | [H : exists k : _, _ |- _] => destruct H as [k H]
  | [H : _ /\ _ |- _] => destruct H
  end.

Lemma singval_facts {s a b} :
   s ∈ a =>= b ->
     vars s a = Some b /\
     (forall x, x = a \/ vars s x = None) /\
     (forall l, heap s l = None).
intro.
repeat destruct H.
rewrite <- H0 in *.
intuition; rewrite H1.
cbv.
destruct (Var_eq_dec a a); intuition.

cbv.
destruct (Var_eq_dec a x0); intuition.
Qed.

Lemma singloc_facts {s a b} :
   s ∈ a |-> b ->
     heap s a = Some b /\
     (forall l, l = a \/ heap s l = None) /\
     (forall x, vars s x = None).
intro.
repeat destruct H.
rewrite <- H0 in *.
intuition; rewrite H;
cbv.
destruct (Loc_eq_dec a a); intuition.
destruct (Loc_eq_dec a l); intuition.
Qed.

Lemma sep_facts {s x0 y0} :
   s ∈ (x0 * y0) -> exists x, exists y, x ∈ x0 /\ y ∈ y0 /\
     (forall v, (vars s v = vars x v /\ vars y v = None) \/
           (vars s v = vars y v /\ vars x v = None)) /\
     (forall l, (heap s l = heap x l /\ heap y l = None) \/
           (heap s l = heap y l /\ heap x l = None)).
intros.
repeat destruct H.
intuition.
saop__tac.
rewrite <- H0 in *.
destruct H1.
unfold pw_disjoint in *.
exists x1; exists x2; intuition.
rewrite <- H3.
simpl.
unfold pw_over.
use_foralls;
destruct (vars x1 v); intuition.
inversion H6.
rewrite <- H3; simpl; unfold pw_over.
use_foralls.
destruct (heap x1 l); intuition.
inversion H6.
Qed.

Ltac use_facts := repeat match goal with
  | [H : ?s ∈ ?a =>= ?b |- _] =>
     generalize (singval_facts H); clear H; intro H; push
  | [H : ?s ∈ ?a |-> ?b |- _] =>
     generalize (singloc_facts H); clear H; intro H; push
  | [H : ?s ∈ ?x0 * ?y0 |- _] =>
     generalize (sep_facts H); clear H; intro H; push
  end.

Lemma sep_facts_rev {s x0 y0} : forall x y,
  x ∈ x0 -> y ∈ y0 ->
   (forall v, (vars s v = vars x v /\ vars y v = None) \/
      (vars s v = vars y v /\ vars x v = None)) ->
   (forall l, (heap s l = heap x l /\ heap y l = None) \/
      (heap s l = heap y l /\ heap x l = None)) ->
        s ∈ x0 * y0.
intros.
exists s; intuition.
exists x; exists y; intuition.
split.
firstorder.

simpl; intuition;
intro;
unfold pw_over.
use_foralls.
destruct (heap x a); intuition.
inversion H7.
rewr auto.
use_foralls.
destruct (vars x a); intuition.
inversion H7.
rewr auto.
Qed.

Lemma singval_facts_rev {s a b} :
     vars s a = Some b ->
     (forall x, x = a \/ vars s x = None) ->
     (forall l, heap s l = None) ->
       s ∈ a =>= b.
intros.
exists s; intuition.
split.
firstorder.
intro.
use_foralls; cbv in *.
destruct (Var_eq_dec a a0);
intuition; rewr intuition.
Qed.

Lemma singloc_facts_rev {s a b} :
     heap s a = Some b ->
     (forall l, l = a \/ heap s l = None) ->
     (forall v, vars s v = None) ->
       s ∈ a |-> b.
intros.
exists s; intuition.
split.
intro.
use_foralls; cbv in *.
destruct (Loc_eq_dec a a0);
intuition; rewr intuition.
firstorder.
Qed.

Ltac blast := match goal with
  [H : ?X = Some _, H0 : ?X = None |- _] => rewrite H0 in H; inversion H
  end.

Ltac useoptions2 := repeat
  match goal with
  | H : ?a = ?a |- _ => clear H
  | H : Some _ = Some _ |- _ => inversion H; clear H; subst
  | H : Some _ = None |- _ => inversion H
  | H : None = Some _ |- _ => inversion H
  | H : Some _ = ?a |- _ => rewrite <- H in *
  | H : None = ?a |- _ => rewrite <- H in *
  | H : ?a = Some _ |- _ => rewrite H in *
  | H : ?a = None |- _ => rewrite H in *
  | |- Some _ = None => fail 1
  | |- None = Some _ => fail 1
  | |- Some ?x = Some ?y => cut (x=y); [intro; subst; reflexivity | idtac]
  end.

Ltac vartac := let v0 := fresh "v" in
   intro v0;
   cbv - [vars heap]; simpl;
   repeat match goal with [ H : forall v : Var, _ |- _ ] => generalize (H v0); clear H; intro H end;
   repeat match goal with [ |- context [Var_eq_dec ?x ?y] ]=> destruct (Var_eq_dec x y); subst end;
   intuition (useoptions2; auto with *).
Ltac loctac := let l0 := fresh "l" in
   intro l0;
   cbv - [vars heap]; simpl;
   repeat match goal with [ H : forall l : Loc, _ |- _ ] => generalize (H l0); clear H; intro H end;
   repeat match goal with [ |- context [Loc_eq_dec ?x ?y] ]=> destruct (Loc_eq_dec x y); subst end;
   intuition (useoptions2; auto with *).

  Ltac updatetac := intros; use_facts;
    match goal with [H: ?W ∈ ?Z |- overwrite ?X ?Y ∈ _ * ?Z ] => apply sep_facts_rev with X W end;
    [ eexists; split; reflexivity | trivial | vartac | loctac ].

  Lemma update_var : forall s x u v o, s ∈ x =>= u * o ->
               (overwrite (svstore x v) s) ∈ x =>= v * o.
   updatetac.
  Qed.

  Lemma update_loc : forall s l u v o, s ∈ l |-> u * o ->
               (overwrite (slstore l v) s) ∈ l |-> v * o.
   updatetac.
  Qed.

Existing Instance saop_smorph.

Ltac commanddes := repeat match goal with
    | [H : choice_st _ _ _ |- _] => let x:= fresh "a" in destruct H as [x H]; simpl in H
    | [H : gchoice_st _ _ _ |- _] => let x:=fresh "a" in destruct H as [x H]; simpl in H; destruct H; subst
    | [H : relseq _ _ _ _ |- _] => let x:=fresh "s" in destruct H as [x H]; simpl in H; destruct H
    | [H : guard_st _ _ _ |- _] => destruct H
    | [H : selector (equiv_guard (sOK ?u)) (sOK ?v) |- _] => assert (u == v) by apply H; clear H
    end.

Ltac blitzcomp := match goal with
    | [|- (match vars ?x ?y with | Some a => _ | None => _ end) == _ ] =>
       repeat match goal with [ H : forall v : Var, _ |- _ ] => generalize (H y) H; clear H; intro H end;
       destruct (vars x y); intuition (useoptions2; auto with *)
    | [|- (match heap ?x ?y with | Some a => _ | None => _ end) == _ ] =>
       repeat match goal with [ H : forall l : Loc, _ |- _ ] => generalize (H y) H; clear H; intro H end;
       destruct (heap x y); intuition (useoptions2; auto with *)
    end.

Ltac axbelong := repeat match goal with
   | [|- sOK ?X ∈ collapse (so_map erase _) ]=> exists (erase X); split
   | [|- sOK ?X ∈ erase _ ] => exists (sOK X); intuition
   | [|- erase ?X ∈ so_map erase _ ] => exists X; intuition
   end.

(* This tactic is supposed to rewrite two assertions
   so their differences are at the start.  It doesn't
   work completely, but good enough for now!?
 *)
Ltac matchup_ U Hu V Hv cleanup :=
  match U with
   | ?a * ?b => match V with
     | a * b => idtac
     | a * ?c => rewrite (saop_comm _ _ a b) in Hu;
          rewrite (saop_comm _ _ a c) in Hv; (matchup_ b Hu c Hv ltac:(rewrite (saop_assoc _ _ _ _ a) in Hu;rewrite (saop_assoc _ _ _ _ a) in Hv)); cleanup
     | ?c * b => (matchup_ a Hu c Hv ltac:(rewrite (saop_assoc _ _ _ _ b) in Hu;rewrite (saop_assoc _ _ _ _ b) in Hv)); cleanup
     | _ => cleanup
     end
   | _ => idtac
  end.
Ltac matchup a b :=
  let x := fresh "A" in let y := fresh "A" in
    set (x := a); set (y := b); let hA := fresh in let hB := fresh in
    assert (x == a) by reflexivity; assert (y == b) by reflexivity;
    matchup_ a hA b hB idtac.

Ltac axmatchup := match goal with
  [H : ?x ∈ ?a * ?b |- _ ∈ collapse (so_map erase ?c)] =>
    matchup (a * b) c; match goal with
    [s := a * b |- _ ] => match goal with
      [H0 : s == _ |- _ ] => unfold s in H0; rewrite H0 in H; clear s H0
      end
    end
end.

  Ltac setoid_subst := repeat match goal with
     [X : _ |- _] =>
       match goal with
        [H : X == ?Y |- _] => rewrite H in *; clear X H
        end
     end.

  Lemma lu_varAxiom x y (l:Loc) u v m :
    so_map_rel [[lu_var y x]]
     (collapse (so_map erase (x =>= l * l |-> v * y =>= u * singleton m)))
     ⊆ collapse (so_map erase (x =>= l * l |-> v * y =>= v * singleton m)).
   intros a H.
   do 6 destruct H.
   axmatchup.
   generalize (fun w => update_var _ _ _ w _ H); intro Hw.
   use_facts.
   singleel; ssubst.

   assert (a == sOK (overwrite (svstore y v) x2)).
    destruct H1; intuition; setoid_subst.
    simpl in H0.
    commanddes.
    rewrite <- H1.
    clear H1 s H0.
    rewrite H18.
    assert (vars x2 x = Some (loc_val l)).
     repeat match goal with [ H : forall v : Var, _ |- _ ] => generalize (H x); clear H; intro H end.
     intuition (useoptions2; auto with *).
    rewrite H0.
    assert (heap a1 l = Some v).
     rewrite H18.
     repeat match goal with [ H : forall l : Loc, _ |- _ ] => generalize (H l); clear H; intro H end.
     intuition (useoptions2; auto with *).
    rewrite H1.
    rewr easy.

   rewrite H2.
   axbelong.
   rewr trivial.
  Qed.

  Lemma soundAxioms :
     forall p a q, axioms p a q ->
       forall (m : M),
         subsetof (so_map_rel (interp a)
                      (collapse (so_map erase (saop sepop p (singleton m))))
                     (R_morphism:=st_morph (interp a)))
           (collapse (so_map erase (saop sepop q (singleton m)))).
   intros.
   destruct H.
   nicedestr; subst.
   intros a H.
   do 6 destruct H.
   axmatchup.
   generalize (fun w => update_var _ _ _ w _ H); intro Hw.
   use_facts.
   singleel.
   setoid_subst.

   assert (a == sOK (overwrite (svstore x v) x2)).
    destruct H1; intuition; setoid_subst.
    simpl in H0.
    commanddes.
    rewrite <- H1, H13.
    rewrite <- H13 at 2.
    clear H1 A0 H4 H13 H H0 Hw H7 H9 H12 H14.
    blitzcomp.

   rewrite H2.
   axbelong.
   rewr trivial.

   destruct H.
   nicedestr; subst.
   intros a H.
   do 6 destruct H.
   axmatchup.
   generalize (fun w => update_loc _ _ _ w _ H); intro Hw.
   use_facts.
   singleel; setoid_subst.

   assert (a == sOK (overwrite (slstore l v) x2)).
    destruct H1; intuition; setoid_subst.
    simpl in H0.
    commanddes.
    rewrite <- H1.
    rewrite H13.
    rewrite <- H13 at 2.
    blitzcomp.
    rewrite H13 at 1.
    blitzcomp.

   rewrite H2.
   axbelong.
   rewr trivial.

   destruct H.
   nicedestr; subst.
   intros a H.
   do 6 destruct H.
   axmatchup.
   generalize (fun w => update_loc _ _ _ w _ H); intro Hw.
   use_facts.
   singleel; setoid_subst.

   assert (a == sOK (overwrite (slstore l v) x2)).
    destruct H1; intuition; setoid_subst.
    simpl in H0.
    commanddes.
    rewrite <- H2.
    destruct H0.
    rewrite <- H0.
    rewrite H20.
    clear H H4.
    blitzcomp.
    clear H2.
    rewrite H20.
    blitzcomp;
    rewrite H20; rewrite <- H20 at 2;
    blitzcomp. (* chokepoint! *)

   rewrite H2.
   axbelong.
   rewr trivial.

   destruct H.
   nicedestr; subst.
   apply lu_varAxiom.

   destruct H.
   nicedestr; subst.
   intros a H.
   do 6 destruct H.
   use_facts.
   singleel; setoid_subst.

   destruct H1; intuition; setoid_subst.
    simpl in H0.
    commanddes.
    rewrite H12 in *.
    assert (vars x2 y = Some v).
     repeat match goal with [ H : forall v : Var, _ |- _ ] => generalize (H y); clear H; intro H end.
     intuition (useoptions2; auto with *).
    rewrite H2 in *.
    destruct H1.
    cbv [fst snd] in H1.
    destruct H1.
    lazy [STmp STmakep st_trans makep_st equiv_guard selector] in H14.
    rewrite <- H14.
    axbelong.
    rewrite H12.
    apply sep_facts_rev with (overwrite (svstore x x0) (overwrite (slstore x0 v) x3)) x4.
     eexists.
      exists x0; reflexivity.
      rewrite (saop_assoc _ _).
      apply sep_facts_rev with (svstore x x0) (overwrite (slstore x0 v) (svstore y v)).
       eexists; split; reflexivity.
       apply sep_facts_rev with (slstore x0 v) (svstore y v).
        eexists; split; reflexivity.
        eexists; split; reflexivity.
        vartac.
        loctac.
        vartac.
        loctac.
        rewrite H; simpl; firstorder.
        vartac.
        rewrite H12 in *.
        loctac.
  Qed.

End SLSASafetyParams.

Module SeparationLogic (Import ht : HeapTypes).
  Module Import hp := MHeaps ht.
  Module Import ha := HeapAtomics ht hp.
  Module hst := HeapStateTransformers ht hp ha.
  Module Import slsp := SLSASafetyParams ht hp ha hst.
  Module Import bs := BasicSyntax ha.
  Module Import slsafe := SA_Safety ha bs hst slsp.
  Import slsafe.msp.

  Inductive SL : V -> Syntax -> V -> Prop :=
    | SL_atom : forall p q a, axioms p a q ->
                    SL p a q
    | SL_skip : forall p, SL p skip p
    | SL_loop : forall p c, SL p c p -> SL p (c)* p
    | SL_sequence : forall p q r c1 c2,
            SL p c1 q -> SL q c2 r -> SL p (c1 ;; c2) r
    | SL_choice : forall p q c1 c2,
            SL p c1 q -> SL p c2 q -> SL p (c1 + c2) q
    | SL_frame : forall p q r c, SL p c q -> SL (p*r) c (q*r)
    | SL_parallel : forall p1 q1 p2 q2 c1 c2,
            SL p1 c1 q1 -> SL p2 c2 q2 ->
                    SL (p1 * p2) (c1 || c2) (q1 * q2)
    | SL_conseq_l : forall p1 p2 c q, subsetof p1 p2 ->
            SL p2 c q -> SL p1 c q
    | SL_conseq_r : forall p c q1 q2, SL p c q1 ->
            subsetof q1 q2 -> SL p c q2
    | SL_disj : forall P c q, (forall p, p ∈ P -> SL p c q) ->
            SL (setof_union P) c q.

  Hint Resolve Safe_atomic.
  Hint Resolve Safe_mjoin_disj.

  Lemma SL_Safe : forall p c q, SL p c q -> Safe p c q.
   induction 1; intuition.
    eauto.
    rewr auto.
    rewr auto.
    apply Safe_mjoin_disj; trivial.
  Qed.

  Hint Resolve SL_Safe.
  Hint Resolve Safe_sound.

  Theorem SL_sound : forall p c q, SL p c q ->
    forall s, s ∈ erase p ->
        forall s', myOpSem.osms c s skip s' ->
            s' ∈ erase q.
   eauto.
  Qed.

End SeparationLogic.


Require Import Bool.
Require Import SpecializedCategory Functor NaturalTransformation.
Require Import Common.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

(** This Ltac controls the simplification routine. *)

Local Ltac do_simplification :=
    repeat rewrite ?LeftIdentity, ?RightIdentity, ?FIdentityOf;
    repeat rewrite ?Associativity;
    repeat rewrite ?FCompositionOf.

Section ReifiedMorphism.
  Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type :=
  | ReifiedIdentityMorphism : forall objC C x, @ReifiedMorphism objC C x x
  | ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'
  | ReifiedNaturalTransformationMorphism : forall objB (B : SpecializedCategory objB)
                                                  objC (C : SpecializedCategory objC)
                                                  (F G : SpecializedFunctor B C)
                                                  (T : SpecializedNaturalTransformation F G)
                                                  x,
                                             ReifiedMorphism C (F x) (G x)
  | ReifiedFunctorMorphism : forall objB (B : SpecializedCategory objB)
                                    objC (C : SpecializedCategory objC)
                                    (F : SpecializedFunctor B C)
                                    s d,
                               @ReifiedMorphism objB B s d -> @ReifiedMorphism objC C (F s) (F d)
  | ReifiedGenericMorphism : forall objC (C : SpecializedCategory objC) s d, Morphism C s d -> @ReifiedMorphism objC C s d.

  Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d :=
    match m in @ReifiedMorphism objC C s d return Morphism C s d with
      | ReifiedIdentityMorphism _ _ x => Identity x
      | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1)
                                                           (@ReifiedMorphismDenote _ _ _ _ m2)
      | ReifiedNaturalTransformationMorphism _ _ _ _ _ _ T x => T x
      | ReifiedFunctorMorphism _ _ _ _ F _ _ m => MorphismOf F (@ReifiedMorphismDenote _ _ _ _ m)
      | ReifiedGenericMorphism _ _ _ _ m => m
    end.
End ReifiedMorphism.

Ltac Ltac_reify_morphism m :=
  let objC := match type of m with @Morphism ?objC _ ?s ?d => constr:(objC) end in
  let C := match type of m with @Morphism ?objC ?C ?s ?d => constr:(C) end in
  let s := match type of m with @Morphism ?objC _ ?s ?d => constr:(s) end in
  let d := match type of m with @Morphism ?objC _ ?s ?d => constr:(d) end in
  match m with
    | @Identity _ _ ?x => constr:(@ReifiedIdentityMorphism _ C x)
    | Compose ?m1 ?m2 => let m1' := Ltac_reify_morphism m1 in
                         let m2' := Ltac_reify_morphism m2 in
                         constr:(@ReifiedComposedMorphism _ _ _ _ _ m1' m2')
    | ComponentsOf ?T ?x => constr:(@ReifiedNaturalTransformationMorphism _ _ _ _ _ _ T x)
    | MorphismOf ?F ?m => let m' := Ltac_reify_morphism m in
                          constr:(@ReifiedFunctorMorphism _ _ _ _ F _ _ m')
    | ReifiedMorphismDenote ?m' => constr:(m')
    | _ => constr:(@ReifiedGenericMorphism objC C s d m)
  end.

Section SimplifiedMorphism.
  Fixpoint ReifiedHasIdentities `(m : @ReifiedMorphism objC C s d) : bool
    := match m with
         | ReifiedIdentityMorphism _ _ _ => true
         | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => orb (@ReifiedHasIdentities _ _ _ _ m1) (@ReifiedHasIdentities _ _ _ _ m2)
         | ReifiedNaturalTransformationMorphism _ _ _ _ _ _ _ _ => false
         | ReifiedFunctorMorphism _ _ _ _ _ _ _ m0 => (@ReifiedHasIdentities _ _ _ _ m0)
         | ReifiedGenericMorphism _ _ _ _ _ => false
       end.

  Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) {struct m}
  : { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }.
  refine match m with
           | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _
           | ReifiedFunctorMorphism _ _ _ _ F _ _ m' => _
           | ReifiedIdentityMorphism _ _ x => exist _ _ eq_refl
           | ReifiedNaturalTransformationMorphism _ _ _ _ _ _ T x => exist _ _ eq_refl
           | ReifiedGenericMorphism _ _ _ _ m => exist _ _ eq_refl
         end; clear m;
  [ destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m1) as [ m1' H1 ], (@ReifiedMorphismSimplifyWithProof _ _ _ _ m2) as [ m2' H2 ];
    clear ReifiedMorphismSimplifyWithProof;
    destruct m1';
    ((destruct m2')
       || (

         (* we failed to destruct m2', so m1' is either a functor
         thing or a natural transformation thing.  We don't care about
         either, so generalize them away *)

         match type of H1 with
             | _ = ReifiedMorphismDenote ?T => generalize dependent T; intros
         end;
         match type of m2' with
           | ReifiedMorphism _ _ (?f ?x) => generalize dependent (f x); intros; destruct m2'
         end))
    | destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m') as [ m'' ? ];
      clear ReifiedMorphismSimplifyWithProof;
      destruct m''];
  simpl in *;
  match goal with
    | [ |- { m' : _ | ?m'' = ReifiedMorphismDenote m' } ]
      => let T := type of m'' in
         let t := fresh in
         let H := fresh in
         evar (t : T);
           assert (H : t = m'');
           [ repeat match goal with
                      | [ H : ReifiedMorphismDenote _ = _ |- _ ] => rewrite H; clear H
                    end;
             do_simplification;
             subst t;
             reflexivity
           | ];
           instantiate;
           let m := (eval unfold t in t) in
           let m' := Ltac_reify_morphism m in
           (exists m');
             clear H t
  end;
  repeat match goal with
           | [ H : _ = _ |- _ ] => revert H
           | _ => clear
         end;
  intros;
  abstract (
      repeat match goal with
               | [ H : ReifiedMorphismDenote _ = _ |- _ ] => rewrite H; clear H
             end;
      do_simplification;
      reflexivity
    ).
  Defined.

  Local Ltac solve_t :=
    simpl in *;
    solve [ match goal with
              | _ => clear; reflexivity
              | _ => clear; abstract (exists eq_refl; subst; reflexivity)
              | [ H : _ = _ |- _ ] => revert H; clear; intros; abstract (exists eq_refl; subst; reflexivity)
              | [ H : true = false |- _ ] => exfalso; revert H; clear; intro H; abstract inversion H
              | _ => assumption
            end
          | repeat match goal with
                     | [ H : appcontext[orb] |- _ ] => revert H
                     | [ H : @eq bool _ _ |- _ ] => revert H
                   end;
            clear;
            intros;
            abstract (
                repeat match goal with
                         | _ => reflexivity
                         | [ H : _ |- _ ] => (apply orb_false_iff in H; destruct H)
                         | [ H : _ = false |- _ ] => rewrite H
                         | [ H : _ = true |- _ ] => rewrite H
                       end
          ) ].

  Local Ltac solve_t' :=
    repeat match goal with
             | _ => subst; solve_t
             | [ |- appcontext[match ?E with _ => _ end] ]
               => match E with
                    | ?f _ => fail 1
                    | _ => destruct E
                    | _ => match type of E with
                             | ReifiedMorphism _ ?s ?d => generalize dependent s; generalize dependent d;
                                                          intros; destruct E
                           end
                  end
           end.

  Local Ltac gen_id_H H m :=
    let H' := fresh in
    set (H' := m) in *;
      destruct H';
      simpl in H.

  Fixpoint ReifiedMorphismSimplifyWithProofNoIdentity `(C : @SpecializedCategory objC) s d
           (m : ReifiedMorphism C s d)
  : {ReifiedHasIdentities (proj1_sig (ReifiedMorphismSimplifyWithProof m)) = false}
    + { exists H : s = d, proj1_sig (ReifiedMorphismSimplifyWithProof m) = match H with eq_refl => ReifiedIdentityMorphism C s end }.
  destruct m;
  try solve [ right; clear; abstract (exists eq_refl; subst; reflexivity)
            | left; clear; reflexivity ];
  [ destruct (@ReifiedMorphismSimplifyWithProofNoIdentity _ _ _ _ m1), (@ReifiedMorphismSimplifyWithProofNoIdentity _ _ _ _ m2);
    [ left | left | left | right ]
  | destruct (@ReifiedMorphismSimplifyWithProofNoIdentity _ _ _ _ m);
    [ left | right ] ];
  clear ReifiedMorphismSimplifyWithProofNoIdentity;
  try abstract (
        destruct_head_hnf @ex;
        subst;
        simpl in *;
          repeat match goal with
                   | [ H : ReifiedHasIdentities (proj1_sig ?m) = _ |- _ ] => gen_id_H H m
                   | [ H : proj1_sig ?m = ReifiedIdentityMorphism _ _ |- _ ] => gen_id_H H m
                 end;
        repeat match goal with
                 | _ => progress subst
                 | _ => progress solve_t'
                 | [ H : ReifiedHasIdentities (?f ?x) = false |- _ ] => generalize dependent (f x); intros
                                                                                | _ => progress simpl in *
               end
      ).
  Defined.

  Section ReifiedMorphismSimplify.
    Local Arguments ReifiedMorphismSimplifyWithProof / .

    Definition ReifiedMorphismSimplify objC C s d (m : @ReifiedMorphism objC C s d)
    : ReifiedMorphism C s d
      := Eval simpl in proj1_sig (ReifiedMorphismSimplifyWithProof m).

    (*Local Arguments ReifiedMorphismSimplify / .*)
  End ReifiedMorphismSimplify.

  Lemma ReifiedMorphismSimplifyOk objC C s d (m : @ReifiedMorphism objC C s d)
  : ReifiedMorphismDenote m =
    ReifiedMorphismDenote (ReifiedMorphismSimplify m).
  Proof.
    exact (proj2_sig (ReifiedMorphismSimplifyWithProof m)).
  Qed.

  Local Arguments ReifiedMorphismSimplifyWithProofNoIdentity / .

  Definition ReifiedMorphismSimplifyNoIdentity `(C : @SpecializedCategory objC) s d
             (m : ReifiedMorphism C s d)
  : {ReifiedHasIdentities (ReifiedMorphismSimplify m) = false}
    + { exists H : s = d, ReifiedMorphismSimplify m = match H with eq_refl => ReifiedIdentityMorphism C s end }
    := Eval simpl in ReifiedMorphismSimplifyWithProofNoIdentity m.
End SimplifiedMorphism.

Ltac Ltac_rsimplify_morphisms :=
  simpl;
  let m1 := match goal with [ |- ?m1 = ?m2 ] => constr:(m1) end in
  let m2 := match goal with [ |- ?m1 = ?m2 ] => constr:(m2) end in
  let m1' := Ltac_reify_morphism m1 in
  let m2' := Ltac_reify_morphism m2 in
  change (ReifiedMorphismDenote m1' = ReifiedMorphismDenote m2');
    rewrite (ReifiedMorphismSimplifyOk m1');
    rewrite (ReifiedMorphismSimplifyOk m2');
    simpl.
(* Note: Using [lazy] in the above tactic makes ExponentialLaws die on
   OOM after 1-2 GB of RAM and 40 minutes. *)

(*******************************************************************************)
(**                Goals which are solved by [rsimplify_morphisms]            **)
(*******************************************************************************)
Section good_examples.
  Section id.
    Context `(C : @SpecializedCategory objC).
    Context `(D : @SpecializedCategory objC).
    Variables F G : SpecializedFunctor C D.
    Variable T : SpecializedNaturalTransformation F G.

    Lemma good_example_00001 (x : C) :Compose (Identity x) (Identity x) = Identity (C := C) x.
      Ltac_rsimplify_morphisms.
      reflexivity.
    Qed.

    Lemma good_example_00002 s d (m : Morphism C s d)
    : MorphismOf F (Compose m (Identity s)) = MorphismOf F m.
      Ltac_rsimplify_morphisms.
      reflexivity.
    Qed.

    Lemma good_example_00003 s d (m : Morphism C s d)
    : MorphismOf F (Compose (Identity d) m) = MorphismOf F m.
      Ltac_rsimplify_morphisms.
      reflexivity.
    Qed.
  End id.

  Lemma good_example_00004
  : forall (objC : Type) (C : SpecializedCategory objC)
           (objD : Type) (D : SpecializedCategory objD) (objC' : Type)
           (C' : SpecializedCategory objC') (objD' : Type)
           (D' : SpecializedCategory objD') (F : SpecializedFunctor C C')
           (G : SpecializedFunctor D' D) (s d d' : SpecializedFunctor D C)
           (m1 : SpecializedNaturalTransformation s d)
           (m2 : SpecializedNaturalTransformation d d') (x : objD'),
      Compose (MorphismOf F (m2 (G x))) (MorphismOf F (m1 (G x))) =
      Compose
        (Compose
           (MorphismOf F (Compose (MorphismOf d' (Identity (G x))) (m2 (G x))))
           (Identity (F (d (G x))))) (MorphismOf F (m1 (G x))).
    intros.
    Ltac_rsimplify_morphisms.
    reflexivity.
  Qed.

  Lemma good_example_00005
  : forall (objC : Type) (C : SpecializedCategory objC)
           (objD : Type) (D : SpecializedCategory objD) (objC' : Type)
           (C' : SpecializedCategory objC') (objD' : Type)
           (D' : SpecializedCategory objD') (F : SpecializedFunctor C C')
           (G : SpecializedFunctor D' D) (s d d' : SpecializedFunctor D C)
           (m1 : SpecializedNaturalTransformation s d)
           (m2 : SpecializedNaturalTransformation d d') (x : objD'),
      Compose
        (MorphismOf F
                    (Compose (MorphismOf d' (Identity (G x)))
                             (Compose (m2 (G x)) (m1 (G x))))) (Identity (F (s (G x)))) =
      Compose
        (Compose
           (MorphismOf F (Compose (MorphismOf d' (Identity (G x))) (m2 (G x))))
           (Identity (F (d (G x)))))
        (Compose
           (MorphismOf F (Compose (MorphismOf d (Identity (G x))) (m1 (G x))))
           (Identity (F (s (G x))))).
    intros.
    Ltac_rsimplify_morphisms.
    reflexivity.
  Qed.
End good_examples.

(***************************************************)
(* Confusing examples that don't quite work *)
Section bad_examples.
  Require Import SumCategory.
  Section bad_example_0001.
    Context `(C0 : SpecializedCategory objC0).
    Context `(C1 : SpecializedCategory objC1).
    Context `(D : SpecializedCategory objD).

    Variables s d d' : C0.
    Variable m1 : Morphism C0 s d.
    Variable m2 : Morphism C0 d d'.
    Variable F : SpecializedFunctor (C0 + C1) D.

    Goal MorphismOf F (s := inl _) (d := inl _) (Compose m2 m1) = Compose (MorphismOf F (s := inl _) (d := inl _) m2) (MorphismOf F (s := inl _) (d := inl _) m1).
    Ltac_rsimplify_morphisms.
    Fail reflexivity.
    Abort.
  End bad_example_0001.
End bad_examples.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
   induction l1.
   - intros. simpl. f_equal. apply IHl1.
   - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
   induction l.
   - simpl. f_equal. apply IHl.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (append x y)) (len (append y x)).
Proof.
   induction x.
   - intros. simpl. rewrite IHx. lfind. Admitted.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Language LibTactics.

Lemma appsub_to_auxas :
  forall (A B : typ) (S : arg),
    appsub S A B ->
    auxas S A.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Lemma auxas_false :
  forall (A B : typ) (S : arg),
    not (auxas S A) ->
    appsub S A B ->
    False.
Proof.
  intros.
  eapply appsub_to_auxas in H0.
  contradiction.
Qed.

Hint Resolve auxas_false : core.

Lemma appsub_determinism :
  forall (A : typ) (B1 B2 : typ) (S : arg),
    appsub S A B1 ->
    appsub S A B2 ->
    B1 = B2.
Proof.
  intros A B1 B2 C Has1 Has2.
  generalize dependent B2.
  dependent induction Has1; intros;
    dependent destruction Has2; try solve [eauto | exfalso; eauto].
  assert (D1 = D0); eauto.
  assert (D2 = D3); eauto.
  congruence.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require int.MinMax.

Parameter bag : forall (a:Type), Type.

Parameter nb_occ: forall (a:Type), a -> (bag a) -> Z.
Implicit Arguments nb_occ.

Axiom occ_non_negative : forall (a:Type), forall (b:(bag a)) (x:a),
  (0%Z <= (nb_occ x b))%Z.

(* Why3 assumption *)
Definition mem (a:Type)(x:a) (b:(bag a)): Prop := (0%Z <  (nb_occ x b))%Z.
Implicit Arguments mem.

(* Why3 assumption *)
Definition eq_bag (a:Type)(a1:(bag a)) (b:(bag a)): Prop := forall (x:a),
  ((nb_occ x a1) = (nb_occ x b)).
Implicit Arguments eq_bag.

Axiom bag_extensionality : forall (a:Type), forall (a1:(bag a)) (b:(bag a)),
  (eq_bag a1 b) -> (a1 = b).

Parameter empty_bag: forall (a:Type), (bag a).
Set Contextual Implicit.
Implicit Arguments empty_bag.
Unset Contextual Implicit.

Axiom occ_empty : forall (a:Type), forall (x:a), ((nb_occ x (empty_bag :(bag
  a))) = 0%Z).

Axiom is_empty : forall (a:Type), forall (b:(bag a)), (forall (x:a),
  ((nb_occ x b) = 0%Z)) -> (b = (empty_bag :(bag a))).

Parameter singleton: forall (a:Type), a -> (bag a).
Implicit Arguments singleton.

Axiom occ_singleton : forall (a:Type), forall (x:a) (y:a), ((x = y) /\
  ((nb_occ y (singleton x)) = 1%Z)) \/ ((~ (x = y)) /\ ((nb_occ y
  (singleton x)) = 0%Z)).

Axiom occ_singleton_eq : forall (a:Type), forall (x:a) (y:a), (x = y) ->
  ((nb_occ y (singleton x)) = 1%Z).

Axiom occ_singleton_neq : forall (a:Type), forall (x:a) (y:a), (~ (x = y)) ->
  ((nb_occ y (singleton x)) = 0%Z).

Parameter union: forall (a:Type), (bag a) -> (bag a) -> (bag a).
Implicit Arguments union.

Axiom occ_union : forall (a:Type), forall (x:a) (a1:(bag a)) (b:(bag a)),
  ((nb_occ x (union a1 b)) = ((nb_occ x a1) + (nb_occ x b))%Z).

Axiom Union_comm : forall (a:Type), forall (a1:(bag a)) (b:(bag a)),
  ((union a1 b) = (union b a1)).

Axiom Union_identity : forall (a:Type), forall (a1:(bag a)), ((union a1
  (empty_bag :(bag a))) = a1).

Axiom Union_assoc : forall (a:Type), forall (a1:(bag a)) (b:(bag a)) (c:(bag
  a)), ((union a1 (union b c)) = (union (union a1 b) c)).

Axiom bag_simpl : forall (a:Type), forall (a1:(bag a)) (b:(bag a)) (c:(bag
  a)), ((union a1 b) = (union c b)) -> (a1 = c).

Axiom bag_simpl_left : forall (a:Type), forall (a1:(bag a)) (b:(bag a))
  (c:(bag a)), ((union a1 b) = (union a1 c)) -> (b = c).

(* Why3 assumption *)
Definition add (a:Type)(x:a) (b:(bag a)): (bag a) := (union (singleton x) b).
Implicit Arguments add.

Axiom occ_add_eq : forall (a:Type), forall (b:(bag a)) (x:a) (y:a),
  (x = y) -> ((nb_occ x (add x b)) = ((nb_occ x b) + 1%Z)%Z).

Axiom occ_add_neq : forall (a:Type), forall (b:(bag a)) (x:a) (y:a),
  (~ (x = y)) -> ((nb_occ y (add x b)) = (nb_occ y b)).

Parameter card: forall (a:Type), (bag a) -> Z.
Implicit Arguments card.

Axiom Card_empty : forall (a:Type), ((card (empty_bag :(bag a))) = 0%Z).

Axiom Card_zero_empty : forall (a:Type), forall (x:(bag a)),
  ((card x) = 0%Z) -> (x = (empty_bag :(bag a))).

Axiom Card_singleton : forall (a:Type), forall (x:a),
  ((card (singleton x)) = 1%Z).

Axiom Card_union : forall (a:Type), forall (x:(bag a)) (y:(bag a)),
  ((card (union x y)) = ((card x) + (card y))%Z).

Axiom Card_add : forall (a:Type), forall (x:a) (b:(bag a)), ((card (add x
  b)) = (1%Z + (card b))%Z).

Parameter diff: forall (a:Type), (bag a) -> (bag a) -> (bag a).
Implicit Arguments diff.

Axiom Diff_occ : forall (a:Type), forall (b1:(bag a)) (b2:(bag a)) (x:a),
  ((nb_occ x (diff b1 b2)) = (Zmax 0%Z ((nb_occ x b1) - (nb_occ x b2))%Z)).

Axiom Diff_empty_right : forall (a:Type), forall (b:(bag a)), ((diff b
  (empty_bag :(bag a))) = b).

Axiom Diff_empty_left : forall (a:Type), forall (b:(bag a)),
  ((diff (empty_bag :(bag a)) b) = (empty_bag :(bag a))).

Axiom Diff_add : forall (a:Type), forall (b:(bag a)) (x:a), ((diff (add x b)
  (singleton x)) = b).

Axiom Diff_comm : forall (a:Type), forall (b:(bag a)) (b1:(bag a)) (b2:(bag
  a)), ((diff (diff b b1) b2) = (diff (diff b b2) b1)).

(* Why3 goal *)
Theorem Add_diff : forall (a:Type), forall (b:(bag a)) (x:a), (mem x b) ->
  ((add x (diff b (singleton x))) = b).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X b x H. unfold mem in H.
apply bag_extensionality.
intro y.
unfold add; rewrite occ_union.
rewrite Diff_occ.
destruct (Zmax_spec 0 (nb_occ y b - nb_occ y (singleton x)))
  as [(Ha,R)|(Ha,R)]; auto with zarith.
destruct (occ_singleton X x y) as [(H1,H2)|(H1,H2)].
subst; intuition.
generalize (occ_non_negative X b y).
omega.
Qed.


Require Import Coq.ZArith.BinInt.
Require Import coqutil.Z.Lia.

Section Riscv.

  Open Scope Z_scope.

  Record MetricLog := mkMetricLog {
    instructions: Z;
    stores: Z;
    loads: Z; (* Note that this also includes loads of the PC *)
    jumps: Z;
  }.

  Definition EmptyMetricLog := mkMetricLog 0 0 0 0.

  Definition withInstructions i log := mkMetricLog i (stores log) (loads log) (jumps log).
  Definition withStores s log := mkMetricLog (instructions log) s (loads log) (jumps log).
  Definition withLoads l log := mkMetricLog (instructions log) (stores log) l (jumps log).
  Definition withJumps j log := mkMetricLog (instructions log) (stores log) (loads log) j.

  Definition addMetricInstructions n log := withInstructions (instructions log + n) log.
  Definition addMetricStores n log := withStores (stores log + n) log.
  Definition addMetricLoads n log := withLoads (loads log + n) log.
  Definition addMetricJumps n log := withJumps (jumps log + n) log.

  Definition subMetricInstructions n log := withInstructions (instructions log - n) log.
  Definition subMetricStores n log := withStores (stores log - n) log.
  Definition subMetricLoads n log := withLoads (loads log - n) log.
  Definition subMetricJumps n log := withJumps (jumps log - n) log.

  Definition metricSub(metric: MetricLog -> Z) finalM initialM : Z :=
    Z.sub (metric finalM) (metric initialM).

  Definition metricsOp op : MetricLog -> MetricLog -> MetricLog :=
    fun initialM finalM =>
      mkMetricLog
        (op instructions initialM finalM)
        (op stores initialM finalM)
        (op loads initialM finalM)
        (op jumps initialM finalM).

  Definition metricsSub := metricsOp metricSub.

  Definition metricLeq(metric: MetricLog -> Z) m1 m2: Prop :=
    (metric m1) <= (metric m2).

  Definition metricsLeq(m1: MetricLog)(m2: MetricLog): Prop :=
    metricLeq instructions m1 m2 /\
    metricLeq stores m1 m2 /\
    metricLeq loads m1 m2 /\
    metricLeq jumps m1 m2.

  Definition metricMax(metric: MetricLog -> Z) m1 m2: Z :=
    Z.max (metric m1) (metric m2).

  Definition metricsMax := metricsOp metricMax.
End Riscv.

Declare Scope MetricH_scope.
Bind Scope MetricH_scope with MetricLog.
Delimit Scope MetricH_scope with metricsH.

Infix "<=" := metricsLeq : MetricH_scope.
Infix "-" := metricsSub : MetricH_scope.

#[export] Hint Unfold
     withInstructions
     withLoads
     withStores
     withJumps
     addMetricInstructions
     addMetricLoads
     addMetricStores
     addMetricJumps
     subMetricInstructions
     subMetricLoads
     subMetricStores
     subMetricJumps
     metricsOp
     metricSub
     metricsSub
     metricLeq
     metricsLeq
  : unf_metric_log.

Ltac unfold_MetricLog := autounfold with unf_metric_log in *.

Lemma MetricLog_eq: forall m,
    {|
      instructions := instructions m;
      stores := stores m;
      loads := loads m;
      jumps := jumps m;
    |} = m.
Proof.
  destruct m; reflexivity.
Qed.

Ltac fold_MetricLog :=
  rewrite MetricLog_eq in *.

Ltac simpl_MetricLog :=
  cbn [instructions loads stores jumps] in *.

Ltac solve_MetricLog :=
  repeat unfold_MetricLog;
  repeat simpl_MetricLog;
  blia.


Add LoadPath "../Coq".

Require Import Homotopy.

(** I found I needed these (intuitively obvious) functoriality results for
  [funext_dep] and friends.  Perhaps there's a more generic way to get the same
  results; I can't tell. It's the only immediate use of [inverse_is_retraction]
  I've run into outside Equivalences.v. *)

Section FunExtFunctorial.

    Hypotheses
      (A : Type)
      (P : A -> Type)
      (e f g : section P).

    Lemma funext_dep_distrib :
      forall (h1 : e === f) ( h2 : f === g ),
        funext_dep ( fun a => h1 a @ h2 a )
         == (funext_dep h1) @ (funext_dep h2).
    Proof.
        intros.
        set (H1 := funext_dep h1).
        set (H2 := funext_dep h2).
        path_via (funext_dep (fun a => (happly_dep H1 a) @ (happly_dep H2 a))).
        apply funext_dep.
        intro.
        apply concat2.
        unfold H1. apply opposite. apply funext_dep_compute.
        apply opposite. apply funext_dep_compute.
        path_via ( funext_dep (fun a => happly_dep (H1 @ H2) a) ).
        apply funext_dep. intro.
        clearbody H1 H2. path_induction.
        apply (inverse_is_retraction
                  (@happly_dep A P e g ; strong_funext_dep e g )).
    Defined.

    Lemma funext_dep_opp :
      forall h1 : e === g,
        funext_dep h1 == ! funext_dep (fun a => ! h1 a).
    Proof.
        intro.
        set (H := funext_dep h1).
        path_via (! funext_dep (fun a => (!happly_dep H a))).
        path_via (! funext_dep (fun a => happly_dep (! H) a)).
        assert (help := inverse_is_retraction
                           (@happly_dep A P g e; strong_funext_dep g e)).
        simpl in help.
        path_via (! (! H)).
        apply (! help (! H)).
        apply funext_dep. intro. clearbody H. induction H.  auto.
        apply funext_dep. intro.
        unfold H. apply (map opposite).
        apply funext_dep_compute.
    Defined.

    Lemma funext_dep_idh :
      funext_dep (fun a => idpath (f a)) == idpath f.
    Proof.
        path_via (funext_dep (fun a => happly_dep (idpath f) a)).
        assert (help := inverse_is_retraction
                           (@happly_dep A P f f; strong_funext_dep f f)
                           (idpath f)).
        simpl in help.
        unfold funext_dep.
        unfold strong_to_naive_funext_dep.
        auto.
    Defined.

End FunExtFunctorial.


(*
Copyright © 2006 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRIR.
Require Import CoRN.reals.Q_in_CReals.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.reals.fast.CRarctan_small.
Require Import CoRN.transc.MoreArcTan.
Require Import CoRN.tactics.CornTac.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import CoRN.stdlib_omissions.Q.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope uc_scope.

Opaque inj_Q CR.
(**
** Pi
(Please import CRpi instead)

This version is faster to compute than CRpi_slow; however it is slower to
compile.

Pi is defined as

176*arctan(1/57) + 28*arctan(1/239) - 48*arctan(1/682) + 96*arctan(1/12943).
*)
Section Pi.

Lemma small_per_57 : (-1 < (1#(57%positive)) < 1)%Q.
Proof. split; easy. Qed.

Lemma small_per_239 : (-1 < (1#(239%positive)) < 1)%Q.
Proof. split; easy. Qed.

Lemma small_per_682 : (-1 < (1#(682%positive)) < 1)%Q.
Proof. split; easy. Qed.

Lemma small_per_12943 : (-1 < (1#(12943%positive)) < 1)%Q.
Proof. split; easy. Qed.

Definition r_pi (r:Q) : CR :=
((scale (176%Z*r) (rational_arctan_small (widen_interval small_per_57)) +
  scale (28%Z*r) (rational_arctan_small (widen_interval small_per_239))) +
 (scale (-(48%Z)*r) (rational_arctan_small (widen_interval small_per_682)) +
  scale (96%Z*r) (rational_arctan_small (widen_interval small_per_12943))))%CR.

(** To prove that pi is is correct we repeatedly use the arctan sum law.
The problem is that the arctan sum law only works for input between -1
and 1.  We use reflect to show that our use of arctan sum law always
satifies this restriction. *)

Let f (a b:Q) : Q :=
 let (x,y) := a in
 let (z,w) := b in
 Qred ((x*w + y*z)%Z/(y*w-x*z)%Z).

Lemma f_char : forall a b, f a b == (a+b)/(1-a*b).
Proof.
 intros [x y] [w z].
 unfold f.
 rewrite -> Qred_correct.
 destruct (Z.eq_dec (y*z) (x*w)) as [H|H].
  unfold Qmult.
  simpl ((Qnum (x # y) * Qnum (w # z) # Qden (x # y) * Qden (w # z))).
  repeat rewrite <- H.
  replace (y * z - y * z)%Z with 0%Z by ring.
  setoid_replace (1-(y * z # y * z)) with 0.
   change ((x * z + y * w)%Z * 0 == ((x # y) + (w # z)) * 0).
   ring.
  rewrite -> (Qmake_Qdiv (y*z)).
  change (1 - (y * z)%positive / (y * z)%positive == 0).
  field; discriminate.
 unfold Zminus.
 repeat rewrite -> injz_plus.
 change (((x * Zpos z) + (Zpos y * w)) / (Zpos y * Zpos z - x * w) == ((x # y) + (w # z)) / (1 - (x #y)*(w # z))).
 repeat rewrite -> Qmake_Qdiv.
 field.
 repeat split; try discriminate.
 cut (~(y * z)%Z == (x * w)%Z).
  intros X Y.
  apply X.
  replace RHS with ((x * w)%Z + 0) by simpl; ring.
  rewrite <- Y.
  change ((y * z) == (x * w) + (y * z - x * w)).
  ring.
 intros X; apply H.
 unfold Qeq in X.
 simpl in X.
 rewrite Pmult_1_r in X.
 change  ((y * z)%Z = (x * w * 1)%Z) in X.
 rewrite X.
 ring.
Qed.

Lemma ArcTan_plus_ArcTan_Q : forall x y, -(1) <= x <= 1 -> -(1) <= y <= 1 -> ~1-x*y==0 ->
 (ArcTan (inj_Q _ x)[+]ArcTan (inj_Q _ y)[=]ArcTan (inj_Q _ (f x y))).
Proof.
 intros x y [Hx0 Hx1] [Hy0 Hy1] H.
 assert (X:forall z, -(1) <= z -> [--][1][<=]inj_Q IR z).
  intros z Hz.
  stepl ((inj_Q IR (-(1)))).
   apply inj_Q_leEq; assumption.
  eapply eq_transitive.
   apply (inj_Q_inv IR (1)).
  apply un_op_wd_unfolded.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 assert (X0:forall z, z <= 1 -> inj_Q IR z[<=][1]).
  intros z Hz.
  stepr ((inj_Q IR ((1)))).
   apply inj_Q_leEq; assumption.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 assert ([1][-](inj_Q IR x)[*](inj_Q IR y)[#][0]).
  stepl (inj_Q IR (1[-]x[*]y)).
   (stepr (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]).
   apply inj_Q_ap; assumption.
  eapply eq_transitive.
   apply inj_Q_minus.
  apply bin_op_wd_unfolded.
   rstepr (nring 1:IR); apply (inj_Q_nring IR 1).
  apply un_op_wd_unfolded.
  apply inj_Q_mult.
 apply eq_transitive with (ArcTan (inj_Q IR x[+]inj_Q IR y[/]([1][-]inj_Q IR x[*]inj_Q IR y)[//]X1)).
  apply ArcTan_plus_ArcTan; first [apply X; assumption |apply X0; assumption].
 apply ArcTan_wd.
 stepl (inj_Q IR ((x[+]y)/([1][-]x*y))).
  apply inj_Q_wd.
  simpl.
  symmetry.
  apply f_char.
 assert (H0:(inj_Q IR ([1][-]x * y))[#][0]).
  (stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]).
  apply inj_Q_ap; assumption.
 apply eq_transitive with (inj_Q IR (x[+]y)[/]inj_Q IR ([1][-]x * y)[//]H0).
  apply (inj_Q_div).
 apply div_wd.
  apply inj_Q_plus.
 eapply eq_transitive.
  apply inj_Q_minus.
 apply bin_op_wd_unfolded.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 apply un_op_wd_unfolded.
 apply inj_Q_mult.
Qed.

Definition ArcTan_multiple : forall x, -(1) <= x <= 1 -> forall n,
  sumbool True ((nring n)[*]ArcTan (inj_Q _ x)[=]ArcTan (inj_Q _ (iter_nat n _ (f x) 0))).
Proof.
 intros x Hx.
 induction n.
  right.
  abstract ( rstepl ([0]:IR); (stepl (ArcTan [0]); [| now apply ArcTan_zero]); apply ArcTan_wd;
    apply eq_symmetric; apply (inj_Q_nring IR 0)).
 simpl.
 destruct (IHn) as [H|H].
  left; constructor.
 set (y:=(iter_nat n Q (f x) 0)) in *.
 destruct (Qlt_le_dec_fast 1 y) as [_|Y0].
  left; constructor.
 destruct (Qlt_le_dec_fast y (-(1))) as [_|Y1].
  left; constructor.
 destruct (Qeq_dec (1-x*y) 0) as [_|Y2].
  left; constructor.
 right.
 abstract ( rstepl (ArcTan (inj_Q IR x)[+](nring n[*]ArcTan (inj_Q IR x))); csetoid_rewrite H;
   apply ArcTan_plus_ArcTan_Q; try assumption; split; assumption).
Defined.

Lemma reflect_right : forall A B (x:{A}+{B}), (match x with left _ => False | right _ => True end) -> B.
Proof.
 intros A B x.
 elim x.
  contradiction.
 trivial.
Qed.

Lemma Pi_Formula :
(((nring 44)[*]ArcTan (inj_Q IR (1 /  57%Z))[-]
  (nring 12)[*]ArcTan (inj_Q IR (1 / 682%Z))[+]
  (nring  7)[*]ArcTan (inj_Q IR (1 / 239%Z))[+]
  (nring 24)[*]ArcTan (inj_Q IR (1 / 12943%Z)))[=]
 Pi[/]FourNZ).
Proof.
 assert (H0:-(1) <= (1/(57%Z)) <= 1).
  split; discriminate.
 assert (H1:-(1) <= (1/(239%Z)) <= 1).
  split; discriminate.
 assert (H2:-(1) <= (1/(682%Z)) <= 1).
  split; discriminate.
 assert (H3:-(1) <= (1/(12943%Z)) <= 1).
  split; discriminate.
 set (y0:=(iter_nat 44 _ (f (1/57%Z)) 0)).
 set (y1:=(iter_nat 7 _ (f (1/239%Z)) 0)).
 set (y2:=(iter_nat 12 _ (f (1/682%Z)) 0)).
 set (y3:=(iter_nat 24 _ (f (1/12943%Z)) 0)).
 rstepl (nring 44[*]ArcTan (inj_Q IR (1 / 57%Z))[+]
   [--](nring 12[*]ArcTan (inj_Q IR (1 / 682%Z)))[+]
     (nring 7[*]ArcTan (inj_Q IR (1 / 239%Z))[+]
       nring 24[*]ArcTan (inj_Q IR (1 / 12943%Z)))).
 csetoid_replace ((nring 44)[*]ArcTan (inj_Q IR (1 / 57%Z)))
   (ArcTan (inj_Q IR y0)); [|apply: (reflect_right (ArcTan_multiple H0 44)); now vm_compute].
 csetoid_replace ((nring 7)[*]ArcTan (inj_Q IR (1 / 239%Z))) (ArcTan (inj_Q IR y1));
   [|apply: (reflect_right (ArcTan_multiple H1 7)); now vm_compute].
 csetoid_replace ((nring 12)[*]ArcTan (inj_Q IR (1 / 682%Z))) (ArcTan (inj_Q IR y2));
   [|apply: (reflect_right (ArcTan_multiple H2 12)); now vm_compute].
 csetoid_replace ((nring 24)[*]ArcTan (inj_Q IR (1 / 12943%Z))) (ArcTan (inj_Q IR y3));
   [|apply: (reflect_right (ArcTan_multiple H3 24)); now vm_compute].
 vm_compute in y0.
 vm_compute in y1.
 vm_compute in y2.
 vm_compute in y3.
 csetoid_replace ([--](ArcTan (inj_Q IR y2))) (ArcTan (inj_Q IR (-y2)));
   [|csetoid_rewrite_rev (ArcTan_inv (inj_Q IR y2));
     apply ArcTan_wd; apply eq_symmetric; apply (inj_Q_inv IR y2)].
 csetoid_replace (ArcTan (inj_Q IR y0)[+]ArcTan (inj_Q IR (-y2))) (ArcTan (inj_Q IR (f y0 (-y2))));
   [|apply ArcTan_plus_ArcTan_Q; try split; now vm_compute].
 csetoid_replace (ArcTan (inj_Q IR y1)[+]ArcTan (inj_Q IR y3)) (ArcTan (inj_Q IR (f y1 y3)));
   [|apply ArcTan_plus_ArcTan_Q; try split; now vm_compute].
 set (z0 := (f y0 (-y2))).
 set (z1 := (f y1 y3)).
 vm_compute in z0.
 vm_compute in z1.
 csetoid_replace (ArcTan (inj_Q IR z0)[+]ArcTan (inj_Q IR z1)) (ArcTan (inj_Q IR (f z0 z1)));
   [|apply ArcTan_plus_ArcTan_Q; try split; now vm_compute].
 set (z3:= (f z0 z1)).
 vm_compute in z3.
 eapply eq_transitive;[|apply ArcTan_one].
 apply ArcTan_wd.
 rstepr (nring 1:IR).
 apply (inj_Q_nring IR 1).
Qed.

Lemma r_pi_correct : forall r, (r_pi r == IRasCR ((inj_Q IR r)[*]Pi))%CR.
Proof.
 intros r.
 unfold r_pi.
 repeat rewrite <- (CRmult_scale).
 setoid_replace (176%Z* r) with (4%Z * r * 44%Z) by (simpl; ring).
 setoid_replace (28%Z * r) with (4%Z * r * 7%Z) by (simpl; ring).
 setoid_replace (-(48)%Z * r) with (4%Z * r * -(12)%Z) by (simpl; ring).
 setoid_replace (96%Z * r) with (4%Z * r * 24%Z) by (simpl; ring).
 repeat rewrite <- CRmult_Qmult.
 transitivity ('4%Z * 'r *(' 44%Z * rational_arctan_small (widen_interval small_per_57) +
   ' 7%Z * rational_arctan_small (widen_interval small_per_239) +
     (' (-12)%Z * rational_arctan_small (widen_interval small_per_682) +
       ' 24%Z * rational_arctan_small (widen_interval small_per_12943))))%CR.
  ring.
 repeat rewrite rational_arctan_small_correct.
 repeat rewrite <- IR_inj_Q_as_CR.
 repeat (rewrite <- IR_mult_as_CR || rewrite <- IR_plus_as_CR).
 apply IRasCR_wd.
 rstepr (Four[*]inj_Q IR r[*]Pi[/]FourNZ).
 apply mult_wd.
  apply mult_wdl.
  apply (inj_Q_nring IR 4).
 eapply eq_transitive;[|apply Pi_Formula].
 rstepr (nring 44[*]ArcTan (inj_Q IR (1 / 57%Z))[+]
   nring 7[*]ArcTan (inj_Q IR (1 / 239%Z))[+]
     (([--](nring 12))[*]ArcTan (inj_Q IR (1 / 682%Z))[+]
       nring 24[*]ArcTan (inj_Q IR (1 / 12943%Z)))).
 repeat apply bin_op_wd_unfolded; try apply eq_reflexive.
    apply (inj_Q_nring IR 44).
   apply (inj_Q_nring IR 7).
  eapply eq_transitive.
   apply (inj_Q_inv IR (nring 12)).
  csetoid_rewrite (inj_Q_nring IR 12).
  apply eq_reflexive.
 apply (inj_Q_nring IR 24).
Qed.

Global Instance: Proper (Qeq ==> msp_eq) r_pi.
Proof.
  intros ? ? E. unfold r_pi.
  apply ucFun2_wd.
  apply ucFun2_wd.
  apply Cmap_wd. 2: reflexivity. simpl.
  split. discriminate. intro q. simpl.
  unfold Qmetric.Qball, Qmetric.QAbsSmall.
  rewrite E. unfold Qminus. rewrite Qplus_opp_r.
  split; discriminate.
  apply Cmap_wd. 2: reflexivity. simpl.
  split. discriminate. intro q. simpl.
  unfold Qmetric.Qball, Qmetric.QAbsSmall.
  rewrite E. unfold Qminus. rewrite Qplus_opp_r.
  split; discriminate.
  apply ucFun2_wd.
  apply Cmap_wd. 2: reflexivity. simpl.
  split. discriminate. intro q. simpl.
  unfold Qmetric.Qball, Qmetric.QAbsSmall.
  rewrite E. unfold Qminus. rewrite Qplus_opp_r.
  split; discriminate.
  apply Cmap_wd. 2: reflexivity. simpl.
  split. discriminate. intro q. simpl.
  unfold Qmetric.Qball, Qmetric.QAbsSmall.
  rewrite E. unfold Qminus. rewrite Qplus_opp_r.
  split; discriminate.
Qed.

Definition CRpi : CR := (r_pi 1).

Lemma CRpi_correct : (IRasCR Pi == CRpi)%CR.
Proof.
 unfold CRpi.
 rewrite -> r_pi_correct.
 apply IRasCR_wd.
 rstepl ((nring 1)[*]Pi).
 apply mult_wdl.
 apply eq_symmetric.
 apply (inj_Q_nring IR 1).
Qed.

End Pi.
(* begin hide *)
#[global]
Hint Rewrite CRpi_correct : IRtoCR.
(* end hide *)


(** Inspired by https://github.com/tchajed/goedel-t/blob/master/SystemT.v. *)

Require Import List Equality Relations.
Require Import Tactics.Crush.
Require Import Tactics.Tactics.

Import List.ListNotations.
Open Scope list.

Set Implicit Arguments.

Inductive type : Set :=
| ty_bool : type
| ty_nat : type
| ty_arrow : type -> type -> type
| ty_pair : type -> type -> type.

Definition typing_context := list type.

Inductive var : typing_context -> type -> Set :=
| var_h : forall Gamma t,
    var (t :: Gamma) t
| var_r : forall Gamma t t',
    var Gamma t -> var (t' :: Gamma) t.

Inductive exp (Gamma : typing_context) : type -> Set :=
| exp_var : forall t (v : var Gamma t),
    exp Gamma t
| exp_true :
    exp Gamma ty_bool
| exp_false :
    exp Gamma ty_bool
| exp_zero :
    exp Gamma ty_nat
| exp_succ : forall (e : exp Gamma ty_nat),
   exp Gamma ty_nat
| exp_iszero : forall (e : exp Gamma ty_nat),
   exp Gamma ty_bool
| exp_abs : forall t1 t2 (e : exp (t1 :: Gamma) t2),
    exp Gamma (ty_arrow t1 t2)
| exp_app : forall t1 t2 (e1 : exp Gamma (ty_arrow t1 t2)) (e2 : exp Gamma t1),
    exp Gamma t2
| exp_if : forall t (e : exp Gamma ty_bool) (e1 e2 : exp Gamma t),
    exp Gamma t
| exp_pair : forall t1 t2 (e1 : exp Gamma t1) (e2 : exp Gamma t2),
    exp Gamma (ty_pair t1 t2)
| exp_fst : forall t1 t2 (e : exp Gamma (ty_pair t1 t2)),
    exp Gamma t1
| exp_snd : forall t1 t2 (e : exp Gamma (ty_pair t1 t2)),
    exp Gamma t2.

Arguments exp_true {Gamma}.
Arguments exp_false {Gamma}.
Arguments exp_zero {Gamma}.

Inductive val : forall t, exp [] t -> Prop :=
| val_true :
    val exp_true
| val_false :
    val exp_false
| val_zero :
    val exp_zero
| val_succ : forall (e : exp [] ty_nat),
    val e -> val (exp_succ e)
| val_abs : forall t1 t2 (e : exp [t1] t2),
    val (exp_abs e)
| val_pair : forall t1 t2 (e1 : exp [] t1) (e2 : exp [] t2),
    val e1 -> val e2 -> val (exp_pair e1 e2).

Hint Constructors var exp val.

Theorem type_decidable :
  forall (t1 t2 : type), {t1 = t2} + {t1 <> t2}.
Proof.
  decide equality.
Qed.

Theorem val_decidable :
  forall t (e : exp [] t), {val e} + {~ (val e)}.
Proof.
  Ltac not_val :=
    right;
    match goal with
    [ |- _ -> False ] => let H := fresh "H" in intros H;
                         inversion H
    end.
  intros; dependent induction e; crush.
  - not_val.
  - pose proof (IHe e); crush; not_val; crush.
  - not_val.
  - not_val.
  - not_val.
  - pose proof (IHe1 e1); pose proof (IHe2 e2); crush; not_val; crush.
  - not_val.
  - not_val.
Qed.

Theorem var_found Gamma1 Gamma2 t' t
  (v : var (Gamma1 ++ [t'] ++ Gamma2) t) : var (Gamma1 ++ Gamma2) t + {t = t'}.
Proof.
  induction Gamma1; simpl in *.
  - inversion v; subst.
    + right. auto.
    + left. auto.
  - inversion v; subst.
    + left. apply var_h.
    + pose proof (IHGamma1 H2).
      destruct H. left. apply var_r. apply v0.
      right. apply e.
Qed.

Definition var_weaken Gamma1 Gamma2 t t' (v : var (Gamma1 ++ Gamma2) t) :
  var (Gamma1 ++ t' :: Gamma2) t.
Proof.
  induction Gamma1; simpl in *.
  - apply var_r. apply v.
  - inversion v.
    + apply var_h.
    + subst. apply var_r. apply IHGamma1. apply H2.
Defined.

Definition exp_weaken Gamma1 Gamma2 t t' (e : exp (Gamma1 ++ Gamma2) t) :
  exp (Gamma1 ++ t' :: Gamma2) t.
Proof.
  remember (Gamma1 ++ Gamma2) as Gamma.
  generalize dependent Gamma1.
  induction e; intros; subst.
  - apply exp_var.
    apply var_weaken. apply v.
  - apply exp_true.
  - apply exp_false.
  - apply exp_zero.
  - apply exp_succ.
    apply IHe. auto.
  - apply exp_iszero.
    apply IHe. auto.
  - apply exp_abs.
    apply (IHe (t1 :: Gamma1)). auto.
  - eapply exp_app.
    apply IHe1; auto.
    apply IHe2; auto.
  - eapply exp_if.
    apply IHe1; auto.
    apply IHe2; auto.
    apply IHe3; auto.
  - eapply exp_pair.
    apply IHe1; auto.
    apply IHe2; auto.
  - eapply exp_fst.
    apply IHe; auto.
  - eapply exp_snd.
    apply IHe; auto.
Defined.

Definition exp_weaken_nil Gamma t (e : exp [] t) : exp Gamma t.
Proof.
  induction Gamma.
  - apply e.
  - apply (exp_weaken nil).
    simpl. apply IHGamma.
Defined.

Definition subst_impl Gamma1 Gamma2 t t'
  (e' : exp [] t')
  (e : exp (Gamma1 ++ [t'] ++ Gamma2) t) : exp (Gamma1 ++ Gamma2) t.
Proof.
  remember (Gamma1 ++ [t'] ++ Gamma2) as Gamma.
  generalize dependent Gamma1.
  induction e; intros; subst.
  + apply var_found in v.
    destruct v.
    - apply exp_var. apply v.
    - subst. apply exp_weaken_nil. apply e'.
  + apply exp_true.
  + apply exp_false.
  + apply exp_zero.
  + apply exp_succ.
    apply IHe. auto.
  + apply exp_iszero.
    apply IHe. auto.
  + apply exp_abs.
    apply (IHe (t1 :: Gamma1)); auto.
  + eapply exp_app.
    apply IHe1. auto.
    apply IHe2. auto.
  + eapply exp_if.
    apply IHe1. auto.
    apply IHe2. auto.
    apply IHe3. auto.
  + apply exp_pair.
    apply IHe1. auto.
    apply IHe2. auto.
  + eapply exp_fst.
    apply IHe. auto.
  + eapply exp_snd.
    apply IHe. auto.
Defined.

Definition subst t t' (e' : exp [] t') (e : exp [t'] t) : exp [] t.
Proof.
  pose proof (subst_impl [] []).
  simpl in *. apply (H t t' e' e).
Defined.

Definition subst_all Gamma t (e : exp Gamma t)
  (H : forall t', List.In t' Gamma -> exp [] t') : exp [] t.
Proof.
  induction Gamma.
  - apply e.
  - apply IHGamma.
    assert (e' : exp [] a). { pose proof (H a). apply H0. apply in_eq. }
    pose proof (subst_impl nil Gamma). simpl in H0.
    eapply H0. apply e'. apply e. intros. apply H. crush.
Defined.

Inductive step : forall t, exp [] t -> exp [] t -> Prop :=
| step_app1 : forall t1 t2 (e1 e1' : exp [] (ty_arrow t1 t2)) e2,
    step e1 e1' ->
    step (exp_app e1 e2) (exp_app e1' e2)
| step_app2 : forall t1 t2 (e1 : exp [] (ty_arrow t1 t2)) e2 e2',
    val e1 ->
    step e2 e2' ->
    step (exp_app e1 e2) (exp_app e1 e2')
| step_abs : forall t1 t2 (e2: exp [] t1) (e: exp [t1] t2),
    val e2 ->
    step (exp_app (exp_abs e) e2) (subst e2 e)
| step_true : forall t (e1 e2 : exp [] t),
    step (exp_if exp_true e1 e2) e1
| step_false : forall t (e1 e2 : exp [] t),
    step (exp_if exp_false e1 e2) e2
| step_succ : forall (e e' : exp [] ty_nat),
    step e e' ->
    step (exp_succ e) (exp_succ e')
| step_iszero :
    step (exp_iszero exp_zero) exp_true
| step_iszero1 : forall (v : exp [] ty_nat),
    val v ->
    step (exp_iszero (exp_succ v)) exp_false
| step_iszero2 : forall (e e' : exp [] ty_nat),
    step e e' ->
    step (exp_iszero e) (exp_iszero e')
| step_if : forall t (e e' : exp [] ty_bool) (e1 e2 : exp [] t),
    step e e' ->
    step (exp_if e e1 e2) (exp_if e' e1 e2)
| step_pair1 : forall t1 t2 (e1 e1' : exp [] t1) (e2 : exp [] t2),
    step e1 e1' ->
    step (exp_pair e1 e2) (exp_pair e1' e2)
| step_pair2 : forall t1 t2 (v1 : exp [] t1) (e2 e2' : exp [] t2),
    val v1 ->
    step e2 e2' ->
    step (exp_pair v1 e2) (exp_pair v1 e2')
| step_fst : forall t1 t2 (v1 : exp [] t1) (v2 : exp [] t2),
    val v1 ->
    val v2 ->
    step (exp_fst (exp_pair v1 v2)) v1
| step_fst1 : forall t1 t2 (e e' : exp [] (ty_pair t1 t2)),
    step e e' ->
    step (exp_fst e) (exp_fst e')
| step_snd : forall t1 t2 (v1 : exp [] t1) (v2 : exp [] t2),
    val v1 ->
    val v2 ->
    step (exp_snd (exp_pair v1 v2)) v2
| step_snd1 : forall t1 t2 (e e' : exp [] (ty_pair t1 t2)),
    step e e' ->
    step (exp_snd e) (exp_snd e').

Notation "e ==> e'" := (step e e') (at level 50).
Notation "e ==>* e'" := (@clos_refl_trans_1n _ (@step _) e e') (at level 50).

Hint Constructors step.
Arguments step {t} e1 e2.

Definition irred t (e : exp [] t) := ~ (exists e', e ==> e').

Lemma bool_canonical :
  forall (e : exp [] ty_bool),
    val e -> e = exp_true \/ e = exp_false.
Proof.
  intros; inversion H; crush.
Qed.

Lemma nat_canonical :
  forall (e : exp [] ty_nat),
    val e -> e = exp_zero \/ (exists e', e = exp_succ e' /\ val e').
Proof.
  intros; inversion H; crush.
  right. eauto.
Qed.

Lemma abs_canonical :
  forall t1 t2 (e : exp [] (ty_arrow t1 t2)),
    val e -> exists e', e = exp_abs e'.
Proof.
  intros; inversion H; crush; eauto.
Qed.

Lemma pair_canonical :
  forall t1 t2 (e : exp [] (ty_pair t1 t2)),
     val e -> exists e1 e2, e = exp_pair e1 e2 /\ val e1 /\ val e2.
Proof.
  intros; inversion H; crush; eauto.
Qed.

Theorem progress :
  forall t (e : exp [] t), val e \/ exists e', e ==> e'.
Proof.
  intros.
  dependent induction e; crush.
  - inversion v.
  - pose proof (IHe e); crush.
    right. eauto.
  - pose proof (IHe e); crush.
    + right. apply nat_canonical in H0.
      destruct H0.
      * subst. eauto.
      * destruct H as [e' [H1 H2]]. subst. eauto.
    + right. eauto.
  - destruct (val_decidable e1).
    + pose proof (abs_canonical v); crush.
      destruct (val_decidable e2).
      * right. eauto.
      * right. pose proof (IHe2 e2); crush; eauto.
    + pose proof (IHe1 e1); crush.
      right. eauto.
  - destruct (val_decidable e1).
    + pose proof (bool_canonical v); crush; eauto.
    + right. pose proof (IHe1 e1); crush; eauto.
  - destruct (val_decidable e1).
    + destruct (val_decidable e2).
      * left. auto.
      * pose proof (IHe2 e2); crush; right. eauto.
    + pose proof (IHe1 e1); crush; right. eauto.
  - pose proof (IHe e); crush.
    + pose proof (pair_canonical H0); crush; right. eauto.
    + right. eauto.
  - pose proof (IHe e); crush.
    + pose proof (pair_canonical H0); crush; right. eauto.
    + right. eauto.
Qed.

Lemma irred_val_eqv :
  forall t (e : exp [] t), irred e <-> val e.
Proof.
  unfold irred; intros; split; intros.
  - pose proof (progress e). destruct H0; auto; crush.
  - dependent induction e; inversion H; crush;
    match goal with
    | [ H : step _ _ |- _ ] => inversion H
    end; crush.
    + pose proof (IHe e); crush.
      inversion H0; crush; eauto.
    + pose proof (IHe1 e1); pose proof (IHe2 e2); crush.
      inversion H0; crush; eauto.
    + pose proof (IHe1 e1); pose proof (IHe2 e2); crush.
      inversion H0; crush; eauto.
Qed.

(** Preservation is natural by this definition. *)

Theorem safety :
  forall t (e e' : exp [] t),
    e ==>* e' -> val e' \/ exists e'', e' ==> e''.
Proof.
  intros. induction H.
  - destruct (val_decidable x).
    + left. auto.
    + right. admit.
  - intuition.
Admitted.

Theorem deterministic :
  forall t (e e1 e2 : exp [] t),
    e ==> e1 -> e ==> e2 -> e1 = e2.
Proof.
  intros t e.
  Ltac amusing :=
    match goal with
    | [ H : step (exp_var _) _ |- _ ] => inversion H
    | [ H : step (exp_true) _ |- _ ] => inversion H
    | [ H : step (exp_false) _ |- _ ] => inversion H
    | [ H : step (exp_zero) _ |- _ ] => inversion H
    | [ H : step (exp_abs _) _ |- _ ] => inversion H
    | [ H1 : val ?e1, H2 : step ?e1 ?e2 |- _] =>
        apply irred_val_eqv in H1; unfold irred in H1;
        exfalso; apply H1; eauto
    | [ H1 : val ?e1, H2 : step (exp_succ ?e1) ?e2 |- _ ] =>
        let H := fresh "H" in pose proof (val_succ H1) as H; amusing
    | [ H1 : val ?e1, H2 : val ?e2, H3 : step (exp_pair ?e1 ?e2) ?e |- _ ] =>
        let H := fresh "H" in pose proof (val_pair H1 H2) as H; amusing
    end.
  dependent induction e; intros e5 e6 H1 H2; try amusing.
  - pose proof (IHe e); clear IHe; crush.
    inversion H1; inversion H2; inv_existT; f_equal; crush.
  - pose proof (IHe e); clear IHe; crush.
    inversion H1; inversion H2; inv_existT;
    solve [f_equal; crush | amusing].
  - pose proof (IHe1 e1); clear IHe1;
    pose proof (IHe2 e2); clear IHe2; crush.
    inversion H1; inversion H2; inv_existT;
    solve [f_equal; crush | amusing | inversion H6; crush].
  - pose proof (IHe1 e1); clear IHe1;
    pose proof (IHe2 e2); clear IHe2;
    pose proof (IHe3 e3); clear IHe3; crush.
    inversion H1; inversion H2; inv_existT;
    solve [f_equal; crush | amusing].
  - pose proof (IHe1 e1); clear IHe1;
    pose proof (IHe2 e2); clear IHe2; crush.
    inversion H1; inversion H2; inv_existT;
    solve [f_equal; crush | amusing].
  - pose proof (IHe e); crush.
    inversion H1; inversion H2; inv_existT;
    solve [f_equal; crush | amusing | inversion H3; crush].
  - pose proof (IHe e); crush.
    inversion H1; inversion H2; inv_existT;
    solve [f_equal; crush | amusing | inversion H3; crush].
Qed.

(*

Definition normalizable t (e : exp [] t) : Prop :=
  exists (v : exp [] t), val v /\ e ==>* v.

Fixpoint R (t : type) : exp [] t -> Prop :=
  match t with
  | ty_bool => fun e =>
      normalizable e
  | ty_nat => fun e =>
      normalizable e
  | ty_pair t1 t2 => fun e =>
      normalizable e /\
      R (exp_fst e) /\ R (exp_snd e)
  | ty_arrow t1 t2 => fun e =>
      normalizable e /\
      (forall (e' : exp [] t1), R e' -> R (exp_app e e'))
  end.

Theorem R_normalizable :
  forall t (e : exp [] t), R e -> normalizable e.
Proof.
  intros; destruct t; unfold R in *; crush.
Qed.

*)


(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

From Coq Require Import ssreflect ssrbool ssrfun.

Require Import GHC.Base.
Require Import GHC.Nat.
Require Import Proofs.GHC.Base.
Require Import Proofs.GHC.List.
Require Import Proofs.Data.Foldable.
Require Import Proofs.GhcTactics.

Require Import Coq.Lists.List.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import SetoidList.

Import ListNotations.

Open Scope Z_scope.

Set Bullet Behavior "Strict Subproofs".

(**
Some of this can migrate to [base-thy] at some point, but maybe some lemmas or
tactics are rather specific.
*)

Lemma eqlist_Foldable_elem : forall a (s s' : list a) `{EqLaws a},
      eqlistA (fun x y => x == y) s s' ->
      (forall a, Foldable.elem a s = Foldable.elem a s').
Proof.
  intros a s s' EQ EQL. intro H. induction H.
  intro x.
  rewrite elem_nil. auto.
  intro y.
  repeat rewrite -> elem_cons.
  rewrite IHeqlistA.
  erewrite eq_replace_r; eauto.
Qed.

Lemma elem_exists_in {a}`{Eq_ a} (x:a) (xs : list a) :  Foldable.elem x xs -> exists y, List.In y xs /\ (x == y).
Proof.
   elim: xs => [|y ys IH].
   hs_simpl. done.
   hs_simpl.
   move => /orP.
   move => [h1| h2].
   exists y. unfold List.In. split; auto.
   move: (IH h2) => [z [Inz eqz]].
   exists z. unfold List.In. split; auto.
Qed.

Lemma list_in_elem {a} `{Base.EqLaws a} (x:a) xs: List.In x xs -> Foldable.elem x xs.
Proof. elim: xs => [|y ys IH]. hs_simpl. auto.
hs_simpl. simpl. intuition. subst. apply /orP. left. eapply Eq_refl.
Qed.

Lemma forallb_imp:
  forall a P Q (xs : list a),
  forallb P xs = true ->
  (forall x, P x = true -> Q x = true) ->
  forallb Q xs = true.
Proof.
  induction xs; simpl; intros; auto.
  apply andb_prop in H.
  apply andb_true_intro.
  intuition.
Qed.