From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq eqtype path fintype finfun tuple interval perm fingroup.
From pcm Require Import options prelude ordtype seqext slice.

Lemma implyb_trans a b c : a ==> b -> b ==> c -> a ==> c.
Proof. by case: a=>//=->. Qed.

Section Seq.
Variable (A : Type).

Lemma rcons_nseq n (x : A) :
        rcons (nseq n x) x = nseq n.+1 x.
Proof. by elim: n=>//=n ->. Qed.

Lemma behead_rcons (xs : seq A) x :
        0 < size xs ->
        behead (rcons xs x) = rcons (behead xs) x.
Proof. by case: xs. Qed.

Lemma path_all (xs : seq A) x r :
        transitive r ->
        path r x xs -> all (r x) xs.
Proof. by move=>Ht; rewrite path_sortedE; [case/andP | exact: Ht]. Qed.

Lemma sorted_rconsE (leT : rel A) xs x :
        transitive leT ->
        sorted leT (rcons xs x) = all (leT^~ x) xs && sorted leT xs.
Proof.
move/rev_trans=>Ht; rewrite -(revK (rcons _ _)) rev_rcons rev_sorted /=.
by rewrite path_sortedE // all_rev rev_sorted.
Qed.

Lemma sorted1 (r : rel A) xs : size xs == 1 -> sorted r xs.
Proof. by case: xs=>// x; case. Qed.

End Seq.

Section SeqEq.
Variable (A : eqType).

Lemma perm_cons2 (x y : A) s : perm_eq [:: x, y & s] [:: y, x & s].
Proof.
by rewrite (_ : [::x,y & s] = [::x] ++ [::y] ++ s) //
  (_ : [::y,x & s] = [::y] ++ [::x] ++ s) // perm_catCA.
Qed.

(* a weaker form of in_split *)
Lemma mem_split (x : A) s :
        x \in s -> exists s1 s2, s = s1 ++ [:: x] ++ s2.
Proof. by case/in_split=>s1 [s2][H _]; exists s1, s2. Qed.

Lemma mem_split_uniq (x : A) s :
       x \in s -> uniq s ->
         exists s1 s2, [/\ s = s1 ++ [:: x] ++ s2,
                           uniq (s1 ++ s2) &
                           x \notin s1 ++ s2].
Proof.
move=>/[swap] Hu /mem_split [s1 [s2 H]].
exists s1, s2; move: Hu.
by rewrite H uniq_catCA cons_uniq; case/andP.
Qed.

Lemma all_notin (p : pred A) xs y :
        all p xs -> ~~ p y -> y \notin xs.
Proof. by move/allP=>Ha; apply/contra/Ha. Qed.

Lemma subset_all a (s1 s2 : seq A) : {subset s1 <= s2} -> all a s2 -> all a s1.
Proof. by move=>Hs /allP Ha1; apply/allP=>s /Hs /Ha1. Qed.

End SeqEq.

Section Allrel.
Variables (S T : Type).

Lemma allrel_rconsl (r : T -> S -> bool) x xs ys :
        allrel r (rcons xs x) ys = allrel r xs ys && all (r x) ys.
Proof. by rewrite -cats1 allrel_catl allrel1l. Qed.

Lemma allrel_rconsr (r : T -> S -> bool) y xs ys :
        allrel r xs (rcons ys y) = allrel r xs ys && all (r^~ y) xs.
Proof. by rewrite -cats1 allrel_catr allrel1r. Qed.

End Allrel.

Section AllrelEq.
Variables (S T : eqType).

Lemma allrel_in_l (r : T -> S -> bool) (xs xs' : seq T) (ys : seq S) :
        xs =i xs' ->
        allrel r xs ys = allrel r xs' ys.
Proof.
by move=>H; rewrite !allrel_allpairsE; apply/eq_all_r/mem_allpairs_dep.
Qed.

Lemma allrel_in_r (r : T -> S -> bool) (xs : seq T) (ys ys' : seq S) :
        ys =i ys' ->
        allrel r xs ys = allrel r xs ys'.
Proof.
by move=>H; rewrite !allrel_allpairsE; apply/eq_all_r/mem_allpairs_dep.
Qed.

Lemma allrel_sub_l (r : T -> S -> bool) (xs xs' : seq T) (ys : seq S) :
        {subset xs' <= xs} ->
        allrel r xs ys -> allrel r xs' ys.
Proof.
move=>H Ha; apply/allrelP=>x y Hx Hy.
by move/allrelP: Ha; apply=>//; apply: H.
Qed.

Lemma allrel_sub_r (r : T -> S -> bool) (xs : seq T) (ys ys' : seq S) :
        {subset ys' <= ys} ->
        allrel r xs ys -> allrel r xs ys'.
Proof.
move=>H Ha; apply/allrelP=>x y Hx Hy.
by move/allrelP: Ha; apply=>//; apply: H.
Qed.

Lemma allrel_trans (xs ys : seq S) z r :
        transitive r ->
        all (r^~ z) xs -> all (r z) ys -> allrel r xs ys.
Proof.
move=>Ht /allP Ha /allP Hp; apply/allrelP=>x y + Hy.
by move/Ha/Ht; apply; apply: Hp.
Qed.

End AllrelEq.

Section SeqOrd.
Variable (A : ordType).

Lemma ord_neq (x y : A) : ord x y -> x != y.
Proof.
move=>H; apply/negP=>/eqP E.
by rewrite E irr in H.
Qed.

Lemma sorted_cat_cons_cat (l r : seq A) x :
        sorted ord (l ++ x :: r) = sorted ord (l ++ [::x]) && sorted ord (x::r).
Proof.
rewrite !(sorted_pairwise (@trans A)) cats1 pairwise_cat pairwise_rcons allrel_consr !pairwise_cons.
case/boolP: (all (ord^~ x) l)=>//= Hl; case/boolP: (all (ord x) r)=>/= [Hr|_]; last by rewrite !andbF.
by rewrite (allrel_trans (@trans A) Hl Hr).
Qed.

End SeqOrd.

(* surgery on finfuns: slicing & permuting *)

Section OnthCodom.
Variable (A : Type).

Lemma onth_tnth {n} (s : n.-tuple A) (i : 'I_n) : onth s i = Some (tnth s i).
Proof.
elim: n s i =>[|n IH] s i; first by case: i.
case/tupleP: s=>/=x s; case: (unliftP ord0 i)=>[j|]-> /=.
- by rewrite tnthS.
by rewrite tnth0.
Qed.

Lemma onth_codom {n} (i : 'I_n) (f: {ffun 'I_n -> A}) : onth (fgraph f) i = Some (f i).
Proof.
pose i' := cast_ord (esym (card_ord n)) i.
move: (@tnth_fgraph _ _ f i'); rewrite (enum_val_ord) {2}/i' cast_ordKV=><-.
by rewrite (onth_tnth (fgraph f) i').
Qed.

End OnthCodom.

Section CodomWS.
Variable (n : nat) (A : Type).

Lemma codom_ux_rcons (f : {ffun 'I_n -> A}) (i : 'I_n) :
  &:(fgraph f) `]-oo, i : nat] = rcons (&:(fgraph f) `]-oo, i : nat[) (f i).
Proof. by rewrite slice_xR // slice_uu onth_codom. Qed.

End CodomWS.

Section PermFfun.
Variables (I : finType) (A : Type).

Definition pffun (p : {perm I}) (f : {ffun I -> A}) :=
  [ffun i => f (p i)].

Lemma pffunE1 (f : {ffun I -> A}) :
  pffun 1%g f = f.
Proof. by apply/ffunP=>i; rewrite !ffunE permE. Qed.

Lemma pffunEM (p p' : {perm I}) (f : {ffun I -> A}) :
  pffun (p * p') f = pffun p (pffun p' f).
Proof. by apply/ffunP => i; rewrite !ffunE permM. Qed.

End PermFfun.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 18: Deriving Programs from Specifications
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  * Some material borrowed from Fiat <http://plv.csail.mit.edu/fiat/> *)

Require Import Frap.
Require Import Program Setoids.Setoid Classes.RelationClasses Classes.Morphisms Morphisms_Prop.
Require Import Eqdep.

Set Warnings "-cannot-define-projection".

Ltac inv_pair :=
  match goal with
  | [ H : existT _ _ _ = existT _ _ _ |- _ ] => apply inj_pair2 in H; invert H
  end.

(* We have generally focused so far on proving that programs meet
 * specifications.  What if we could generate programs from their
 * specifications, in ways that guarantee correctness?  Let's explore that
 * direction, in the tradition of *program derivation* via
 * *stepwise refinement*. *)

(** * The computation monad *)

(* One counterintuitive design choice will be to represent specifications and
 * implementations in the same "language," which is essentially Gallina with the
 * added ability to pick elements nondeterministically from arbitrary sets. *)

(* Specifically, a process producing type [A] is represents as [comp A]. *)
Definition comp (A : Type) := A -> Prop.
(* The computation is represented by the set of legal values it might
 * generate. *)

(* Computations form a monad, with the following two operators. *)
Definition ret {A} (x : A) : comp A := eq x.
(* Note how [eq x] is one way of writing "the singleton set of [x],", using
 * partial application of the two-argument equality predicate [eq]. *)
Definition bind {A B} (c1 : comp A) (c2 : A -> comp B) : comp B :=
  fun b => exists a, c1 a /\ c2 a b.
(* As in some of our earlier examples, [bind] is for sequencing one computation
 * after another.  For this monad, existential quantification provides a natural
 * explanation of sequencing. *)

Definition pick_ {A} (P : A -> Prop) : comp A := P.
(* Here is a convenient wrapper function for injecting an arbitrary set into
 * [comp].  This operator stands for nondeterministic choice of any value in the
 * set. *)

(* Here is the correctness condition, for when [c2] implements [c1].  From left
 * to right in the operands of [refine], we move closer to a concrete
 * implementation. *)
Definition refine {A} (c1 c2 : comp A) :=
  forall a, c2 a -> c1 a.
(* Note how this definition is just subset inclusion, in the right direction. *)

(* Next, we use Coq's *setoid* feature to declare compatibility of our
 * definitions with the [rewrite] tactic.  See the Coq manual on setoids for
 * background on what we are doing and why. *)

Ltac morphisms := unfold refine, impl, pointwise_relation, bind, ret, pick_; hnf; first_order; subst; eauto.

Global Instance refine_PreOrder A : PreOrder (@refine A).
Proof.
  constructor; morphisms.
Qed.

Add Parametric Morphism A : (@refine A)
    with signature (@refine A) --> (@refine A) ++> impl
      as refine_refine.
Proof.
  morphisms.
Qed.

Add Parametric Morphism A B : (@bind A B)
    with signature (@refine A)
                     ==> (pointwise_relation _ (@refine B))
                     ==> (@refine B)
    as refine_bind.
Proof.
  morphisms.
Qed.

Add Parametric Morphism A B : (@bind A B)
    with signature (flip (@refine A))
                     ==> (pointwise_relation _ (flip (@refine B)))
                     ==> (flip (@refine B))
      as refine_bind_flip.
Proof.
  morphisms.
Qed.

(** ** OK, back to the details we want to focus on. *)

(* Here we have one of the monad laws, showing how traditional computational
 * reduction is compatible with refinement. *)
Theorem bind_ret : forall A B (v : A) (c2 : A -> comp B),
    refine (bind (ret v) c2) (c2 v).
Proof.
  morphisms.
Qed.

(* Here's an example specific to this monad.  One way to resolve a
 * nondeterministic pick from a set is to replace it with a specific element
 * from the set. *)
Theorem pick_one : forall {A} {P : A -> Prop} v,
    P v
    -> refine (pick_ P) (ret v).
Proof.
  morphisms.
Qed.

Notation "'pick' x 'where' P" := (pick_ (fun x => P)) (at level 80, x at level 0).
Notation "x <- c1 ; c2" := (bind c1 (fun x => c2)) (at level 81, right associativity).

(** * Picking a number not in a list *)

(* Let's illustrate the big idea with an example derivation. *)

(* A specification of what it means to choose a number that is not in a
 * particular list *)
Definition notInList (ls : list nat) :=
  pick n where ~In n ls.

(* We can use a simple property to justify a decomposition of the original
 * spec. *)
Theorem notInList_decompose : forall ls,
  refine (notInList ls) (upper <- pick upper where forall n, In n ls -> upper >= n;
                         pick beyond where beyond > upper).
Proof.
  simplify.
  unfold notInList, refine, bind, pick_, not.
  first_order.
  apply H in H0.
  linear_arithmetic.
Qed.

(* A simple traversal will find the maximum list element, which is a good upper
 * bound. *)
Definition listMax := fold_right max 0.

(* ...and we can prove it! *)
Theorem listMax_upperBound : forall init ls,
  forall n, In n ls -> fold_right max init ls >= n.
Proof.
  induct ls; simplify; propositional.
  linear_arithmetic.
  apply IHls in H0.
  linear_arithmetic.
Qed.

(* Now we restate that result as a computation refinement. *)
Theorem listMax_refines : forall ls,
  refine (pick upper where forall n, In n ls -> upper >= n) (ret (listMax ls)).
Proof.
  unfold refine, pick_, ret; simplify; subst.
  apply listMax_upperBound; assumption.
Qed.

(* An easy way to find a number higher than another: add 1! *)
Theorem increment_refines : forall n,
  refine (pick higher where higher > n) (ret (n + 1)).
Proof.
  unfold refine, pick_, ret; simplify; subst.
  linear_arithmetic.
Qed.

(** ** Interlude: defining some tactics for key parts of derivation *)

(* We run this next step to hide an evar, so that rewriting isn't too eager to
 * make up values for it. *)
Ltac hide_evars :=
  match goal with
  | [ |- refine _ (?f _ _) ] => set f
  | [ |- refine _ (?f _) ] => set f
  | [ |- refine _ ?f ] => set f
  end.

(* This tactic starts a script that finds a term to refine another. *)
Ltac begin :=
  eexists; simplify; hide_evars.

(* This tactic ends such a derivation, in effect undoing the effect of
 * [hide_evars]. *)
Ltac finish :=
  match goal with
  | [ |- refine ?e (?f ?arg1 ?arg2) ] =>
    let g := eval pattern arg1, arg2 in e in
    match g with
    | ?g' _ _ =>
      let f' := eval unfold f in f in
      unify f' g'; reflexivity
    end
  | [ |- refine ?e (?f ?arg) ] =>
    let g := eval pattern arg in e in
    match g with
    | ?g' _ =>
      let f' := eval unfold f in f in
      unify f' g'; reflexivity
    end
  | [ |- refine ?e ?f ] =>
    let f' := eval unfold f in f in
    unify f' e; reflexivity
  end.

(** ** Back to the example *)

(* Let's derive an efficient implementation. *)
Definition implementation : sig (fun f : list nat -> comp nat => forall ls, refine (notInList ls) (f ls)).
  begin.
  rewrite notInList_decompose.
  rewrite listMax_refines.
  rewrite bind_ret.
  rewrite increment_refines.
  finish.
Defined.

(* We can extract the program that we found as a standlone, executable Gallina
 * term. *)
Definition impl := Eval simpl in proj1_sig implementation.

(* We'll locally expose the definition of [max], so we can compute neatly
 * here. *)
Transparent max.
Eval compute in impl (1 :: 7 :: 8 :: 2 :: 13 :: 6 :: nil).

(** * Abstract data types (ADTs) *)

(* Stepwise refinement can be most satisfying to build objects with multiple
 * methods.  The specification of such an object is often called an abstract
 * data type (ADT), and we studied them (from a verification perspective) in
 * module DataAbstraction.  Let's see how we can build implementations
 * automatically from ADTs.  First, some preliminary definitions. *)

(* Every method inhabits this type, where [state] is the type of private state
 * for the object. *)
Record method_ {state : Type} := {
  MethodName : string;
  MethodBody : state -> nat -> comp (state * nat)
}.
(* A body takes the current state as input and produces the new state as output.
 * Additionally, we have hardcoded both the parameter type and the return type
 * to [nat], for simplicity.  The only wrinkle is that a body result is in the
 * [comp] monad, to let it mix features from specification and
 * implementation. *)

Arguments method_ : clear implicits.
Notation "'method' name [[ self , arg ]] = body" :=
  {| MethodName := name;
     MethodBody := fun self arg => body |}
    (at level 100, self at level 0, arg at level 0).

(* Next, this type collects several method definitions, given a list of their
 * names. *)
Inductive methods {state : Type} : list string -> Type :=
| MethodsNil : methods []
| MethodsCons : forall (m : method_ state) {names},
    methods names
    -> methods (MethodName m :: names).

Arguments methods : clear implicits.

(* Finally, the definition of an abstract data type, which will apply to both
 * specifications (the classical sense of ADT) and implementations. *)
Record adt {names : list string} := {
  AdtState : Type;
  AdtConstructor : comp AdtState;
  AdtMethods : methods AdtState names
}.
(* An ADT has a state type, one constructor to initialize the state, and a set
 * of methods that may read and write the state. *)

Arguments adt : clear implicits.

Notation "'ADT' { 'rep' = state 'and' 'constructor' = constr ms }" :=
  {| AdtState := state;
     AdtConstructor := constr;
     AdtMethods := ms |}.

Notation "'and' m1 'and' .. 'and' mn" :=
  (MethodsCons m1 (.. (MethodsCons mn MethodsNil) ..)) (at level 101).

(* Here's one quick example, of a counter with duplicate "increment" methods. *)

Definition counter := ADT {
  rep = nat
  and constructor = ret 0
  and method "increment1"[[self, arg]] = ret (self + arg, 0)
  and method "increment2"[[self, arg]] = ret (self + arg, 0)
  and method "value"[[self, _]] = ret (self, self)
}.

(* This example hasn't used the power of the [comp] monad, but we will get
 * there later. *)

(** * ADT refinement *)

(* What does it mean to take sound implementation steps from an ADT toward an
 * efficient implementation?  We formalize refinement for ADTs as well.  The key
 * principle will be *simulation*, very similarly to how we used the idea for
 * compiler verification. *)

(* For a "before" state type [state1] and an "after" state type [state2], we
 * require choice of a simulation relation [R].  This next inductive relation
 * captures when all methods are pairwise compatible with [R], between the
 * "before" and "after" ADTs. *)
Inductive RefineMethods {state1 state2} (R : state1 -> state2 -> Prop)
  : forall {names}, methods state1 names -> methods state2 names -> Prop :=
| RmNil : RefineMethods R MethodsNil MethodsNil
| RmCons : forall name names (f1 : state1 -> nat -> comp (state1 * nat))
                  (f2 : state2 -> nat -> comp (state2 * nat))
                  (ms1 : methods state1 names) (ms2 : methods state2 names),

    (* This condition is the classic "simulation diagram." *)
    (forall s1 s2 arg s2' res,
        R s1 s2
        -> f2 s2 arg (s2', res)
        -> exists s1', f1 s1 arg (s1', res)
                       /\ R s1' s2')

    -> RefineMethods R ms1 ms2
    -> RefineMethods R (MethodsCons {| MethodName := name; MethodBody := f1 |} ms1)
                       (MethodsCons {| MethodName := name; MethodBody := f2 |} ms2).

Local Hint Constructors RefineMethods : core.

(* When does [adt2] refine [adt1]?  When there exists a simulation relation,
 * with respect to which the constructors and methods all satisfy the usual
 * simulation diagram. *)
Record adt_refine {names} (adt1 adt2 : adt names) : Prop := {
  ArRel : AdtState adt1 -> AdtState adt2 -> Prop;
  ArConstructors : forall s2,
      AdtConstructor adt2 s2
      -> exists s1, AdtConstructor adt1 s1
                    /\ ArRel s1 s2;
  ArMethods : RefineMethods ArRel (AdtMethods adt1) (AdtMethods adt2)
}.

(* We will use this handy tactic to prove ADT refinements. *)
Ltac choose_relation R :=
  match goal with
  | [ |- adt_refine ?a ?b ] => apply (Build_adt_refine _ a b R)
  end; simplify.

(** ** Example: numeric counter *)

(* Let's refine the previous counter spec into an implementation that maintains
 * two separate counters and adds them on demand. *)

Definition split_counter := ADT {
  rep = nat * nat
  and constructor = ret (0, 0)
  and method "increment1"[[self, arg]] = ret ((fst self + arg, snd self), 0)
  and method "increment2"[[self, arg]] = ret ((fst self, snd self + arg), 0)
  and method "value"[[self, _]] = ret (self, fst self + snd self)
}.

Local Hint Extern 1 (@eq nat _ _) => simplify; linear_arithmetic : core.

(* Here is why the new implementation is correct. *)
Theorem split_counter_ok : adt_refine counter split_counter.
Proof.
  choose_relation (fun n p => n = fst p + snd p).

  unfold ret in *; subst.
  eauto.

  repeat constructor; simplify; unfold ret in *; subst;
    match goal with
    | [ H : (_, _) = (_, _) |- _ ] => invert H
    end; eauto.

  Unshelve.
  exact 0.
Qed.

(** * General refinement strategies *)

(* ADT refinement forms a preorder, as the next two theorems show. *)

Lemma RefineMethods_refl : forall state names (ms : methods state names),
    RefineMethods eq ms ms.
Proof.
  induct ms.
  constructor.
  cases m; constructor; first_order.
  subst; eauto.
Qed.

Local Hint Immediate RefineMethods_refl : core.

Theorem refine_refl : forall names (adt1 : adt names),
    adt_refine adt1 adt1.
Proof.
  simplify.
  choose_relation (@eq (AdtState adt1)); eauto.
Qed.

Lemma RefineMethods_trans : forall state1 state2 state3 names
                                   R1 R2
                                   (ms1 : methods state1 names)
                                   (ms2 : methods state2 names)
                                   (ms3 : methods state3 names),

    RefineMethods R1 ms1 ms2
    -> RefineMethods R2 ms2 ms3
    -> RefineMethods (fun s1 s3 => exists s2, R1 s1 s2 /\ R2 s2 s3) ms1 ms3.
Proof.
  induct 1; invert 1; repeat inv_pair; eauto.

  econstructor; eauto.
  first_order.
  eapply H5 in H2; eauto.
  first_order.
  eapply H in H2; eauto.
  first_order.
Qed.

Local Hint Resolve RefineMethods_trans : core.

Theorem refine_trans : forall names (adt1 adt2 adt3 : adt names),
    adt_refine adt1 adt2
    -> adt_refine adt2 adt3
    -> adt_refine adt1 adt3.
Proof.
  simplify.
  invert H.
  invert H0.
  choose_relation (fun s1 s3 => exists s2, ArRel s1 s2 /\ ArRel0 s2 s3); eauto.

  apply ArConstructors0 in H.
  first_order.
Qed.

(* Note the use of relation composition for [refine_trans]. *)

(** ** Refining constructors *)

(* One way to refine an ADT is to perform [comp]-level refinement within its
 * constructor definition. *)

Theorem refine_constructor : forall names state constr1 constr2 (ms : methods _ names),
    refine constr1 constr2
    -> adt_refine {| AdtState := state;
                     AdtConstructor := constr1;
                     AdtMethods := ms |}
                  {| AdtState := state;
                     AdtConstructor := constr2;
                     AdtMethods := ms |}.
Proof.
  simplify.
  choose_relation (@eq state); eauto.
Qed.

(** ** Refining methods *)

(* Conceptually quite similar, refining within methods requires more syntactic
 * framework. *)

(* This relation captures the process of replacing [oldbody] of method [name]
 * with [newbody]. *)
Inductive ReplaceMethod {state} (name : string)
          (oldbody newbody : state -> nat -> comp (state * nat))
  : forall {names}, methods state names -> methods state names -> Prop :=
| RepmHead : forall names (ms : methods state names),
    ReplaceMethod name oldbody newbody
                  (MethodsCons {| MethodName := name; MethodBody := oldbody |} ms)
                  (MethodsCons {| MethodName := name; MethodBody := newbody |} ms)
| RepmSkip : forall name' names oldbody' (ms1 ms2 : methods state names),
    name' <> name
    -> ReplaceMethod name oldbody newbody ms1 ms2
    -> ReplaceMethod name oldbody newbody
                  (MethodsCons {| MethodName := name'; MethodBody := oldbody' |} ms1)
                  (MethodsCons {| MethodName := name'; MethodBody := oldbody' |} ms2).

(* Let's skip ahead to the next [Theorem]. *)

Lemma ReplaceMethod_ok : forall state name
                                  (oldbody newbody : state -> nat -> comp (state * nat))
                                  names (ms1 ms2 : methods state names),
    (forall s arg, refine (oldbody s arg) (newbody s arg))
    -> ReplaceMethod name oldbody newbody ms1 ms2
    -> RefineMethods eq ms1 ms2.
Proof.
  induct 1.

  econstructor; eauto.
  unfold refine in *; simplify; subst; eauto.

  econstructor; eauto.
  simplify; subst; eauto.
Qed.

Local Hint Resolve ReplaceMethod_ok : core.

(* It is OK to replace a method body if the new refines the old as a [comp]. *)
Theorem refine_method : forall state name (oldbody newbody : state -> nat -> comp (state * nat))
                               names (ms1 ms2 : methods state names) constr,
    (forall s arg, refine (oldbody s arg) (newbody s arg))
    -> ReplaceMethod name oldbody newbody ms1 ms2
    -> adt_refine {| AdtState := state;
                     AdtConstructor := constr;
                     AdtMethods := ms1 |}
                  {| AdtState := state;
                     AdtConstructor := constr;
                     AdtMethods := ms2 |}.
Proof.
  simplify.
  choose_relation (@eq state); eauto.
Qed.

(** ** Representation changes *)

(* Some of the most interesting refinements select new data structures.  That
 * is, they pick new state types.  Here we formalize that idea in terms of
 * existence of an *abstraction function* from the new state type to the old. *)

Inductive RepChangeMethods {state1 state2} (absfunc : state2 -> state1)
  : forall {names}, methods state1 names -> methods state2 names -> Prop :=
| RchNil :
    RepChangeMethods absfunc MethodsNil MethodsNil
| RchCons : forall name names oldbody (ms1 : methods state1 names) (ms2 : methods state2 names),
    RepChangeMethods absfunc ms1 ms2
    -> RepChangeMethods absfunc
       (MethodsCons {| MethodName := name; MethodBody := oldbody |} ms1)
       (MethodsCons {| MethodName := name; MethodBody := (fun s arg =>
                         p <- oldbody (absfunc s) arg;
                         s' <- pick s' where absfunc s' = fst p;
                         ret (s', snd p)) |} ms2).
(* Interestingly, we managed to rewrite all method bodies automatically, to be
 * compatible with a new data structure!  The catch is that our language of
 * method bodies is inherently noncomputational.  We leave nontrivial work for
 * ourselves, in further refinement of method bodies to remove "pick"
 * operations.  Note how the generic method template above relies on "pick"
 * operations to invert abstraction functions. *)

Lemma RepChangeMethods_ok : forall state1 state2 (absfunc : state2 -> state1)
  names (ms1 : methods state1 names) (ms2 : methods state2 names),
    RepChangeMethods absfunc ms1 ms2
    -> RefineMethods (fun s1 s2 => absfunc s2 = s1) ms1 ms2.
Proof.
  induct 1; eauto.
  econstructor; eauto.
  morphisms.
  invert H3.
  cases x; simplify; subst.
  eauto.
Qed.

Local Hint Resolve RepChangeMethods_ok : core.

Theorem refine_rep : forall state1 state2 (absfunc : state2 -> state1)
                            names (ms1 : methods state1 names) (ms2 : methods state2 names)
                            constr,
    RepChangeMethods absfunc ms1 ms2
    -> adt_refine {| AdtState := state1;
                     AdtConstructor := constr;
                     AdtMethods := ms1 |}
                  {| AdtState := state2;
                     AdtConstructor := s0 <- constr; pick s where absfunc s = s0;
                     AdtMethods := ms2 |}.
Proof.
  simplify.
  choose_relation (fun s1 s2 => absfunc s2 = s1); eauto.
Qed.

(** ** Tactics for easy use of those refinement principles *)

Ltac refine_rep f := eapply refine_trans; [ apply refine_rep with (absfunc := f);
                                            repeat (apply RchNil
                                                    || refine (RchCons _ _ _ _ _ _ _)) | cbv beta ].

Ltac refine_constructor := eapply refine_trans; [ apply refine_constructor; hide_evars | ].

Ltac refine_method nam := eapply refine_trans; [ eapply refine_method with (name := nam); [
  | repeat (refine (RepmHead _ _ _ _ _)
            || (refine (RepmSkip _ _ _ _ _ _ _ _ _ _); [ equality | ])) ];
    cbv beta; simplify; hide_evars | ].
(* Don't be thrown off by the [refine] tactic used here.  It is not related to
 * our notion of refinement!  See module SubsetTypes for an explanation of
 * it. *)

Ltac refine_finish := apply refine_refl.

(** ** Example: the numeric counter again *)

(* Let's generate the two-counter variant through the process of finding a
 * proof, in contrast to theorem [split_counter_ok], which started with the full
 * code of the transformed ADT. *)

Definition derived_counter : sig (adt_refine counter).
  unfold counter; eexists.
  refine_rep (fun p => fst p + snd p).

  refine_constructor.
  rewrite bind_ret.
  rewrite (pick_one (0, 0)).
  finish.
  equality.

  refine_method "increment1".
  rewrite bind_ret; simplify.
  rewrite (pick_one (fst s + arg, snd s)).
  rewrite bind_ret; simplify.
  finish.
  simplify; linear_arithmetic.

  refine_method "increment2".
  rewrite bind_ret; simplify.
  rewrite (pick_one (fst s, snd s + arg)).
  rewrite bind_ret; simplify.
  finish.
  simplify; linear_arithmetic.

  refine_method "value".
  rewrite bind_ret; simplify.
  rewrite (pick_one s).
  rewrite bind_ret; simplify.
  finish.
  equality.

  refine_finish.
Defined.

Eval simpl in proj1_sig derived_counter.

(** * Another refinement strategy: introducing a cache (a.k.a. finite differencing) *)

(* Some methods begin life as expensive computations, such that it pays off to
 * precompute their values.  A generic refinement strategy follows this plan by
 * introducing *caches*. *)

(* Here, [name] names a method whose body leaves the state alone and returns the
 * result of [func] applied to that state. *)
Inductive CachingMethods {state} (name : string) (func : state -> nat)
  : forall {names}, methods state names -> methods (state * nat) names -> Prop :=
| CmNil :
    CachingMethods name func MethodsNil MethodsNil

(* Here is how we rewrite [name] itself.  We are extending state with an extra
 * cache of [func]'s value, so it is legal just to return that cache. *)
| CmCached : forall names (ms1 : methods state names) (ms2 : methods _ names),
    CachingMethods name func ms1 ms2
    -> CachingMethods name func
       (MethodsCons {| MethodName := name; MethodBody := (fun s _ => ret (s, func s)) |} ms1)
       (MethodsCons {| MethodName := name; MethodBody := (fun s _ => ret (s, snd s)) |} ms2)

(* Any other method now picks up an obligation to recompute the cache value
 * whenever changing the state.  We express that recomputation with a pick, to
 * be refined later into efficient logic. *)
| CmDefault : forall name' names oldbody (ms1 : methods state names) (ms2 : methods _ names),
    name' <> name
    -> CachingMethods name func ms1 ms2
    -> CachingMethods name func
       (MethodsCons {| MethodName := name'; MethodBody := oldbody |} ms1)
       (MethodsCons {| MethodName := name'; MethodBody := (fun s arg =>
                         p <- oldbody (fst s) arg;
                         new_cache <- pick c where (func (fst s) = snd s -> func (fst p) = c);
                         ret ((fst p, new_cache), snd p)) |} ms2).

Lemma CachingMethods_ok  : forall state name (func : state -> nat)
                                  names (ms1 : methods state names) (ms2 : methods (state * nat) names),
    CachingMethods name func ms1 ms2
    -> RefineMethods (fun s1 s2 => fst s2 = s1 /\ snd s2 = func s1) ms1 ms2.
Proof.
  induct 1; eauto.

  econstructor; eauto.
  unfold ret, bind.
  simplify; first_order; subst.
  invert H1.
  rewrite H2.
  eauto.

  econstructor; eauto.
  unfold ret, bind.
  simplify; first_order; subst.
  invert H5.
  unfold pick_ in H4.
  cases x; simplify.
  eauto.
Qed.

Local Hint Resolve CachingMethods_ok : core.

Theorem refine_cache : forall state name (func : state -> nat)
                            names (ms1 : methods state names) (ms2 : methods (state * nat) names)
                            constr,
    CachingMethods name func ms1 ms2
    -> adt_refine {| AdtState := state;
                     AdtConstructor := constr;
                     AdtMethods := ms1 |}
                  {| AdtState := state * nat;
                     AdtConstructor := s0 <- constr; ret (s0, func s0);
                     AdtMethods := ms2 |}.
Proof.
  simplify.
  choose_relation (fun s1 s2 => fst s2 = s1 /\ snd s2 = func s1); eauto.

  unfold bind, ret in *.
  first_order; subst.
  simplify; eauto.
Qed.

Ltac refine_cache nam := eapply refine_trans; [ eapply refine_cache with (name := nam);
   repeat (apply CmNil
           || refine (CmCached _ _ _ _ _ _)
           || (refine (CmDefault _ _ _ _ _ _ _ _ _); [ equality | ])) | ].

(** ** An example with lists of numbers *)

(* Let's work out an example of caching. *)

Definition sum := fold_right plus 0.

Definition nats := ADT {
  rep = list nat
  and constructor = ret []
  and method "add"[[self, n]] = ret (n :: self, 0)
  and method "sum"[[self, _]] = ret (self, sum self)
}.

Definition optimized_nats : sig (adt_refine nats).
  unfold nats; eexists.

  refine_cache "sum".

  refine_constructor.
  rewrite bind_ret.
  finish.

  refine_method "add".
  rewrite bind_ret; simplify.
  rewrite (pick_one (arg + snd s)).
  rewrite bind_ret.
  finish.
  equality.

  refine_finish.
Defined.

Eval simpl in proj1_sig optimized_nats.


Require Import kstyle.
Require Import domains.

Require Import ZArith.
Require Import String.
Require Import List.

Set Implicit Arguments.

Section MapSplit.
  Variable K : Type.
  Variable k_dec : forall (x y : K), {x=y}+{x<>y}.

  Fixpoint map_split k {V} m : option (V * Map K V) :=
  match m with
    | mapEmpty => None
    | (k' |-> v) => if k_dec k k' then Some (v, mapEmpty) else None
    | (l :* r) =>
      match map_split k l with
        | Some (v, mapEmpty) => Some (v, r)
        | Some (v, l') => Some (v, l' :* r)
        | None =>
          match map_split k r with
            | Some (v, r') => Some (v, l :* r')
            | None => None
          end
      end
  end.
  Functional Scheme map_split_ind := Induction for map_split Sort Prop.

  Lemma map_split_sound k {V} (m : Map K V) :
    match map_split k m with
      | Some (v, m') => m ~= k |-> v :* m'
      | None => True
    end.
  Proof.
  functional induction (map_split k m);auto;try equate_maps;
  match goal with [H : map_split ?x ?m = _, IH : match map_split ?x ?m with None => _ | _ => _ end
                   |- _] => rewrite H in IH; rewrite IH end;
  equate_maps.
  Qed.

  Lemma map_split_sound' k {V} (v : V) m m' :
    map_split k m = Some (v, m') -> m ~= k |-> v :* m'.
  Proof.
    pose proof (map_split_sound k m).
    intro.
    rewrite H0 in H.
    assumption.
  Qed.

  Inductive HasKey (x : K) {V} : Map K V -> Prop :=
  | key_here : forall v, HasKey x (x |-> v)
  | key_left : forall env env', HasKey x env -> HasKey x (env :* env')
  | key_right : forall env env', HasKey x env' -> HasKey x (env :* env')
  .

  Lemma transport_has_key x {V} (env env' : Map K V) :
    env ~= env' -> (HasKey x env <-> HasKey x env').
  Proof.
    induction 1; split;intros;
    repeat match goal with [H : HasKey _ ?V |- _] => (is_var V;fail 1) || (inversion H; clear H; subst) end;
    repeat match goal with [H : _ <-> _ |- _] => destruct H end;
    eauto using key_left, key_right, key_here.
  Qed.

  Definition has_key (x : K) {V} (m : Map K V) :=
    exists v env', m ~= x |-> v :* env'.

  Lemma rep x {V} (env : Map K V) :
    has_key x env -> HasKey x env.
  Proof.
    destruct 1 as [v [env' H]].
    apply (transport_has_key x) in H.
    apply H.
    eauto using key_left, key_right, key_here.
  Qed.

  Lemma rep_inv x {V} (env : Map K V) :
    HasKey x env -> has_key x env.
    induction 1.
    eexists. eexists. symmetry. apply equivUnit.
    destruct IHHasKey as [v [env'' IH]].
    exists v. exists (env'' :* env').
    rewrite IH. equate_maps.
    destruct IHHasKey as [v [env'' IH]].
    exists v. exists (env :* env'').
    rewrite IH. equate_maps.
  Qed.

  (* Without enforcing definedness there might be duplicate labels, but str_split finds some label *)
  Lemma map_split_completeish : forall x {V} (env : Map K V),
    has_key x env -> if map_split x env then True else False.
  Proof.
    induction env; intros; apply rep in H; inversion H; subst; simpl;
    repeat match goal with
        | [|- if if k_dec ?x ?y then _ else _ then _ else _] => destruct (k_dec x y);auto
        | [|- if match map_split ?x ?env with  _ => _ end then _ else _] =>
          destruct (map_split x env) as [[? []]|];auto using rep_inv
    end.
  Qed.
End MapSplit.

Definition str_split := map_split string_dec.
Definition str_split_sound k V (m : Map string V) :
       match str_split k m with
       | Some (v, m') => m ~= k |-> v :* m'
       | None => True
       end
 := map_split_sound string_dec k m.
Definition str_split_sound' :
 forall k V v (m m' : Map string V),
       str_split k m = Some (v, m') -> m ~= k |-> v :* m'
 := map_split_sound' string_dec.
Definition str_split_completeish
 : forall x V (env : Map string V),
       has_key x env -> if str_split x env then True else False
 := map_split_completeish string_dec.

Definition eval cfg : option kcfg :=
  match cfg with
    | KCfg nil env heap lenv => None
    | KCfg (item1 :: rest) env heap lenv =>
      let exp_step e' := Some (KCfg e' env heap lenv) in
      let heat_step e' f := exp_step (kra e' (kra f rest)) in
      let exp1_step e' := exp_step (e' :: rest) in
      match item1 with
        | EAmb l _ => exp1_step l
        | ECon i =>
          match rest with
            | (KFreezeE f :: rest') => exp_step (f (ECon i) :: rest')
            | _ => None
          end
        | BCon b =>
          match rest with
            | (KFreezeB f :: rest') => exp_step (f (BCon b) :: rest')
            | _ => None
          end
        | EVar x =>
          match str_split x env with
            | None => None
            | Some (v,env') => Some (KCfg (kra (ECon v) rest) (x |-> v :* env') heap lenv)
          end
        | ELoad (ECon i) =>
          match map_split Z.eq_dec i heap with
            | None => None
            | Some (j, _) => Some (KCfg (kra (ECon j) rest) env heap lenv)
          end
        | ELoad e => heat_step e (KFreezeE ELoad)
        | SAssign x (ECon i) =>
          match str_split x env with
            | None => None
            | Some (_, env') => Some (KCfg rest (x |-> i :* env') heap lenv)
          end
        | SAssign x e => heat_step e (x :=□)
        | HAssign (ECon i) (ECon j) =>
          match map_split Z.eq_dec i heap with
            | None => None
            | Some (_, heap') => Some (KCfg rest env (i |-> j :* heap') lenv)
          end
        | HAssign (ECon i) e => heat_step e (FreezeR HAssign (ECon i))
        | HAssign e e2 => heat_step e (FreezeL HAssign e2)
        | Jump l =>
          match str_split l lenv with
            | None => None
            | Some (s, _) => Some (KCfg (kra s kdot) env heap lenv)
          end
        | EPlus (ECon i) (ECon j) => exp1_step (ECon (Zplus i j))
        | EPlus (ECon i) e2       => heat_step e2 (ECon i + □)
        | EPlus e1 e2             => heat_step e1 (□ + e2)
        | EMinus (ECon i) (ECon j) => exp1_step (ECon (Zminus i j))
        | EMinus (ECon i) e2       => heat_step e2 (ECon i - □)
        | EMinus e1 e2             => heat_step e1 (□ - e2)
        | EDiv (ECon i) (ECon j) =>
          if Zneq_bool 0%Z j then exp1_step (ECon (Zdiv i j)) else None
        | EDiv (ECon i) e2       => heat_step e2 (ECon i /□)
        | EDiv e1 e2             => heat_step e1 (□/ e2)
        | BNot (BCon b)          => exp1_step (BCon (negb b))
        | BNot b                => heat_step b (KFreezeB BNot)
        | BLe (ECon i) (ECon j) => exp1_step (BCon (Zle_bool i j))
        | BLe (ECon i) e2       => heat_step e2 (i <=□)
        | BLe e1 e2             => heat_step e1 (□<= e2)
        | BEq (ECon i) (ECon j) => exp1_step (BCon (i =? j)%Z)
        | BEq (ECon i) e2       => heat_step e2 (i ==□)
        | BEq e1 e2             => heat_step e1 (□== e2)
        | BAnd (BCon b) be2 => if b then exp1_step be2 else exp1_step (BCon false)
        | BAnd be1 be2 => heat_step be1 (□&& be2)
        | Skip => exp_step rest
        | SIf (BCon b) s1 s2 => if b then exp1_step s1 else exp1_step s2
        | SIf be s1 s2 => heat_step be (if□then s1 else s2)
        | SWhile b s => exp1_step (SIf b (Seq s (SWhile b s)) Skip)
        | Seq s1 s2 => heat_step s1 s2

        | KFreezeE _ => None
        | KFreezeB _ => None
      end
end.

Functional Scheme eval_ind := Induction for eval Sort Prop.

Lemma eval_sound : forall cfg, match eval cfg with Some cfg' => kstep cfg cfg' | None => True end.
Proof.
intros;functional induction (eval cfg);unfold str_split in * |-;
repeat match goal with
  [H : map_split _ _ _ = _ |- _] => apply map_split_sound' in H end;
econstructor(reflexivity || eassumption).
Qed.

Lemma eval_completeish : forall cfg cfg', kstep cfg cfg' ->
                                          match eval cfg with
                                                         Some cfg'' => kstep cfg cfg''
                                                       | None => False end.
Proof.
Ltac good_split H dec x env :=
  let H0 := fresh in
  assert (has_key x env) as H0 by (clear -H;firstorder);
  apply (map_split_completeish dec) in H0;
  pose proof (map_split_sound dec x env);
  destruct (map_split dec x env) as [[]|];[clear H0|solve[destruct H0]].

intros;destruct H eqn:?;simpl;unfold str_split in *|-*;try solve[repeat match goal with
  | [H : ?env ~= ?x |-> _ :* _ |- context [match map_split ?dec ?x ?env with None => _ | _ => _ end]] =>
    good_split H dec x env
  | [|- kstep _ _] => econstructor (eassumption || reflexivity)
  | [H : Zneq_bool ?x ?y = _ |- context [if Zneq_bool ?x ?y then _ else _]] => rewrite H
  | [|- context [match ?e with EVar _ => _ | _ => _ end]] => destruct e; try discriminate
  | [|- context [match ?b with BCon _ => _ | _ => _ end]] => destruct b; try discriminate
end].
Qed.


(***********************************************************************
 Left Kan extensions
 In this file, we define left Kan extensions of functors. In addition,
 we construct a left adjoint to the precomposition functor. To define
 the left Kan extension, we use the pointwise formula for it, which
 defines it as a conical colimit.
 Contents
 1. Pointwise definition of the left Kan extension
 1.1. Action on objects
 1.2. Action on morphisms
 1.3. Functoriality
 1.4. Definition of the left Kan extension
 1.5. Natural transformation that witnesses commutation (the unit)
 2. Left Kan extension of natural transformations
 2.1. Extending transformations
 2.2. Naturality of unit
 3. Functoriality of assigning the left Kan extension
 4. Adjunction coming from left Kan extensions
 4.1. The left adjoint (left Kan extension)
 4.2. The unit
 4.3. The counit
 4.4. The triangles
 4.5. The adjunction
 ***********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.CommaCategories.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

(**
 1. Pointwise definition of the left Kan extension
 Note: we assume `C₁` below to be small.
 *)
Section LeftKanExtension.
  Context {C₁ C₂ D : category}
          (ColimsD : Colims D)
          (P : C₁ ⟶ C₂)
          (F : C₁ ⟶ D).

  (**
   1.1. Action on objects
   *)
  Definition lan_comma (x : C₂) : category := comma P (constant_functor unit_category _ x).
  Definition lan_pr (x : C₂) : lan_comma x ⟶ D := comma_pr1 _ _ ∙ F.
  Definition lan_colim
             (x : C₂)
    : ColimCocone (diagram_from_functor (lan_comma x) D (lan_pr x))
    := ColimsD _ (diagram_from_functor _ _ (lan_pr x)).

  Definition lan_point
             (x : C₂)
    : D
    := colim (lan_colim x).

  (**
   1.2. Action on morphisms
   *)
  Section LanMor.
    Context {x y : C₂}
            (f : x --> y).

    Definition lan_mor_cocone_ob
               (z : C₁)
               (h : P z --> x)
      : F z --> lan_point y
      := colimIn (lan_colim y) ((z ,, tt) ,, h · f).

    Definition lan_mor_forms_cocone
               {z₁ z₂ : C₁}
               (h₁ : P z₁ --> x)
               (h₂ : P z₂ --> x)
               (e : z₁ --> z₂)
               (p : h₁ = # P e · h₂)
      : # F e · lan_mor_cocone_ob z₂ h₂
        =
        lan_mor_cocone_ob z₁ h₁.
    Proof.
      refine (colimInCommutes
               (lan_colim y)
               ((z₁ ,, tt) ,, h₁ · f)
               ((z₂ ,, tt) ,, h₂ · f)
               ((e ,, idpath _) ,, _)).
      abstract
        (cbn ;
         rewrite id_right ;
         rewrite !assoc ;
         apply maponpaths_2 ;
         exact p).
    Defined.

    Definition lan_mor
      : D ⟦ lan_point x , lan_point y ⟧.
    Proof.
      refine (colim_mor
                (lan_colim x)
                (lan_point y)
                (λ v, lan_mor_cocone_ob (pr11 v) (pr2 v))
                (λ v₁ v₂ e, lan_mor_forms_cocone (pr2 v₁) (pr2 v₂) (pr11 e) _)).
      abstract
          (exact(!(id_right _) @ pr2 e)).
    Defined.

    Definition lan_mor_colimIn
               (w : C₁)
               (h : P w --> x)
               (a : unit)
      : colimIn (lan_colim x) ((w ,, a) ,, h) · lan_mor
        =
        colimIn (lan_colim y) ((w ,, a) ,, h · f).
    Proof.
      induction a.
      unfold lan_mor.
      rewrite colim_mor_commute.
      apply idpath.
    Qed.
  End LanMor.

  Definition lan_data
    : functor_data C₂ D.
  Proof.
    use make_functor_data.
    - exact lan_point.
    - exact @lan_mor.
  Defined.

  (**
   1.3. Functoriality
   *)
  Definition lan_is_functor
    : is_functor lan_data.
  Proof.
    split.
    - intros x ; cbn.
      use colim_mor_eq.
      intros v.
      rewrite id_right.
      refine (lan_mor_colimIn (identity x) (pr11 v) (pr2 v) _ @ _).
      rewrite id_right.
      apply idpath.
    - intros x y z f g.
      cbn.
      use colim_mor_eq.
      intros v.
      rewrite !assoc.
      etrans.
      {
        apply lan_mor_colimIn.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply lan_mor_colimIn.
      }
      etrans.
      {
        apply (lan_mor_colimIn g (pr11 v) (pr2 v · f)).
      }
      rewrite !assoc'.
      apply idpath.
  Qed.

  (**
   1.4. Definition of the left Kan extension
   *)
  Definition lan
    : C₂ ⟶ D.
  Proof.
    use make_functor.
    - exact lan_data.
    - exact lan_is_functor.
  Defined.

  (**
   1.5. Natural transformation that witnesses commutation
   *)
  Definition lan_commute_data
    : nat_trans_data F (P ∙ lan)
    := λ x,
       colimIn
         (lan_colim (P x))
         ((x ,, tt) ,, identity _).

  Definition lan_commute_is_nat_trans
    : is_nat_trans F (P ∙ lan) lan_commute_data.
  Proof.
    intros x y f.
    cbn.
    refine (!_).
    etrans.
    {
      exact (lan_mor_colimIn (#P f) x (identity _) _).
    }
    rewrite id_left.
    exact (!(colimInCommutes
               (lan_colim (P y))
               ((x ,, tt) ,, #P f)
               ((y ,, tt) ,, identity _)
               ((f ,, idpath _) ,, idpath _))).
  Qed.

  Definition lan_commute
    : F ⟹ P ∙ lan.
  Proof.
    use make_nat_trans.
    - exact lan_commute_data.
    - exact lan_commute_is_nat_trans.
  Defined.
End LeftKanExtension.

(**
 2. Left Kan extension of natural transformations
 *)
Section LeftKanExtensionNatTrans.
  Context {C₁ C₂ D : category}
          (ColimsD : Colims D)
          (P : C₁ ⟶ C₂)
          {F G : C₁ ⟶ D}
          (τ : F ⟹ G).

  (**
   2.1. Extending transformations
   *)
  Definition lan_nat_trans_data_cocone_ob
             (x : C₂)
             (w : C₁)
             (h : P w --> x)
    : F w --> lan_point ColimsD P G x
    := τ w · colimIn (lan_colim ColimsD P G x) ((w ,, tt) ,, h).

  Definition lan_nat_trans_data_cocone_forms_cocone
             {x : C₂}
             {w₁ w₂ : C₁}
             {h₁ : P w₁ --> x}
             {h₂ : P w₂ --> x}
             {e : w₁ --> w₂}
             (p : h₁ · identity _ = #P e · h₂)
    : # F e · lan_nat_trans_data_cocone_ob x w₂ h₂
      =
      lan_nat_trans_data_cocone_ob x w₁ h₁.
  Proof.
    unfold lan_nat_trans_data_cocone_ob.
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      exact (nat_trans_ax τ _ _ e).
    }
    rewrite !assoc'.
    apply maponpaths.
    exact (colimInCommutes
             (lan_colim ColimsD P G x)
             ((w₁,, tt),, h₁)
             ((w₂,, tt),, h₂)
             ((e ,, idpath _) ,, p)).
  Qed.

  Definition lan_nat_trans_data
    : nat_trans_data
        (lan ColimsD P F)
        (lan ColimsD P G)
    := λ x, colim_mor (lan_colim ColimsD P F x)
              _
              (λ v, lan_nat_trans_data_cocone_ob x (pr11 v) (pr2 v))
              (λ _ _ e, lan_nat_trans_data_cocone_forms_cocone (pr2 e)).

  Definition lan_nat_trans_colimIn
             (x : C₂)
             (w : C₁)
             (h : P w --> x)
             (a : unit)
    : colimIn (lan_colim ColimsD P F x) ((w ,, a) ,, h) · lan_nat_trans_data x
      =
      τ w · colimIn (lan_colim ColimsD P G x) ((w ,, a) ,, h).
  Proof.
    unfold lan_nat_trans_data.
    induction a.
    rewrite colim_mor_commute.
    apply idpath.
  Qed.

  Definition lan_nat_trans_is_nat_trans
    : is_nat_trans _ _ lan_nat_trans_data.
  Proof.
    intros x y f ; cbn.
    use colim_mor_eq.
    intros v.
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      apply lan_mor_colimIn.
    }
    etrans.
    {
      apply (lan_nat_trans_colimIn y (pr11 v) (pr2 v · f)).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply lan_nat_trans_colimIn.
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply lan_mor_colimIn.
    }
    apply idpath.
  Qed.

  Definition lan_nat_trans
    : lan ColimsD P F ⟹ lan ColimsD P G.
  Proof.
    use make_nat_trans.
    - exact lan_nat_trans_data.
    - exact lan_nat_trans_is_nat_trans.
  Defined.

  (**
   2.2. Naturality of unit
   *)
  Definition lan_commute_natural
    : nat_trans_comp
        _ _ _
        τ (lan_commute ColimsD P G)
      =
      nat_trans_comp
        _ _ _
        (lan_commute ColimsD P F) (pre_whisker P (lan_nat_trans )).
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x ; cbn.
    unfold lan_commute_data.
    refine (!_).
    apply lan_nat_trans_colimIn.
  Qed.
End LeftKanExtensionNatTrans.

(**
 3. Functoriality of assigning the left Kan extension
 *)
Definition lan_nat_trans_id
           {C₁ C₂ D : category}
           (ColimsD : Colims D)
           (P : C₁ ⟶ C₂)
           (F : C₁ ⟶ D)
  : lan_nat_trans ColimsD P (nat_trans_id F)
    =
    nat_trans_id _.
Proof.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x.
  use colim_mor_eq.
  intro v.
  etrans.
  {
    apply lan_nat_trans_colimIn.
  }
  exact (id_left _ @ !(id_right _)).
Qed.

Definition lan_nat_trans_comp
           {C₁ C₂ D : category}
           (ColimsD : Colims D)
           (P : C₁ ⟶ C₂)
           {F G H : C₁ ⟶ D}
           (τ₁ : F ⟹ G)
           (τ₂ : G ⟹ H)
  : lan_nat_trans ColimsD P (nat_trans_comp _ _ _ τ₁ τ₂)
    =
    nat_trans_comp _ _ _ (lan_nat_trans ColimsD P τ₁) (lan_nat_trans ColimsD P τ₂).
Proof.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x.
  use colim_mor_eq.
  intro v.
  etrans.
  {
    apply lan_nat_trans_colimIn.
  }
  refine (_ @ assoc' _ _ _).
  refine (!_).
  etrans.
  {
    apply maponpaths_2.
    apply lan_nat_trans_colimIn.
  }
  refine (assoc' _ _ _ @ _).
  etrans.
  {
    apply maponpaths.
    apply lan_nat_trans_colimIn.
  }
  apply assoc.
Qed.

(**
 4. Adjunction coming from left Kan extensions
 *)
Section LeftKanExtensionAdjunction.
  Context {C₁ C₂ D : category}
          (ColimsD : Colims D)
          (P : C₁ ⟶ C₂).

  (**
   4.1. The left adjoint (left Kan extension)
   *)
  Definition lan_functor_data
    : functor_data [ C₁ , D ] [ C₂ , D ].
  Proof.
    use make_functor_data.
    - exact (λ F, lan ColimsD P F).
    - exact (λ _ _ τ, lan_nat_trans ColimsD P τ).
  Defined.

  Definition lan_functor_is_functor
    : is_functor lan_functor_data.
  Proof.
    split.
    - intro ; intros.
      apply lan_nat_trans_id.
    - intro ; intros.
      apply lan_nat_trans_comp.
  Qed.

  Definition lan_functor
    : [ C₁ , D ] ⟶ [ C₂ , D ].
  Proof.
    use make_functor.
    - exact lan_functor_data.
    - exact lan_functor_is_functor.
  Defined.

  (**
   4.2. The unit
   *)
  Definition lan_precomposition_unit
    : functor_identity _ ⟹ lan_functor ∙ pre_comp_functor P.
  Proof.
    use make_nat_trans.
    - exact (λ F, lan_commute ColimsD P F).
    - exact (λ F G τ, lan_commute_natural ColimsD P τ).
  Defined.

  (**
   4.3. The counit
   *)
  Definition lan_precomposition_counit_point
             (F : C₂ ⟶ D)
             (x : C₂)
    : lan_point ColimsD P (P ∙ F) x --> F x.
  Proof.
    use colim_mor.
    - exact (λ v, #F (pr2 v)).
    - abstract
        (intros v₁ v₂ e ;
         refine (!(functor_comp F _ _) @ maponpaths (λ z, #F z) _) ;
         exact (!(pr2 e) @ id_right _)).
  Defined.

  Definition lan_precomposition_counit_point_colimIn
             (F : C₂ ⟶ D)
             (x : C₂)
             (w : C₁)
             (f : P w --> x)
             (a : unit)
    : colimIn (lan_colim ColimsD P (P ∙ F) x) ((w ,, a) ,, f)
      · lan_precomposition_counit_point F x
      =
      #F f.
  Proof.
    etrans.
    {
      apply colim_mor_commute.
    }
    apply idpath.
  Qed.

  Definition lan_precomposition_counit_natural
             (F : C₂ ⟶ D)
             {x y : C₂}
             (f : x --> y)
    : lan_mor ColimsD P (P ∙ F) f · lan_precomposition_counit_point F y
      =
      lan_precomposition_counit_point F x · # F f.
  Proof.
    use colim_mor_eq.
    intros v.
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      apply lan_mor_colimIn.
    }
    rewrite lan_precomposition_counit_point_colimIn.
    etrans.
    {
      apply (lan_precomposition_counit_point_colimIn F y (pr11 v) (pr2 v · f)).
    }
    apply (functor_comp F).
  Qed.

  Definition lan_precomposition_counit_data
             (F : C₂ ⟶ D)
    : lan_data ColimsD P (P ∙ F) ⟹ F.
  Proof.
    use make_nat_trans.
    - exact (lan_precomposition_counit_point F).
    - exact (@lan_precomposition_counit_natural F).
  Defined.

  Definition lan_precomposition_counit_natural_trans
             {F G : C₂ ⟶ D}
             (τ : F ⟹ G)
    : nat_trans_comp
        _ _ _
        (lan_nat_trans ColimsD P (pre_whisker P τ : P ∙ F ⟹ P ∙ G))
        (lan_precomposition_counit_data G)
      =
      nat_trans_comp
        _ _ _
        (lan_precomposition_counit_data F) τ.
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use colim_mor_eq.
    intro v ; cbn -[comma].
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      apply (lan_nat_trans_colimIn
               ColimsD
               P
               (pre_whisker P τ : P ∙ F ⟹ P ∙ G)).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply lan_precomposition_counit_point_colimIn.
    }
    refine (!_).
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply lan_precomposition_counit_point_colimIn.
    }
    refine (!_).
    apply (nat_trans_ax τ).
  Qed.

  Definition lan_precomposition_counit
    : pre_comp_functor P ∙ lan_functor ⟹ functor_identity _.
  Proof.
    use make_nat_trans.
    - exact lan_precomposition_counit_data.
    - exact @lan_precomposition_counit_natural_trans.
  Defined.

  (**
   4.4. The triangles
   *)
  Definition lan_precomposition_triangle_1
             (F : C₁ ⟶ D)
    : nat_trans_comp
        _ _ _
        (lan_nat_trans ColimsD P (lan_commute ColimsD P F))
        (lan_precomposition_counit_data (lan ColimsD P F))
      =
      nat_trans_id (lan_data ColimsD P F).
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use colim_mor_eq.
    intro v ; cbn -[comma].
    refine (assoc _ _ _ @ _ @ !(id_right _)).
    etrans.
    {
      apply maponpaths_2.
      apply lan_nat_trans_colimIn.
    }
    refine (assoc' _ _ _ @ _).
    etrans.
    {
      apply maponpaths.
      apply (lan_precomposition_counit_point_colimIn (lan ColimsD P F)).
    }
    etrans.
    {
      exact (lan_mor_colimIn ColimsD P F (pr2 v) (pr11 v) (identity _) tt).
    }
    induction v as [ v₁ v₃ ].
    induction v₁ as [ v₁ v₂ ].
    induction v₂.
    cbn.
    rewrite id_left.
    apply idpath.
  Qed.

  Definition lan_precomposition_triangle_2
             (F : C₂ ⟶ D)
    : nat_trans_comp
        _ _ _
        (lan_commute ColimsD P (P ∙ F))
        (pre_whisker P (lan_precomposition_counit_data F))
      =
      nat_trans_id (functor_composite_data P F).
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    cbn.
    etrans.
    {
      apply lan_precomposition_counit_point_colimIn.
    }
    apply functor_id.
  Qed.

  (**
   4.5. The adjunction
   *)
  Definition lan_precomposition_are_adjoints
    : are_adjoints lan_functor (pre_comp_functor P).
  Proof.
    simple refine ((_ ,, _) ,, (_ ,, _)).
    - exact lan_precomposition_unit.
    - exact lan_precomposition_counit.
    - exact lan_precomposition_triangle_1.
    - exact lan_precomposition_triangle_2.
  Defined.

  Definition is_right_adjoint_precomposition
    : is_right_adjoint (pre_comp_functor P)
    := lan_functor ,, lan_precomposition_are_adjoints.
End LeftKanExtensionAdjunction.


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

Set Printing Parentheses.

(** * Definition *)

Inductive sub : type -> type -> Prop :=
| Sub_Int :
    sub Int Int
| Sub_Top : forall A,
    sub A Top
| Sub_Arr : forall A B C D,
    sub C A -> sub B D ->
    sub (Arr A B) (Arr C D)
| Sub_And : forall A B1 B2,
    sub A B1 -> sub A B2 ->
    sub A (And B1 B2)
| Sub_And_L : forall A B C,
    sub A C ->
    sub (And A B) C
| Sub_And_R : forall A B C,
    sub B C ->
    sub (And A B) C.

Hint Constructors sub : core.

Notation "A <: B" := (sub A B) (at level 40).

(** * Reflexivity *)

Lemma sub_reflexivity:
  forall A,
    sub A A.
Proof.
  dependent induction A; eauto.
Qed.

Hint Resolve sub_reflexivity : core.

(** * Transitivity *)

Lemma sub_and_inversion1:
  forall A B C, sub A (And B C) -> sub A B /\ sub A C.
Proof.
  introv Sub.
  dependent induction Sub; eauto.
  destruct (IHSub B C); eauto.
  destruct (IHSub B C); eauto.
Qed.

Lemma sub_transitivity:
  forall B A C,
    sub A B -> sub B C -> sub A C.
Proof.
  dependent induction B; intros; eauto.
  - dependent induction H; eauto.
  - dependent induction H; eauto.
    dependent induction H0; eauto.
  - dependent induction H0; eauto.
    clear IHsub1 IHsub2.
    dependent induction H; eauto.
  - eapply sub_and_inversion1 in H. destruct H.
    dependent induction H0; eauto.
Qed.

(** * Decidablility *)

(** subtyping is decidable, refer https://github.com/andongfan/CP-Foundations/blob/main/fiplus/coq/Subtyping.v#L1214 *)
Axiom dec_sub : forall A B, sumbool (sub A B) (not (sub A B)).


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Omega.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert sltype.

Require Import Kstar_def demo hilbert_ref gen_def gen_ref.

(** * Main Results *)

(** Soundness and Completeness of the Hilbert System *)

Lemma soundness s : prv s -> forall (M:cmodel) (w:M), eval s w.
Proof. exact: Kstar_def.soundness. Qed.

Theorem informative_completeness s :
    prv (fImp s fF)
  + (exists2 M:fmodel, #|M| <= 2^(2 * f_size s) & exists w:M, eval s w).
Proof. exact: informative_completeness s. Qed.

Corollary prv_dec s : decidable (prv s).
Proof. exact: prv_dec. Qed.

Corollary sat_dec s : decidable (exists (M:cmodel) (w:M), eval s w).
Proof. exact: sat_dec. Qed.

Corollary valid_dec s : decidable (forall (M:cmodel) (w:M), eval s w).
Proof. exact: valid_dec. Qed.

Corollary small_models s:
  (exists (M:cmodel) (w:M), eval s w) ->
  (exists2 M:fmodel, #|M| <= 2^(2 * f_size s) & exists w:M, eval s w).
Proof. exact: small_models. Qed.

(** Correctness of the Gentzen System *)

Lemma gen_completeness C : gen (C,aVoid) + (exists M : fmodel, sat M C).
Proof. exact: gen_completeness. Qed.

Theorem gen_correctness C : gen (C,aVoid) <-> ~ (exists M : cmodel, sat M C).
Proof. exact: gen_correctness. Qed.

(** Equivalence to Segerberg Style Hilbert System *)

Theorem prv_Sprv s : prv s <-> S.prv s.
Proof. exact: prv_Sprv. Qed.


Require Import ZArith Basics.
Require Import ASN1FP.Aux.Option
               ASN1FP.Types.ASN
               ASN1FP.Conversion.IEEE_ASN
               ASN1FP.Conversion.ASN_Bitstring
               ASN1FP.Conversion.Bitstring_Bsaux
               ASN1FP.Conversion.Bsaux_Bits.
Require Import ASN1FP.Conversion.Full.Abstract.

Require Import Flocq.IEEE754.Binary Flocq.IEEE754.Bits Flocq.Core.Zaux.

Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.

Import MonadNotation. Local Open Scope monad_scope.

Open Scope Z.
Open Scope program_scope.

Notation "f <=< g" := (g >=> f) (at level 50).

Search (Z -> Z).

(* TODO: radix, scaling *)
(* extraction-ready functions for the most common IEEE formats *)
Section B32.

  Definition float32_to_BER_exact (target_radix : radix) (scaled : bool) : Z -> option Z :=
    ret ∘ bits_of_bsaux ∘ bsaux_of_bitstring <=< bitstring_of_BER <=<
        BER_of_b32_abstract ∘ b32_of_bits.

  Definition BER_to_float32_exact : Z -> option Z :=
    ret ∘ bits_of_b32 <=< b32_of_BER_abstract_exact <=<
        BER_of_bitstring ∘ bitstring_of_bsaux <=< bsaux_of_bits.

  Definition BER_to_float32_rounded (rounding: mode) : Z -> option Z :=
    ret ∘ bits_of_b32 <=< (b32_of_BER_abstract_rounded rounding) <=<
        BER_of_bitstring ∘ bitstring_of_bsaux <=< bsaux_of_bits.

  Definition normalize_float32 (m e : Z) : Z * Z :=
    normalize_b32_abstract m e.

End B32.

Section B64.

  Definition float64_to_BER_exact (target_radix : radix) (scaled : bool) : Z -> option Z :=
    ret ∘ bits_of_bsaux ∘ bsaux_of_bitstring <=< bitstring_of_BER <=<
        BER_of_b64_abstract ∘ b64_of_bits.

  Definition BER_to_float64_exact : Z -> option Z :=
    ret ∘ bits_of_b64 <=< b64_of_BER_abstract_exact <=<
        BER_of_bitstring ∘ bitstring_of_bsaux <=< bsaux_of_bits.

  Definition BER_to_float64_rounded (rounding: mode) : Z -> option Z :=
    ret ∘ bits_of_b64 <=< (b64_of_BER_abstract_rounded rounding) <=<
        BER_of_bitstring ∘ bitstring_of_bsaux <=< bsaux_of_bits.

  Definition normalize_float64 (m e : Z) : Z * Z :=
    normalize_b64_abstract m e.

End B64.


(**
    Given H a set of hardware architecture states and E a set of events,
    a Computing System C is a pair of (precondition, postcondition) where
    precondition is a predicate on H x E and postcondition is a predicate
    on H x E x H.
**)

Class Event (E: Type) :=
  { software : E -> Prop
  ; software_dec: forall (e: E), { software e } + { ~ software e } }.

Record ComputingSystem
       (Hw Ev:  Type)
      `{Event Ev}
  :=
  { precondition: Hw -> Ev -> Prop
  ; postcondition: Hw -> Ev -> Hw -> Prop }.

Arguments precondition [Hw Ev H] (_ _ _).
Arguments postcondition [Hw Ev H] (_ _ _ _).

(**
    A Computing System C defines a semantics of events as state-transformers
**)
Definition state_transformation
           {H E:     Type}
          `{Event E}
           (C:       ComputingSystem H E)
           (h:       H)
           (ev:      E)
           (h':      H)
  : Prop :=
  precondition C h ev /\ postcondition C h ev h'.

Notation "h -[ C | ev ]-> h'" := (state_transformation C h ev h') (at level 81).

(**
    A Run of a Computing System C is a sequence of state-transformations
    of C.
**)
Inductive Run
          {H E:       Type}
         `{evInst:    Event E}
          (C:         ComputingSystem H E)
          (init last: H)
  :=
  | step (ev:  E)
         (Hst: init -[C|ev]-> last)
    : Run C init last
  | sequence {penultimate: H}
             (r':          Run C init penultimate)
             (ev:          E)
             (Hst:         penultimate -[C|ev]-> last)
    : Run C init last.

Arguments step [H E evInst C init last] (ev Hst).
Arguments sequence [H E evInst C init last penultimate] (r' ev Hst).

Definition rinit
           {H E:       Type}
          `{Event E}
           {C:         ComputingSystem H E}
           {init last: H}
           (r:         Run C init last)
  : H :=
  init.

Definition rlast
           {H E:       Type}
          `{Event E}
           {C:         ComputingSystem H E}
           {init last: H}
           (r:         Run C init last)
  : H :=
  last.

Fixpoint always_true
         {H E:       Type}
        `{Event E}
         {C:         ComputingSystem H E}
         {init last: H}
         (prop:      H -> E -> Prop)
         (r:         Run C init last)
  : Prop :=
  match r with
  | step ev _        => prop init ev
  | sequence r' ev _ => always_true prop r' /\ prop (rlast r') ev
  end.


Require Import Rsequence_def Rpser_def Rpow_facts.

Require Import Cmet Cnorm Ctacfield.
Require Import Cpow.
Require Import Cprop_base.
Require Import Csequence_def Csequence_facts.
Require Import Cpser_def.

Local Open Scope R_scope.
Local Open Scope C_scope.

(** * Some lemmas manipulating the definitions *)

Lemma Cv_radius_weak_0 : forall An, Cv_radius_weak An 0.
Proof.
intro An ; exists (Cnorm (An O)) ; intros x [n Hn] ; rewrite Hn ;
 unfold_gt ; destruct n.
  rewrite Cpow_0 ; right ; apply Cnorm_eq_compat ; intuition.
  rewrite IRC_pow_compat, pow_i, Cmult_0_r, Cnorm_C0 ; [apply Cnorm_pos | intuition].
Qed.

Lemma finite_cv_radius_pos : forall An r, finite_cv_radius An r -> 0 <= r.
Proof.
intros An r [_ Hf].
 destruct(Rle_lt_dec 0 r).
  trivial.
destruct (Hf R0).
trivial.
apply Cv_radius_weak_0.
Qed.

Lemma Cv_radius_weak_Cnorm_compat_rev : forall (An : nat -> C) (r : R),
       Cv_radius_weak (fun n => Cnorm (An n)) r -> Cv_radius_weak An r.
Proof.
intros An r [M HM] ; exists M.
 intros x [n Hn] ; rewrite Hn.
 unfold_gt ; rewrite Cnorm_Cmult, <- Cnorm_invol, <- Cnorm_Cmult ;
 apply HM ; exists n ; reflexivity.
Qed.

Lemma Cv_radius_weak_Cnorm_compat_rev2 : forall (An : nat -> C) (r : R),
       Rpser_def.Cv_radius_weak (fun n => Cnorm (An n)) r -> Cv_radius_weak An r.
Proof.
intros An r [M HM] ; apply Cv_radius_weak_Cnorm_compat_rev ;
 exists M ; intros x [n Hn] ; rewrite Hn ; unfold_gt ;
 rewrite Cnorm_Cmult, IRC_pow_compat ; do 2 rewrite Cnorm_IRC_Rabs ;
 rewrite <- Rabs_mult  ; apply HM ; exists n ; reflexivity.
Qed.

Lemma Cv_radius_weak_Cnorm_compat : forall (An : nat -> C) (r : R),
       Cv_radius_weak An r -> Cv_radius_weak (fun n => Cnorm (An n)) r.
Proof.
intros An r Rho.
elim Rho ; intros m Hm ; exists m ; unfold_gt ; intros a Ha ;
 unfold EUn in Ha ; elim Ha ; intros u Hu ; rewrite Hu ; rewrite Cnorm_Cmult ;
 rewrite Cnorm_invol, <- Cnorm_Cmult ; apply Hm.
 exists u ; unfold_gt ; rewrite IRC_pow_compat ; reflexivity.
Qed.

Lemma Cv_radius_weak_Cnorm_compat2 : forall (An : nat -> C) (r : R),
       Cv_radius_weak An r -> Rpser_def.Cv_radius_weak (fun n => Cnorm (An n)) r.
Proof.
intros An r Rho.
elim Rho ; intros m Hm ; exists m ; unfold_gt ;
 unfold gt_abs_pser, Rpser_def.gt_pser, Rseq_abs, Rseq_mult ; intros a Ha ;
 unfold EUn in Ha ; elim Ha ; intros u Hu ; rewrite Hu ; rewrite Rabs_mult ;
 do 2 rewrite <- Cnorm_IRC_Rabs ; rewrite Cnorm_invol, <- Cnorm_Cmult ; apply Hm.
 exists u ; unfold_gt ; rewrite IRC_pow_compat ; reflexivity.
Qed.

Lemma Cv_radius_weak_le_compat : forall (An : nat -> C) (r r' : R),
       Rabs r' <= Rabs r -> Cv_radius_weak An r -> Cv_radius_weak An r'.
Proof.
intros An r r' r'_bd Rho.
 case (Req_or_neq r') ; intro r_eq.
  rewrite r_eq ; exists (Cnorm (An 0%nat)) ; intros x Hx ; destruct Hx as (u, Hu) ;
  rewrite Hu ; unfold_gt ; clear ; induction u.
  apply Req_le ; apply Cnorm_eq_compat ; rewrite Cpow_0. apply Cmult_1_r.
  rewrite C0_pow ; [| intuition] ; rewrite Cmult_0_r ;
  rewrite Cnorm_C0 ; apply Cnorm_pos.
  assert (r_pos : 0 < Rabs r).
   apply Rlt_le_trans with (Rabs r') ; [apply Rabs_pos_lt |] ; assumption.
  assert (r_neq : r <> 0%R).
   case (Req_or_neq r) ; intro s ; [| assumption] ;
  apply False_ind ; rewrite s in r_pos ; rewrite Rabs_R0 in r_pos ; lra.
  destruct Rho as (C, HC) ; exists C ; intros x Hx ; destruct Hx as (u,Hu) ; rewrite Hu ;
  unfold_gt.
  replace (IRC r' ^ u) with ((IRC r' ^ u * /IRC r ^ u) * (IRC r ^ u)).
  repeat (rewrite Cnorm_Cmult) ; rewrite Rmult_comm ; rewrite <- Cnorm_Cmult at 1 ;
  rewrite Rmult_assoc ; rewrite <- Cnorm_Cmult.
  apply Rle_trans with (1 * Cnorm (IRC r ^ u * An u))%R.
  apply Rmult_le_compat_r ; [apply Cnorm_pos |].
  rewrite Cpow_inv. rewrite <- Cpow_mul_distr_l.
  rewrite Cnorm_pow.
  replace 1%R with (1 ^ u)%R.
  apply pow_le_compat. apply Cnorm_pos.
  rewrite Cnorm_Cmult ; replace (IZR 1) with (Cnorm (IRC r) * / Cnorm (IRC r))%R.
  rewrite Cnorm_inv ; repeat rewrite Cnorm_IRC_Rabs.
  apply Rmult_le_compat_r.
  left ; apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
  assumption.
  apply IRC_neq_0_compat ; assumption.
  field ; rewrite Cnorm_IRC_Rabs ; apply Rgt_not_eq ; assumption.
  apply pow1.
  apply IRC_neq_0_compat ; assumption.
  rewrite Rmult_1_l ; apply HC.
  exists u ; unfold_gt ; rewrite Cmult_comm ; reflexivity.
  field.
  rewrite IRC_pow_compat ; apply IRC_neq_0_compat ;
  apply pow_nonzero ; assumption.
Qed.

Lemma finite_cv_radius_weakening : forall An r, finite_cv_radius An r ->
      forall x, Rabs x < r -> Cv_radius_weak An x.
Proof.
intros An r [H_sup _] x Hx.
 apply Cv_radius_weak_le_compat with (Rabs x).
  rewrite Rabs_Rabsolu ; right ; reflexivity.
  apply H_sup ; split ; [apply Rabs_pos | assumption].
Qed.

Lemma Cv_radius_weak_padding_pos_compat : forall (An : nat -> C) (r : R),
     Cv_radius_weak An r -> forall N, Cv_radius_weak (fun n => An (n + N)%nat) r.
Proof.
intros An r Rho N.
 destruct (Req_dec r 0) as [r_eq | r_neq].
  rewrite r_eq ; exists (Cnorm (An N)).
  intros u Hu ; destruct Hu as [n Hn] ; rewrite Hn ; unfold_gt ; destruct n.
  simpl ; rewrite Cmult_1_r ; right ; reflexivity.
  rewrite Cnorm_Cmult, Cnorm_pow, Cnorm_IRC_Rabs, RPow_abs, pow_i,
  Rabs_R0, Rmult_0_r ; [apply Cnorm_pos | intuition].
 destruct Rho as [M HM].
 exists (M * (/ Rabs r) ^ N)%R.
 intros u Hu ; destruct Hu as [n Hn] ; rewrite Hn.
 unfold_gt ; simpl.
 rewrite Cnorm_Cmult ; apply Rle_trans with (Cnorm (An (n + N)%nat) * Cnorm (r ^ n) *
 (Rabs r ^ N) * ((/Rabs r) ^ N))%R.
 right ; repeat rewrite Rmult_assoc ; repeat apply Rmult_eq_compat_l.
 rewrite <- Rpow_mult_distr, Rinv_r, pow1, Rmult_1_r ; [reflexivity |
 apply Rabs_no_R0 ; assumption].
 apply Rmult_le_compat_r.
 apply pow_le ; left ; apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
 rewrite <- Cnorm_IRC_Rabs, Rmult_assoc, <- Cnorm_pow, <- Cnorm_Cmult.
 apply HM.
 exists (n + N)%nat ; unfold_gt.
 repeat rewrite Cnorm_Cmult ; apply IRC_eq_compat.
 apply Rmult_eq_compat_l ; rewrite <- Cnorm_Cmult ; apply Cnorm_eq_compat.
 symmetry ; apply Cpow_add.
Qed.

Lemma Cv_radius_weak_padding_neg_compat : forall (An : nat -> C) (r : R) (N : nat),
     Cv_radius_weak (fun n => An (n + N)%nat) r -> Cv_radius_weak An r.
Proof.
intros An r N Rho.
 destruct Rho as [M HM].
 destruct (Cseq_partial_bound (fun n => (An n) * r ^ n) N) as [M' HM'].
 destruct (Req_dec r 0) as [r_eq | r_neq].
 exists (Cnorm (An 0%nat)) ; intros u Hu ; destruct Hu as [n Hn] ; rewrite Hn.
  unfold_gt ; destruct n.
   simpl ; rewrite Cmult_1_r ; right ; reflexivity.
   rewrite Cnorm_Cmult, Cnorm_pow, Cnorm_IRC_Rabs, r_eq, Rabs_R0, pow_i,
   Rmult_0_r ; [apply Cnorm_pos | intuition].
 exists (Rmax (M * Cnorm (r ^ N)) M') ; intros u Hu ; destruct Hu as [n Hn] ; rewrite Hn.
 destruct (le_lt_dec n N) as [n_lb | n_ub].
 apply Rle_trans with M' ; [apply HM' | apply RmaxLess2] ; assumption.
 apply Rle_trans with (M * Cnorm (r ^ N))%R ; [| apply RmaxLess1] ; unfold_gt.
 apply Rle_trans with (Cnorm (An n * r ^ n) * (/ Cnorm (r ^ N)) * Cnorm (r ^ N))%R.
 right ; field ; apply Cnorm_no_R0.
 apply Cpow_neq_compat ; apply IRC_neq_compat ; assumption.
  apply Rmult_le_compat_r ; [apply Cnorm_pos |].
  apply HM ; exists (n - N)%nat.
  unfold_gt.
  rewrite Cnorm_pow, Rinv_pow, <- Cnorm_inv, <- Cnorm_pow, <- Cnorm_Cmult,
  <- Cpow_inv.
  assert (Hrew : (n = n - N + N)%nat).
   intuition.
   repeat rewrite Cnorm_Cmult ; rewrite Hrew at 1 ; rewrite Rmult_assoc ;
   apply Rmult_eq_compat_l ; rewrite <- Cnorm_Cmult ; apply Cnorm_eq_compat.
   rewrite Hrew at 1 ; rewrite Cpow_add, Cmult_assoc, Cinv_r, Cmult_1_r ;
   [reflexivity | apply Cpow_neq_compat ; apply IRC_neq_compat ; assumption].
   apply IRC_neq_compat ; assumption.
   apply IRC_neq_compat ; assumption.
   apply Cnorm_no_R0 ; apply IRC_neq_compat ; assumption.
Qed.

Lemma Cv_radius_weak_plus : forall (An Bn : nat -> C) (r1 r2 : R),
       Cv_radius_weak An r1 -> Cv_radius_weak Bn r2 ->
       Cv_radius_weak (fun n => An n + Bn n) (Rmin (Rabs r1) (Rabs r2)).
Proof.
intros An Bn r1 r2 RhoA RhoB.
assert (r''_bd1 : Rabs (Rmin (Rabs r1) (Rabs r2)) <= Rabs r1).
 unfold Rmin ; case (Rle_dec (Rabs r1) (Rabs r2)) ; intro H ;
 rewrite Rabs_Rabsolu ; intuition.
assert (r''_bd2 : Rabs (Rmin (Rabs r1) (Rabs r2)) <= Rabs r2).
 unfold Rmin ; case (Rle_dec (Rabs r1) (Rabs r2)) ; intro H ;
 rewrite Rabs_Rabsolu ; intuition.
assert (Rho'A := Cv_radius_weak_le_compat An _ _ r''_bd1 RhoA).
assert (Rho'B := Cv_radius_weak_le_compat Bn _ _ r''_bd2 RhoB).
 destruct Rho'A as (C, HC) ;
 destruct Rho'B as (C', HC') ;
 exists (C + C')%R.
 intros x Hx ; destruct Hx as (u, Hu) ; rewrite Hu ; unfold_gt.
 rewrite Cmult_add_distr_r ; apply Rle_trans with (Cnorm (An u *  IRC (Rmin (Rabs r1)
         (Rabs r2)) ^ u) + Cnorm (Bn u * IRC (Rmin (Rabs r1) (Rabs r2)) ^ u))%R ;
 [apply Cnorm_triang |].
 apply Rle_trans with (Cnorm (An u * IRC (Rmin (Rabs r1) (Rabs r2)) ^ u) + C')%R ;
 [apply Rplus_le_compat_l ; apply HC' | apply Rplus_le_compat_r ; apply HC] ;
 exists u ; intuition.
Qed.

Lemma Cv_radius_weak_opp : forall (An : nat -> C) (r : R),
       Cv_radius_weak An r ->
       Cv_radius_weak (fun n => - An n) r.
Proof.
intros An r Rho.
 destruct Rho as (C, HC) ; exists C ; intros x Hx ; destruct Hx as (u,Hu) ; rewrite Hu ;
 unfold_gt ; rewrite Copp_mult_distr_l_reverse ; rewrite Cnorm_opp ;
 apply HC ; exists u ; intuition.
Qed.

Lemma Cv_radius_weak_minus : forall (An Bn : nat -> C) (r1 r2 : R),
       Cv_radius_weak An r1 -> Cv_radius_weak Bn r2 ->
       Cv_radius_weak (fun n => An n - Bn n) (Rmin (Rabs r1) (Rabs r2)).
Proof.
intros An Bn r1 r2 RhoA RhoB.
 assert (Rho'B := Cv_radius_weak_opp Bn _ RhoB).
 unfold Rminus ; apply Cv_radius_weak_plus ; assumption.
Qed.

Lemma Rmin_ge_0 : forall x y, 0 <= x -> 0 <= y -> 0 <= Rmin x y.
Proof.
intros x y x_pos y_pos.
 unfold Rmin ; case (Rle_dec x y) ; intro h ; intuition.
Qed.

Lemma Pser_add : forall (An Bn : nat -> C) (z : C) (N : nat),
       sum_f_C0 (gt_pser (fun n => An n + Bn n) z) N = sum_f_C0 (gt_pser An z) N + sum_f_C0 (gt_pser Bn z) N.
Proof.
intros An Bn x N ; induction N.
 simpl ; unfold gt_pser, Cseq_mult ; field.
 assert (Hrew : forall a b c d e, c = d + e -> a + b + c = a + d + (b + e)).
  intros ; subst ; field.
 simpl ; rewrite IHN ; apply Hrew.
 unfold gt_pser, Cseq_mult ; field.
Qed.

Lemma Pser_minus : forall (An Bn : nat -> C) (x : C) (N : nat),
       sum_f_C0 (gt_pser (fun n => An n - Bn n) x) N = sum_f_C0 (gt_pser An x) N - sum_f_C0 (gt_pser Bn x) N.
Proof.
intros An Bn x N ; induction N.
 simpl ; unfold gt_pser, Cseq_mult ; field.
 assert (Hrew : forall a b c d e, c = d - e -> a - b + c = a + d - (b + e)).
  intros ; subst ; field.
 simpl ; rewrite IHN ; apply Hrew.
 unfold gt_pser, Cseq_mult ; field.
Qed.

Lemma Pser_Cseqcv_link : forall (An : nat -> C) (x l : C),
       Cpser An x l ->
       Cseq_cv (fun N : nat => sum_f_C0 (gt_pser An x) N) l.
Proof.
intros An x l H ; apply H.
Qed.

Lemma Pser_unique : forall (An : nat -> C) (x l1 l2 : C),
  Cpser An x l1 -> Cpser An x l2 -> l1 = l2.
Proof.
intros An x l1 l2 Hl1 Hl2.
 assert (T1 := Pser_Cseqcv_link _ _ _ Hl1) ;
 assert (T2 := Pser_Cseqcv_link _ _ _ Hl2) ;
 eapply Cseq_cv_unique ; eassumption.
Qed.

Lemma Cpser_unique_extentionality : forall (An Bn : nat -> C) (x l1 l2 : C),
	(forall n, An n = Bn n) ->
        Cpser An x l1 -> Cpser Bn x l2 -> l1 = l2.
Proof.
intros An Bn x l1 l2 An_eq_Bn Hl1 Hl2.
 assert (T1 := Pser_Cseqcv_link _ _ _ Hl1) ;
 assert (T2 := Pser_Cseqcv_link _ _ _ Hl2).
 assert (T3 : forall (n : nat), sum_f_C0 (fun n => (gt_pser An x) n) n
                  = sum_f_C0 (fun n => (gt_pser Bn x) n) n).
  intro n ; apply (sum_f_C0_eq_seq) ; intros ; unfold gt_pser, Cseq_mult ;
  rewrite An_eq_Bn ; reflexivity.
 assert (T4 := Cseq_cv_eq_compat _ _ _ T3 T1).
 eapply Cseq_cv_unique ; eassumption.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Classes.Morphisms.
From Coq Require Export Field.
From CReal Require Import QArith_ext.QArith_base_ext.
From CReal.Cauchy Require Import RBase.
From CReal.Cauchy Require Import RArith.

Definition Rpositive (A:Real):Prop:=
  exists eps0:Q, (eps0>0) /\
    (exists N, forall n, (n>=N)%nat ->
      forall q, (match A with | Real_intro A0 _ => A0 end) n q -> q >= eps0).

Theorem Rpositive_equiv: forall A B,
  (A == B)%R -> Rpositive A -> Rpositive B.
Proof. intros [A HA] [B HB] H0 H1. hnf in *.
  destruct H1 as [eps0 [H H1]]. exists (eps0 *(1#2)). split.
  apply eps_divide_2_positive. auto.
  destruct H1 as [N1 H1].
  destruct (H0 _ (eps_divide_2_positive _ H)) as [N2 H2].
  assert (HN: lt N1 N2 \/ ~(lt N1 N2)) by (apply classic). destruct HN as [HN|HN].
  - exists (S N2). intros n HN2. assert (HN1:(n >= N1)%nat) by omega.
    intros qb Hqb. destruct (Cauchy_exists _ HA n) as [qa Hqa].
    assert (E1: qb == qa - (qa - qb)) by ring.
    assert (E2: qa - (qa - qb) >= qa - Qabs (qa - qb)).
     { apply Qplus_le_compat. apply Qle_refl. apply Qopp_le_compat. apply Qle_Qabs. }
    assert (E3: qa >= eps0).
     { apply (H1 _ HN1 _ Hqa). }
    assert (E4: - Qabs (qa - qb) >= - (eps0 * (1 # 2))).
     { apply (proj2 (Qopp_le_compat_iff _ _)). rewrite Qopp_involutive. rewrite Qopp_involutive.
       apply Qlt_le_weak. apply (H2 n HN2 qa qb Hqa Hqb). }
    assert (E5: eps0 * (1 # 2) <= qa - Qabs (qa - qb)).
     { assert (Et: eps0 * (1 # 2) == eps0 -eps0 * (1 # 2) ) by ring. rewrite Et.
       apply Qplus_le_compat. auto. auto. }
    rewrite E1.
    apply (Qle_trans _ _ _ E5 E2).
  - exists (S N1). intros n HN1. apply not_lt in HN. assert (HN2:(n > N2)%nat) by omega.
    intros qb Hqb. destruct (Cauchy_exists _ HA n) as [qa Hqa].
    assert (E1: qb == qa - (qa - qb)) by ring.
    assert (E2: qa - (qa - qb) >= qa - Qabs (qa - qb)).
     { apply Qplus_le_compat. apply Qle_refl. apply Qopp_le_compat. apply Qle_Qabs. }
    assert (E3: qa >= eps0).
     { assert (Et: le N1 n) by omega. apply (H1 _ Et _ Hqa). }
    assert (E4: - Qabs (qa - qb) >= - (eps0 * (1 # 2))).
     { apply (proj2 (Qopp_le_compat_iff _ _)). rewrite Qopp_involutive. rewrite Qopp_involutive.
       apply Qlt_le_weak. apply (H2 n HN2 qa qb Hqa Hqb). }
    assert (E5: eps0 * (1 # 2) <= qa - Qabs (qa - qb)).
     { assert (Et: eps0 * (1 # 2) == eps0 -eps0 * (1 # 2) ) by ring. rewrite Et.
       apply Qplus_le_compat. auto. auto. }
    rewrite E1.
    apply (Qle_trans _ _ _ E5 E2).
Qed.

Instance Rpositive_proper_iff: Proper (Real_equiv ==> iff) Rpositive.
Proof.
  intros.
  hnf.
  intros.
  split.
  + apply Rpositive_equiv. auto.
  + apply Rpositive_equiv. symmetry. auto.
Qed.

Definition Rnegative (A:Real):Prop:=
 Rpositive (Ropp A).

Instance Rnegative_proper_iff: Proper (Real_equiv ==> iff) Rnegative.
Proof.
  intros.
  hnf.
  intros.
  assert (E: (Ropp x == Ropp y)%R). {
    destruct x as [X HX],y as [Y HY]. hnf. hnf in H.
    intros eps Heps. destruct (H eps Heps) as [N H1].
    exists N. unfold Cauchy_opp. intros.
    destruct (Cauchy_exists _ HX m) as [qX HqX].
    destruct (Cauchy_exists _ HY m) as [qY HqY].
    rewrite (H2 _ HqX). rewrite (H3 _ HqY).
    assert (E1: Qabs (qX - qY) < eps). { apply (H1 m). auto. auto. auto. }
    assert (E2: - qX - - qY == - (qX - qY)) by ring. rewrite E2.
    rewrite Qabs_opp. auto. } unfold Rnegative.
  split.
  + intros. rewrite <- E. auto.
  + intros. rewrite E. auto.
Qed.

(*
Definition Rnegative3 (A:Real):Prop:=
  match A with
  | Real_intro A0 _ =>  exists A1, Rpositive A1 /\ ( A == (Ropp A1))%R
  end.

Definition Rnegative2 (A:Real):Prop:=
  match A with
  | Real_intro A0 _ => exists A, Rpositive A /\ (forall n q,
     (match A with Real_intro A1 _ => A1 end) n q -> A0 n (-q))
  end.

Bad Definitions!

*)

Theorem take_max_N: forall N1 N2 (P Q:nat->Prop), (forall n, (n>=N1)%nat -> P n) -> (forall n ,(n>=N2)%nat -> Q n) ->
  exists N, forall n, (n>=N)%nat -> (P n /\ Q n).
Proof. intros. assert (HN: lt N1 N2 \/ ~(lt N1 N2)) by (apply classic). destruct HN as [HN|HN].
  - exists N2. intros n HN2. assert (HN1: (n >= N1)%nat) by omega.
    split. auto. auto.
  - exists N1. intros n HN1. assert (HN2: (n >= N2)%nat) by omega.
    split. auto. auto.
Qed.

Theorem Real_positive_not_negative: forall A, ~ (Rpositive A /\ Rnegative A).
Proof. intros. intros [[eps0 [Heps0 [NA C1]]] C2]. destruct A as [A HA]. hnf in C2. unfold Ropp in C2. unfold Cauchy_opp in C2.
  destruct C2 as [eps1 [Heps1 [NB C2]]].
  destruct (take_max_N NA NB
               (fun n => forall q : Q, A n q -> eps0 <= q)
               (fun n => forall q : Q,
     (forall q1 : Q, A n q1 -> q == - q1) -> eps1 <= q)
               C1 C2) as [N E]. clear C1 C2.
  assert (E2: (N>=N)%nat) by omega. apply E in E2. clear E.
  destruct (Cauchy_exists _ HA N) as [qa Hqa].
  destruct E2 as [E2 E3].
  assert (C1: qa > 0). { apply (Qlt_le_trans _ eps0). auto. auto. }
  assert (C2: qa < 0). { rewrite <- Qopp_involutive. rewrite <- (Qopp_involutive 0).
                         apply Qopp_lt_compat. apply (Qlt_le_trans _ eps1). auto. apply E3.
                         intros. rewrite (Cauchy_unique _ HA _ _ _ Hqa H). reflexivity. }
  assert (Contra: qa > qa). { apply (Qlt_trans _ 0). auto. auto. }
  apply Qlt_irrefl in Contra. contradiction.
Qed.

Theorem take_max_N_2: forall N1 N2 (P:nat->Prop) (Q:nat->nat->Prop),
 (forall n, (n>N1)%nat -> P n) -> (forall m1 m2 ,(m1>N2)%nat-> (m2 > N2)%nat -> (Q m1 m2)) ->
  exists N, (forall n, (n>=N)%nat -> P n) /\ (forall m1 m2, (m1>N)%nat-> (m2 > N)%nat  -> Q m1 m2).
Proof. intros. assert (HN: lt N1 N2 \/ ~(lt N1 N2)) by (apply classic). destruct HN as [HN|HN].
  - exists N2. split. intros n HnN2. assert (HnN1: (n > N1)%nat) by omega. auto.
    intros  m1 m2 Hm1N2 Hm2N2. auto.
  - exists (S N1). split. intros n HnN1. auto. intros.
    assert (Hm1N2: (m1 > N2)%nat) by omega.
    assert (Hm2N2: (m2 > N2)%nat) by omega.
    auto.
Qed.

Theorem Real_not_zero_positive_or_negative: forall A,
~(A==Rzero)%R -> ((Rpositive A) \/ (Rnegative A)).
Proof. intros [A HA] H. apply limit_not_0_spec in H.
  apply (Cauchy_nonzero_pre _ HA) in H.
  destruct H as [N1 [eps0 [Heps0 H1]]].
  destruct (Cauchy_def _ HA (eps0*(1#2)) (eps_divide_2_positive _ Heps0)) as [N2 H2].
  destruct (take_max_N_2 N1 N2
               (fun n => forall q : Q, A n q -> eps0 <= Qabs q)
               (fun m1 m2 => forall (q1 q2 : Q), A m1 q1 -> A m2 q2 -> Qabs (q1 - q2) < eps0 * (1 # 2))
               H1 H2) as [N [E1 E2]]. clear H1 H2.
  destruct (Cauchy_exists _ HA (S N)) as [qN HqN].
  destruct (Qlt_le_dec qN 0) as [HqNsig|HqNsig].
  - right. hnf. exists (eps0*(1#2)). split. apply (eps_divide_2_positive _ Heps0).
      exists (S N). intros. hnf in H0.
      destruct (Cauchy_exists _ HA n) as [qn Hqn].
      assert (E0:q == - qn) by auto. rewrite E0.
      assert (E3: qn == qN - (qN - qn)) by ring.
      assert (E4: qN- (qN - qn) <= qN + Qabs (qN -qn)).
        { apply Qplus_le_compat. apply Qle_refl.
          assert (Et: - (qN - qn) == qn - qN) by ring. rewrite Et.
          rewrite Qabs_Qminus. apply Qle_Qabs. }
      assert (E5: qN <= - eps0). {
          assert (Et: qN == - (Qabs qN)).
          { assert (Et1: - qN == Qabs qN). symmetry. apply Qabs_neg. apply Qlt_le_weak. auto.
            rewrite <- Et1. rewrite Qopp_involutive. reflexivity. }
          rewrite Et. apply Qopp_le_compat. apply (E1 (S N)). omega. auto. }
      assert (E6: Qabs (qN - qn) < eps0 * ( 1 # 2)).
        { apply (E2 (S N) n). omega. auto. auto. auto. }
      assert (E7: - (eps0 * (1 # 2)) == - eps0 + eps0 * (1 # 2)) by ring.
      rewrite <- Qopp_involutive. apply Qopp_le_compat.
      rewrite E7,E3. apply (Qle_trans _ _ _ E4). apply Qplus_le_compat. auto.
      apply Qlt_le_weak. auto.
   - left. hnf. exists (eps0*(1#2)). split. apply (eps_divide_2_positive _ Heps0).
      exists (S N). intros. hnf in H0.
      assert (E3: q == qN - (qN - q)) by ring.
      assert (E4: qN- (qN - q) >= qN - Qabs (qN -q)).
        { apply Qplus_le_compat. apply Qle_refl.
          apply Qopp_le_compat. apply Qle_Qabs. }
      assert (E5: qN >= eps0). { rewrite <- (Qabs_pos qN HqNsig). apply (E1 (S N)). omega. auto. }
      assert (E6: Qabs (qN - q) < eps0 * ( 1 # 2)).
        { apply (E2 (S N) n). omega. auto. auto. auto. }
      assert (E7: (eps0 * (1 # 2)) == eps0 - eps0 * (1 # 2)) by ring.
      rewrite E7,E3. apply (Qle_trans _ (qN - Qabs (qN - q)) _). apply Qplus_le_compat. auto.
      apply Qopp_le_compat. apply Qlt_le_weak. auto. auto.
Qed.

Theorem take_max_N3: forall N1 N2 (P Q:nat->Prop), (forall n, (n>=N1)%nat -> P n) -> (forall n ,(n>N2)%nat -> Q n) ->
  exists N, forall n, (n>=N)%nat -> (P n /\ Q n).
Proof. intros. assert (HN: lt N1 N2 \/ ~(lt N1 N2)) by (apply classic). destruct HN as [HN|HN].
  - exists (S N2). intros n HN2. assert (HN1: (n >= N1)%nat) by omega.
    split. auto. auto.
  - exists (S N1). intros n HN1. assert (HN2: (n >= N2)%nat) by omega.
    split. apply H. omega. apply H0. omega.
Qed.

Lemma Rzero_not_positive: forall A, (A == 0)%R -> ~ Rpositive A.
Proof. intros A.
      destruct A as [A HA]. intros C H. hnf in *. destruct H as [eps [Heps [N H]]].
      destruct (C _ Heps) as [N1 HN1]. clear C.
      destruct (take_max_N3 N N1
                   (fun n => forall q : Q, A n q -> eps <= q)
                   (fun m => forall q1 q2 : Q, A m q1  -> q2 == 0 -> Qabs (q1 - q2) < eps)
                    H HN1) as [Nmax HNmax]. clear H HN1.
      destruct (Cauchy_exists _ HA Nmax) as [qn Hqn].
      assert (E1: qn >= eps). { apply (HNmax Nmax). omega. auto. }
      assert (E2: Qabs qn < eps). { rewrite <- (Qplus_0_r qn).
          assert (Et: ge Nmax Nmax) by omega.
          apply ((proj2 (HNmax Nmax Et)) qn (- 0)). auto. reflexivity. }
      assert (E3: qn > Qabs qn). { apply (Qlt_le_trans _ _ _ E2 E1). }
      apply Qlt_not_le in E3. apply E3. apply Qle_Qabs.
Qed.

Lemma Rzero_not_negative: forall A, (A == 0)%R -> ~ Rnegative A.
Proof. intros A.
      destruct A as [A HA]. intros C H. hnf in *. destruct H as [eps [Heps [N H]]].
      destruct (C _ Heps) as [N1 HN1]. clear C. unfold Ropp in H. unfold Cauchy_opp in H.
      destruct (take_max_N3 N N1
                   (fun n => forall q : Q, (forall q1 : Q, A n q1 -> q == - q1) -> eps <= q)
                   (fun m => forall q1 q2 : Q, A m q1  -> q2 == 0 -> Qabs (q1 - q2) < eps)
                    H HN1) as [Nmax HNmax]. clear H HN1.
      destruct (Cauchy_exists _ HA Nmax) as [qn Hqn].
      assert (E1: qn <= - eps). { rewrite <-Qopp_involutive. apply Qopp_le_compat.
        apply (HNmax Nmax). omega. intros.  rewrite (Cauchy_unique _ HA _ _ _ Hqn H). reflexivity. }
      assert (E2: Qabs qn < eps). { rewrite <- (Qplus_0_r qn).
          assert (Et: ge Nmax Nmax) by omega.
          apply ((proj2 (HNmax Nmax Et)) qn (- 0)). auto. reflexivity. }
      assert (E3: - qn > Qabs qn). { apply (Qlt_le_trans _ _ _ E2).
          rewrite <- Qopp_involutive. apply Qopp_le_compat. auto. }
      rewrite <- Qabs_opp in E3.
      apply Qlt_not_le in E3. apply E3. apply Qle_Qabs.
Qed.

Lemma Rpositive_not_zero: forall A, Rpositive A -> ~ (A == 0)%R.
Proof. intros A H. intros C. rewrite C in H. hnf in H. unfold Rzero in H.
       destruct H as [eps0 [Heps0 [N HN]]].
       assert (nonsense: eps0 <=0). { apply (HN N). omega. reflexivity. }
       apply Qle_not_lt in nonsense. contradiction.
Qed.

Lemma Rnegative_not_positive: forall A, Rnegative A -> ~ Rpositive A.
Proof. intros. intros C. assert (E:Rpositive A /\ Rnegative A) by auto.
       apply Real_positive_not_negative in E. apply E.
Qed.

Lemma Rpositive_not_negative: forall A, Rpositive A -> ~ Rnegative A.
Proof. intros. intros C. assert (E:Rpositive A /\ Rnegative A) by auto.
       apply Real_positive_not_negative in E. apply E.
Qed.

Lemma Rnegative_not_zero: forall A, Rnegative A -> ~(A==0)%R.
Proof. intros A H. intros C. rewrite C in H. hnf in H. unfold Rzero in H.
       destruct H as [eps0 [Heps0 [N HN]]].
       destruct A as [A HA]. unfold Ropp in HN. unfold Cauchy_opp in HN.
       destruct (Cauchy_exists _ HA N) as [qn Hqn].
       assert (nonsense: eps0 <= 0). { apply (HN N).
       omega. intros. rewrite H. reflexivity. }
       apply Qle_not_lt in nonsense. contradiction.
Qed.

Theorem Real_positive_0_negative: forall A,
 ( Rpositive A /\ ~(A==Rzero)%R  /\ ~ Rnegative A ) \/
 ( ~ Rpositive A /\ (A==Rzero)%R  /\ ~ Rnegative A ) \/
 ( ~ Rpositive A /\ ~(A==Rzero)%R  /\ Rnegative A ).
Proof. intros. assert (Case1: (A==Rzero)%R  \/ ~(A==Rzero)%R) by (apply classic).
  destruct Case1 as [Case1|Case2].
  - right. left. split.
    + apply Rzero_not_positive. auto.
    + split. auto.
      apply Rzero_not_negative. auto.
   - apply Real_not_zero_positive_or_negative in Case2. destruct Case2 as [Case2|Case3].
   + left. split. auto. split.
     * apply Rpositive_not_zero. auto.
     * apply Rpositive_not_negative. auto.
   + right. right. split.
     * apply Rnegative_not_positive. auto.
     * split. apply Rnegative_not_zero. auto.
       auto.
Qed.

Lemma Rnot_positive: forall A, ~ (Rpositive A) -> (Rnegative A) \/ (A==0)%R.
Proof. intros. destruct (classic (A==0)%R).
  - right. auto.
  - left. destruct (classic (Rnegative A)). auto.
    destruct (Real_positive_0_negative A).
    + destruct H2. contradiction.
    + destruct H2. * destruct H2. destruct H3. contradiction.
      * destruct H2. destruct H3. auto.
Qed.

Lemma Rnot_negative: forall A, ~ (Rnegative A) -> (Rpositive A) \/ (A==0)%R.
Proof. intros. destruct (classic (A==0)%R).
  - right. auto.
  - left. destruct (classic (Rpositive A)). auto.
    destruct (Real_positive_0_negative A).
    + destruct H2. contradiction.
    + destruct H2. * destruct H2. destruct H3. contradiction.
      * destruct H2. destruct H3. contradiction.
Qed.

Theorem Real_sgn_case: forall A,
Rpositive A \/ (A==Rzero)%R \/ Rnegative A.
Proof. intros. destruct (classic (Rpositive A)).
  - auto.
  - apply Rnot_positive in H. right. destruct H.
    + auto. + auto.
Qed.

Lemma inject_Q_pos: forall q, q>0 -> Rpositive (inject_Q q).
Proof. intros. hnf. exists (q*(1#2)). split.
  apply eps_divide_2_positive. auto.
  exists (S O). intros. unfold inject_Q in H1. rewrite H1.
  rewrite <- (Qmult_1_r q). rewrite <- Qmult_assoc.
  apply (proj2 (Qmult_le_l _ _ _ H)). rewrite Qmult_1_l.
  intros C. inversion C.
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.theory.setoids MathClasses.interfaces.functors MathClasses.theory.categories.
Require MathClasses.categories.setoids.

Section contents.
  Context `{Category C} (x: C).

  Definition homFrom (y: C): setoids.Object := setoids.object (x ⟶ y).

  Global Program Instance: Fmap homFrom := λ v w X, (X ◎): (x ⟶ v) → (x ⟶ w).
  Next Obligation. constructor; apply _. Qed.

  Global Instance: Functor homFrom _.
  Proof.
   constructor; try apply _.
     constructor; try apply _.
     repeat intro. simpl in *.
     apply comp_proper; auto.
    repeat intro.
    simpl.
    rewrite H1.
    apply left_identity.
   repeat intro.
   simpl.
   unfold compose.
   rewrite H1.
   symmetry.
   apply comp_assoc.
  Qed.
End contents.


Require Export ZArith.
Require Export FunInd.
Open Scope Z_scope.
Open Scope list.

Inductive expr : Set :=
  | Cte : Z -> expr
  | Var : nat -> expr
  | Plus : expr -> expr -> expr
  | Moins : expr -> expr -> expr
  | Mult : expr -> expr -> expr
  | Div : expr -> expr -> expr
  | True : expr
  | False : expr
  | Non : expr -> expr
  | And : expr -> expr -> expr
  | Or : expr -> expr -> expr
  | Eq : expr -> expr -> expr
  | Neq : expr -> expr -> expr
  | Lt : expr -> expr -> expr
  | Leq : expr -> expr -> expr
  | Gt : expr -> expr -> expr
  | Geq : expr -> expr -> expr.

Inductive value : Set :=
  | ValZ : Z -> value
  | ValB : bool -> value
  | Err : value.

Inductive env_value : Set :=
  | EValZ : Z -> env_value
  | EValB : bool -> env_value.

Definition context := list (nat * env_value).

Fixpoint get_val (n : nat) (env : context) : option env_value :=
  match env with
  | nil => None
  | (index, val)::t =>
    match eq_nat_dec n index with
    | left _ => Some val
    | _ => get_val n t
  end
end.

Inductive eval (env : context) : expr -> value -> Prop :=
  | ECte : forall c : Z, eval env (Cte c) (ValZ c)
  | EVarZ : forall (n : nat) (v : Z), (get_val n env) = Some (EValZ v) -> eval env (Var n) (ValZ v)
  | EVarB : forall (n : nat) (v : bool), (get_val n env) = Some (EValB v) -> eval env (Var n) (ValB v)
  | EVar_Err : forall (n : nat), (get_val n env) = None -> eval env (Var n) Err
  | EPlus : forall (e1 e2 : expr) (v1 v2 v : Z),
    eval env e1 (ValZ v1) -> eval env e2 (ValZ v2)
    -> v = v1 + v2 -> eval env (Plus e1 e2) (ValZ v)
  | EPlus_ErrL : forall (e1 e2 : expr),
    eval env e1 Err -> eval env (Plus e1 e2) Err
  | EPlus_ErrR : forall (e1 e2 : expr) (v : Z),
    eval env e1 (ValZ v) -> eval env e2 Err
    -> eval env (Plus e1 e2) Err
  | EPlus_ErrBL : forall (e1 e2 : expr) (b : bool),
    eval env e1 (ValB b) -> eval env (Plus e1 e2) Err
  | EPlus_ErrBR : forall (e1 e2 : expr) (v : Z) (b : bool),
    eval env e1 (ValZ v) -> eval env e2 (ValB b) -> eval env (Plus e1 e2) Err
  | EMoins : forall (e1 e2 : expr) (v1 v2 v : Z),
    eval env e1 (ValZ v1) -> eval env e2 (ValZ v2)
    -> v = v1 - v2 -> eval env (Moins e1 e2) (ValZ v)
  | EMoins_ErrL : forall (e1 e2 : expr),
    eval env e1 Err -> eval env (Moins e1 e2) Err
  | EMoins_ErrR : forall (e1 e2 : expr) (v : Z),
    eval env e1 (ValZ v) -> eval env e2 Err
    -> eval env (Moins e1 e2) Err
  | EMoins_ErrBL : forall (e1 e2 : expr) (b : bool),
    eval env e1 (ValB b) -> eval env (Moins e1 e2) Err
  | EMoins_ErrBR : forall (e1 e2 : expr) (v : Z) (b : bool),
    eval env e1 (ValZ v) -> eval env e2 (ValB b) -> eval env (Moins e1 e2) Err
  | EMult : forall (e1 e2 : expr) (v1 v2 v : Z),
    eval env e1 (ValZ v1) -> eval env e2 (ValZ v2)
    -> v = v1 * v2 -> eval env (Mult e1 e2) (ValZ v)
  | EMult_ErrL : forall (e1 e2 : expr),
    eval env e1 Err -> eval env (Mult e1 e2) Err
  | EMult_ErrR : forall (e1 e2 : expr) (v : Z),
    eval env e1 (ValZ v) -> eval env e2 Err
    -> eval env (Mult e1 e2) Err
  | EMult_ErrBL : forall (e1 e2 : expr) (b : bool),
    eval env e1 (ValB b) -> eval env (Mult e1 e2) Err
  | EMult_ErrBR : forall (e1 e2 : expr) (v : Z) (b : bool),
    eval env e1 (ValZ v) -> eval env e2 (ValB b) -> eval env (Mult e1 e2) Err
  | EDiv : forall (e1 e2 : expr) (v1 v2 v : Z),
    eval env e1 (ValZ v1) -> eval env e2 (ValZ v2)
    -> v = v1 / v2 -> eval env (Div e1 e2) (ValZ v)
  | EDiv_ErrL : forall (e1 e2 : expr),
    eval env e1 Err -> eval env (Div e1 e2) Err
  | EDiv_ErrR : forall (e1 e2 : expr) (v : Z),
    eval env e1 (ValZ v) -> eval env e2 Err
    -> eval env (Div e1 e2) Err
  | EDiv_ErrBL : forall (e1 e2 : expr) (b : bool),
    eval env e1 (ValB b) -> eval env (Div e1 e2) Err
  | EDiv_ErrBR : forall (e1 e2 : expr) (v : Z) (b : bool),
    eval env e1 (ValZ v) -> eval env e2 (ValB b) -> eval env (Div e1 e2) Err
  | ETrue : eval env True (ValB true)
  | EFalse : eval env False (ValB false)
  | ENon : forall (e : expr) (b nb : bool), eval env e (ValB b) ->
    nb = negb b -> eval env (Non e) (ValB nb)
  | ENon_ErrDne : forall e : expr, eval env e Err -> eval env (Non e) Err
  | ENon_ErrZ : forall (e : expr) (v : Z), eval env e (ValZ v) -> eval env (Non e) Err
  | EAnd : forall (e1 e2 : expr) (b1 b2 b: bool), eval env e1 (ValB b1) ->
    eval env e2 (ValB b2) -> b = (andb b1 b2) -> eval env (And e1 e2) (ValB b)
  | EAnd_ErrL : forall (e1 e2 : expr), eval env e1 Err -> eval env (And e1 e2) Err
  | EAnd_ErrR : forall (e1 e2 : expr) (b : bool),
    eval env e1 (ValB b) -> eval env e2 Err -> eval env (And e1 e2) Err
  | EAnd_ErrZL : forall (e1 e2 : expr) (v : Z),
    eval env e1 (ValZ v) -> eval env (And e1 e2) Err
  | EAnd_ErrZR : forall (e1 e2 : expr) (b : bool) (v : Z),
    eval env e1 (ValB b) -> eval env e2 (ValZ v) -> eval env (And e1 e2) Err
  | EOr : forall (e1 e2 : expr) (b1 b2 b : bool), eval env e1 (ValB b1) ->
    eval env e2 (ValB b2) -> b = (orb b1 b2) -> eval env (Or e1 e2) (ValB b)
  | EOr_ErrL : forall (e1 e2 : expr), eval env e1 Err -> eval env (Or e1 e2) Err
  | EOr_ErrR : forall (e1 e2 : expr) (b : bool),
    eval env e1 (ValB b) -> eval env e2 Err -> eval env (Or e1 e2) Err
  | EOr_ErrZL : forall (e1 e2 : expr) (v : Z),
    eval env e1 (ValZ v) -> eval env (Or e1 e2) Err
  | EOr_ErrZR : forall (e1 e2 : expr) (b : bool) (v : Z),
    eval env e1 (ValB b) -> eval env e2 (ValZ v) -> eval env (Or e1 e2) Err.

Open Scope nat_scope.

Lemma eval1 : eval ((1, (EValZ 1))::(2, (EValZ 3))::(3, (EValB true))::nil)
    (Plus (Cte 5) (Cte 2)) (ValZ 7).
eapply EPlus.
apply ECte.
apply ECte.
auto.
Qed.
apply EOr.
apply EAnd.
apply EOrL.
apply ETrue.
apply ETrue.
Qed.


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

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

Print Assumptions square.