(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 7: Operational Semantics
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.

(* OK, enough with defining transition relations manually.  Let's return to our
 * syntax of imperative programs from Chapter 3. *)

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (then_ else_ : cmd)
| While (e : arith) (body : cmd).
(* Important differences: we added [If] and switched [Repeat] to general
 * [While]. *)

(* Here are some notations for the language, which again we won't really
 * explain. *)
Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Infix "+" := Plus : arith_scope.
Infix "-" := Minus : arith_scope.
Infix "*" := Times : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
Notation "'when' e 'then' then_ 'else' else_ 'done'" := (If e%arith then_ else_) (at level 75, e at level 0).
Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).

(* Here's an adaptation of our factorial example from Chapter 3. *)
Example factorial :=
  "output" <- 1;;
  while "input" loop
    "output" <- "output" * "input";;
    "input" <- "input" - 1
  done.

(* Recall our use of a recursive function to interpret expressions. *)
Definition valuation := fmap var nat.
Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Minus e1 e2 => interp e1 v - interp e2 v
  | Times e1 e2 => interp e1 v * interp e2 v
  end.

(* Our old trick of interpreters won't work for this new language, because of
 * the general "while" loops.  No such interpreter could terminate for all
 * programs.  Instead, we will use inductive predicates to explain program
 * meanings.  First, let's apply the most intuitive method, called
 * *big-step operational semantics*. *)
Inductive eval : valuation -> cmd -> valuation -> Prop :=
| EvalSkip : forall v,
  eval v Skip v
| EvalAssign : forall v x e,
  eval v (Assign x e) (v $+ (x, interp e v))
| EvalSeq : forall v c1 v1 c2 v2,
  eval v c1 v1
  -> eval v1 c2 v2
  -> eval v (Sequence c1 c2) v2
| EvalIfTrue : forall v e then_ else_ v',
  interp e v <> 0
  -> eval v then_ v'
  -> eval v (If e then_ else_) v'
| EvalIfFalse : forall v e then_ else_ v',
  interp e v = 0
  -> eval v else_ v'
  -> eval v (If e then_ else_) v'
| EvalWhileTrue : forall v e body v' v'',
  interp e v <> 0
  -> eval v body v'
  -> eval v' (While e body) v''
  -> eval v (While e body) v''
| EvalWhileFalse : forall v e body,
  interp e v = 0
  -> eval v (While e body) v.

(* Let's run the factorial program on a few inputs. *)
Theorem factorial_2 : exists v, eval ($0 $+ ("input", 2)) factorial v
                                /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.
  (* [eexists]: to prove [exists x, P(x)], switch to proving [P(?y)], for a new
   *   existential variable [?y]. *)

  unfold factorial.
  econstructor.
  econstructor.
  simplify.
  econstructor.
  simplify.
  equality.
  econstructor.
  econstructor.
  simplify.
  econstructor.
  simplify.
  econstructor.
  simplify.
  equality.
  econstructor.
  econstructor.
  simplify.
  econstructor.
  simplify.
  apply EvalWhileFalse.
  (* Note that, for this step, we had to specify which rule to use, since
   * otherwise [econstructor] incorrectly guesses [EvalWhileTrue]. *)
  simplify.
  equality.

  simplify.
  equality.
Qed.

(* That was rather repetitive.  It's easy to automate. *)

Ltac eval1 :=
  apply EvalSkip || apply EvalAssign || eapply EvalSeq
  || (apply EvalIfTrue; [ simplify; equality | ])
  || (apply EvalIfFalse; [ simplify; equality | ])
  || (eapply EvalWhileTrue; [ simplify; equality | | ])
  || (apply EvalWhileFalse; [ simplify; equality ]).
Ltac evaluate := simplify; try equality; repeat eval1.

Theorem factorial_2_snazzy : exists v, eval ($0 $+ ("input", 2)) factorial v
                                       /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.
  evaluate.
  evaluate.
Qed.

Theorem factorial_3 : exists v, eval ($0 $+ ("input", 3)) factorial v
                                /\ v $? "output" = Some 6.
Proof.
  eexists; propositional.
  evaluate.
  evaluate.
Qed.

(* Instead of chugging through these relatively slow individual executions,
 * let's prove once and for all that [factorial] is correct. *)
Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => n * fact n'
  end.

Example factorial_loop :=
  while "input" loop
    "output" <- "output" * "input";;
    "input" <- "input" - 1
  done.

Lemma factorial_loop_correct : forall n v out, v $? "input" = Some n
  -> v $? "output" = Some out
  -> exists v', eval v factorial_loop v'
                /\ v' $? "output" = Some (fact n * out).
Proof.
  induct n; simplify.

  exists v; propositional.
  unfold factorial_loop.
  apply EvalWhileFalse.
  simplify.
  rewrite H.
  equality.
  rewrite H0.
  f_equal.
  ring.

  (* [assert P]: first prove proposition [P], then continue with it as a new
   *   hypothesis. *)
  assert (exists v', eval (v $+ ("output", out * S n)
                             $+ ("input", n)) factorial_loop v'
                     /\ v' $? "output" = Some (fact n * (out * S n))).
  apply IHn.
  simplify; equality.
  simplify; equality.
  (* [first_order]: simplify first-order logic structure.  Be forewarned: this
   *   one is especially likely to run forever! *)
  first_order.

  eexists; propositional.
  econstructor.
  simplify.
  rewrite H.
  equality.
  econstructor.
  econstructor.
  econstructor.
  simplify.
  rewrite H, H0.
  replace (S n - 1) with n by linear_arithmetic.
  (* [replace e1 with e2 by tac]: replace occurrences of [e1] with [e2], proving
   *   [e2 = e1] with tactic [tac]. *)

  apply H1.
  rewrite H2.
  f_equal.
  ring.
Qed.

Theorem factorial_correct : forall n v, v $? "input" = Some n
  -> exists v', eval v factorial v'
                /\ v' $? "output" = Some (fact n).
Proof.
  simplify.
  assert (exists v', eval (v $+ ("output", 1)) factorial_loop v'
                     /\ v' $? "output" = Some (fact n * 1)).
  apply factorial_loop_correct.
  simplify; equality.
  simplify; equality.
  first_order.

  eexists; propositional.
  unfold factorial.
  econstructor.
  econstructor.
  simplify.

  apply H0.
  rewrite H1.
  f_equal.
  ring.
Qed.

(** * Small-step semantics *)

(* Big-step semantics only tells us something about the behavior of terminating
 * programs.  Our imperative language clearly supports nontermination, thanks to
 * the inclusion of general "while" loops.  A switch to *small-step* semantics
 * lets us also explain what happens with nonterminating executions, and this
 * style will also come in handy for more advanced features like concurrency. *)

Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
| StepAssign : forall v x e,
  step (v, Assign x e) (v $+ (x, interp e v), Skip)
| StepSeq1 : forall v c1 c2 v' c1',
  step (v, c1) (v', c1')
  -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
| StepSeq2 : forall v c2,
  step (v, Sequence Skip c2) (v, c2)
| StepIfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step (v, If e then_ else_) (v, then_)
| StepIfFalse : forall v e then_ else_,
  interp e v = 0
  -> step (v, If e then_ else_) (v, else_)
| StepWhileTrue : forall v e body,
  interp e v <> 0
  -> step (v, While e body) (v, Sequence body (While e body))
| StepWhileFalse : forall v e body,
  interp e v = 0
  -> step (v, While e body) (v, Skip).

(* Here's a small-step factorial execution. *)
Theorem factorial_2_small : exists v, step^* ($0 $+ ("input", 2), factorial) (v, Skip)
                                      /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.

  Print trc.
  econstructor; simplify.
  unfold factorial.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  apply StepSeq2; simplify.
  econstructor; simplify.
  econstructor; simplify.
  equality.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  apply StepSeq2; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  apply StepSeq2; simplify.
  econstructor; simplify.
  econstructor; simplify.
  simplify; simplify.
  equality.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  apply StepSeq2; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  econstructor; simplify.
  apply StepSeq2; simplify.
  econstructor; simplify.
  apply StepWhileFalse; simplify.
  equality.

  econstructor.

  simplify.
  equality.
Qed.

Ltac step1 :=
  apply TrcRefl || eapply TrcFront
  || apply StepAssign || apply StepSeq2 || eapply StepSeq1
  || (apply StepIfTrue; [ simplify; equality ])
  || (apply StepIfFalse; [ simplify; equality ])
  || (eapply StepWhileTrue; [ simplify; equality ])
  || (apply StepWhileFalse; [ simplify; equality ]).
Ltac stepper := simplify; try equality; repeat step1.

Theorem factorial_2_small_snazzy : exists v, step^* ($0 $+ ("input", 2), factorial) (v, Skip)
                                             /\ v $? "output" = Some 2.
Proof.
  eexists; propositional.

  stepper.
  stepper.
Qed.

(* It turns out that these two semantics styles are equivalent.  Let's prove
 * it. *)

Lemma step_star_Seq : forall v c1 c2 v' c1',
  step^* (v, c1) (v', c1')
  -> step^* (v, Sequence c1 c2) (v', Sequence c1' c2).
Proof.
  induct 1.

  constructor.
  (* TrcRefl *)

    cases y.
  (* curious use of [cases] tactic. *)
  econstructor.
  econstructor.

  eassumption.
  apply IHtrc.
  equality.
  equality.
Qed.

Theorem big_small : forall v c v', eval v c v'
  -> step^* (v, c) (v', Skip).
Proof.
  induct 1; simplify.

  constructor.
  (* same as [apply TrcRefl] *)

  econstructor.
  (* same as [apply TrcFront] *)
  constructor.
  constructor.
  (* same as [apply TrcRefl] *)

  Check trc_trans.
  eapply trc_trans.
  apply step_star_Seq.
  (* clever combination of [trc_trans] and [step_star_Seq] *)
  eassumption.
  econstructor.
  apply StepSeq2.
  assumption.

  econstructor.
  constructor.
  assumption.
  assumption.

  econstructor.
  apply StepIfFalse.
  assumption.
  assumption.

  econstructor.
  constructor.
  assumption.
  eapply trc_trans.
  apply step_star_Seq.
  (* another one *)
  eassumption.
  econstructor.
  apply StepSeq2.
  assumption.

  econstructor.
  apply StepWhileFalse.
  assumption.
  constructor.
Qed.

Lemma small_big'' : forall v c v' c', step (v, c) (v', c')
   -> forall v'', eval v' c' v''
   -> eval v c v''.
Proof.
  induct 1; simplify.

  invert H.
  constructor.

  invert H0.
  econstructor.
  apply IHstep.
  eassumption.
  assumption.

  econstructor.
  constructor.
  assumption.

  constructor.
  assumption.
  assumption.

  apply EvalIfFalse.
  assumption.
  assumption.

  invert H0.
  econstructor.
  assumption.
  eassumption.
  assumption.

  invert H0.
  apply EvalWhileFalse.
  assumption.
Qed.

Lemma small_big' : forall v c v' c', step^* (v, c) (v', c')
    -> forall v'', eval v' c' v''
    -> eval v c v''.
Proof.
  induct 1; simplify.

  trivial.

  cases y.
  (* Use cases to expose the fact that [y] is a pair of values *)
  eapply small_big''.
  eassumption.
  eapply IHtrc.
  equality.
  equality.
  assumption.
Qed.

Theorem small_big : forall v c v', step^* (v, c) (v', Skip)
  -> eval v c v'.
Proof.
  simplify.
  eapply small_big'.
  eassumption.
  constructor.
Qed.

(* Bonus material: here's how to make these proofs much more automatic.  We
 * won't explain the features being used here. *)

Hint Constructors trc step eval.

Lemma step_star_Seq_snazzy : forall v c1 c2 v' c1',
  step^* (v, c1) (v', c1')
  -> step^* (v, Sequence c1 c2) (v', Sequence c1' c2).
Proof.
  induct 1; eauto.
  cases y; eauto.
Qed.

Hint Resolve step_star_Seq_snazzy.

Theorem big_small_snazzy : forall v c v', eval v c v'
  -> step^* (v, c) (v', Skip).
Proof.
  induct 1; eauto 6 using trc_trans.
Qed.

Lemma small_big''_snazzy : forall v c v' c', step (v, c) (v', c')
                                             -> forall v'', eval v' c' v''
                                                            -> eval v c v''.
Proof.
  induct 1; simplify;
  repeat match goal with
         | [ H : eval _ _ _ |- _ ] => invert1 H
         end; eauto.
Qed.

Hint Resolve small_big''_snazzy.

Lemma small_big'_snazzy : forall v c v' c', step^* (v, c) (v', c')
                                            -> forall v'', eval v' c' v''
                                                           -> eval v c v''.
Proof.
  induct 1; eauto.
  cases y; eauto.
Qed.

Hint Resolve small_big'_snazzy.

Theorem small_big_snazzy : forall v c v', step^* (v, c) (v', Skip)
                                   -> eval v c v'.
Proof.
  eauto.
Qed.

(** * Small-step semantics gives rise to transition systems. *)

Definition trsys_of (v : valuation) (c : cmd) : trsys (valuation * cmd) := {|
  Initial := {(v, c)};
  Step := step
|}.

Theorem simple_invariant :
  invariantFor (trsys_of ($0 $+ ("a", 1)) ("b" <- "a" + 1;; "c" <- "b" + "b"))
               (fun s => snd s = Skip -> fst s $? "c" = Some 4).
Proof.
  model_check.
  (* Not covered in this course, but available in the book.
     It is a way of automatically coming up with the strongest inductive
     invariant for **finite** transition systems (reachable states are finite),
     then using it to prove weaker invariants *)
Qed.

Definition my_loop :=
  while "n" loop
    "a" <- "a" + "n";;
    "n" <- "n" - 2
  done.

(* For the above program, initially, if [n] is even, then [a] stays
   even during execution.

   This invariant cannot be model checked since [n] can be an arbitrary
   natural number and hence, the reachable states are **infinite**. We
   can prove manually that [a] is always even. *)

(* First, the definition of evenness. *)

Inductive isEven : nat -> Prop :=
| EvenO : isEven 0
| EvenSS : forall n, isEven n -> isEven (S (S n)).

(* Some facts about even *)
Lemma isEven_minus2 : forall n, isEven n -> isEven (n - 2).
Proof.
  induct 1; simplify.

  constructor.

  replace (n - 0) with n by linear_arithmetic.
  assumption.
Qed.

Lemma isEven_plus : forall n m,
  isEven n
  -> isEven m
  -> isEven (n + m).
Proof.
  induct 1; simplify.

  assumption.

  constructor.
  apply IHisEven.
  assumption.
Qed.

Definition all_programs := {
  (while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),

   ("a" <- "a" + "n";;
   "n" <- "n" - 2),

  (Skip;;
   "n" <- "n" - 2),

  ("n" <- "n" - 2),

  (("a" <- "a" + "n";;
    "n" <- "n" - 2);;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),

  ((Skip;;
    "n" <- "n" - 2);;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),

  ("n" <- "n" - 2;;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),

  (Skip;;
   while "n" loop
     "a" <- "a" + "n";;
     "n" <- "n" - 2
   done),

  Skip
}.

Check all_programs.

Lemma manually_proved_invariant' : forall n,
  isEven n
  -> invariantFor (trsys_of ($0 $+ ("n", n) $+ ("a", 0)) (while "n" loop "a" <- "a" + "n";; "n" <- "n" - 2 done))
               (fun s => all_programs (snd s)
                         /\ exists n a, fst s $? "n" = Some n
                                        /\ fst s $? "a" = Some a
                                        /\ isEven n
                                        /\ isEven a).
Proof.
  simplify.
  apply invariant_induction; simplify.

  propositional.
  unfold all_programs.
  subst.
  subst; simplify; equality.
  (* [subst] performs all possible rewrites and clears the hypothesis
     used for substitutions. *)
  subst; simplify.
  exists n, 0.
  (* substitute for existentially quantified variables. The above tactic
     is equivalent to.

     [eexists. eexists. instantitate (1:=0). instantiate (1:=n)] *)
  propositional.
  constructor.

  invert H0.
  invert H3.
  invert H0.
  invert H3.
  invert H4.
  invert H5.
  (* Note our use here of [invert] to break down hypotheses with [exists] and
   * [/\]. *)
  invert H1; simplify.

  unfold all_programs in *; simplify; propositional; try equality.
  invert H2; simplify.
  rewrite H0.
  exists (x - 2), x0; propositional.
  apply isEven_minus2; assumption.

  unfold all_programs in *; simplify; propositional; try equality.
  invert H2.
  invert H5; equality.

  invert H2.
  invert H5.
  rewrite H0, H3; simplify.
  do 2 eexists.
  propositional; try eassumption.
  apply isEven_plus; assumption.

  invert H1.
  invert H5.
  invert H1.
  invert H5.

  invert H1.
  invert H5.
  invert H2.
  equality.

  invert H1.
  invert H5.
  invert H2.
  rewrite H0, H3; simplify.
  eexists; eexists; propositional; try eassumption.
  apply isEven_plus; assumption.

  invert H2.
  invert H5.
  invert H2.
  equality.

  invert H2.
  invert H5.
  invert H2.
  eexists; eexists; propositional; eassumption.

  invert H1.
  invert H5.
  equality.

  invert H1.
  invert H5.
  rewrite H0; simplify.
  do 2 eexists; propositional; try eassumption.
  apply isEven_minus2; assumption.

  invert H2.
  invert H5.

  invert H2.
  invert H5.

  unfold all_programs in *; simplify; propositional; try equality.
  invert H1.
  do 2 eexists; propositional; try eassumption.

  invert H2.
  do 2 eexists; propositional; try eassumption.

  unfold all_programs in *; simplify; propositional; equality.

  unfold all_programs in *; simplify; propositional; equality.

  unfold all_programs in *; simplify; propositional; try equality.
  invert H1.
  do 2 eexists; propositional; try eassumption.

  unfold all_programs in *; simplify; propositional; try equality.
  invert H1.
  do 2 eexists; propositional; try eassumption.
Qed.

(* That manual proof was quite a pain.  Here's a bonus automated proof. *)
Hint Constructors isEven.
Hint Resolve isEven_minus2 isEven_plus.

Lemma manually_proved_invariant'_snazzy : forall n,
  isEven n
  -> invariantFor (trsys_of ($0 $+ ("n", n) $+ ("a", 0)) (while "n" loop "a" <- "a" + "n";; "n" <- "n" - 2 done))
               (fun s => all_programs (snd s)
                         /\ exists n a, fst s $? "n" = Some n
                                        /\ fst s $? "a" = Some a
                                        /\ isEven n
                                        /\ isEven a).
Proof.
  simplify; apply invariant_induction; simplify; unfold all_programs in *; first_order; subst; simplify;
  try match goal with
      | [ H : step _ _ |- _ ] => invert H; simplify
      end;
  repeat (match goal with
          | [ H : _ = Some _ |- _ ] => rewrite H
          | [ H : @eq cmd (_ _ _) _ |- _ ] => invert H
          | [ H : @eq cmd (_ _ _ _) _ |- _ ] => invert H
          | [ H : step _ _ |- _ ] => invert2 H
          end; simplify); equality || eauto 7.
Qed.

Theorem manually_proved_invariant : forall n,
  isEven n
  -> invariantFor (trsys_of ($0 $+ ("n", n) $+ ("a", 0)) (while "n" loop "a" <- "a" + "n";; "n" <- "n" - 2 done))
               (fun s => exists a, fst s $? "a" = Some a /\ isEven a).
Proof.
  simplify.
  eapply invariant_weaken.
  apply manually_proved_invariant'; assumption.
  first_order.
Qed.

(* We'll return to these systems and their abstractions in the next few
 * chapters. *)

(** * Contextual small-step semantics *)

(* There is a common way to factor a small-step semantics into different parts,
 * to make the semantics easier to understand and extend.  First, we define a
 * notion of *evaluation contexts*, which are commands with *holes* in them. *)
Inductive context :=
| Hole
| CSeq (C : context) (c : cmd).

(* This relation explains how to plug the hole in a context with a specific
 * term.  Note that we use an inductive relation instead of a recursive
 * definition, because Coq's proof automation is better at working with
 * relations. *)
Inductive plug : context -> cmd -> cmd -> Prop :=
| PlugHole : forall c, plug Hole c c
| PlugSeq : forall c C c' c2,
  plug C c c'
  -> plug (CSeq C c2) c (Sequence c' c2).

(* Now we define almost the same step relation as before, with one omission:
 * only the more trivial of the [Sequence] rules remains. *)
Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
| Step0Assign : forall v x e,
  step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
| Step0Seq : forall v c2,
  step0 (v, Sequence Skip c2) (v, c2)
| Step0IfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step0 (v, If e then_ else_) (v, then_)
| Step0IfFalse : forall v e then_ else_,
  interp e v = 0
  -> step0 (v, If e then_ else_) (v, else_)
| Step0WhileTrue : forall v e body,
  interp e v <> 0
  -> step0 (v, While e body) (v, Sequence body (While e body))
| Step0WhileFalse : forall v e body,
  interp e v = 0
  -> step0 (v, While e body) (v, Skip).

(* We recover the meaning of the original with one top-level rule, combining
 * plugging of contexts with basic steps. *)
Inductive cstep : valuation * cmd -> valuation * cmd -> Prop :=
| CStep : forall C v c v' c' c1 c2,
  plug C c c1
  -> step0 (v, c) (v', c')
  -> plug C c' c2
  -> cstep (v, c1) (v', c2).

(* We can prove equivalence between the two formulations. *)

Theorem step_cstep : forall v c v' c',
  step (v, c) (v', c')
  -> cstep (v, c) (v', c').
Proof.
  induct 1.

  econstructor.
  constructor.
  constructor.
  constructor.

  invert IHstep.
  econstructor.
  apply PlugSeq.
  eassumption.
  eassumption.
  constructor.
  eassumption.

  econstructor.
  constructor.
  constructor.
  constructor.

  econstructor.
  constructor.
  constructor.
  assumption.
  constructor.

  econstructor.
  constructor.
  apply Step0IfFalse.
  assumption.
  constructor.

  econstructor.
  constructor.
  constructor.
  assumption.
  constructor.

  econstructor.
  constructor.
  apply Step0WhileFalse.
  assumption.
  constructor.
Qed.

Lemma step0_step : forall v c v' c',
  step0 (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
  invert 1; constructor; assumption.
Qed.

Lemma cstep_step' : forall C c0 c,
  plug C c0 c (* C[c0] = c *)
  -> forall v' c'0 v c', step0 (v, c0) (v', c'0) (* (v,c0) ->0 (v',c'0) *)
  -> plug C c'0 c' (* C[C'0] = c' *)
  -> step (v, c) (v', c'). (* (v,c) -> (v',c') *)
Proof.
  induct 1; simplify.

  invert H0.
  apply step0_step.
  assumption.

  invert H1.
  econstructor. (* appeal to the congruence rule in [step] *)
  eapply IHplug.
  eassumption.
  assumption.
Qed.

Theorem cstep_step : forall v c v' c',
  cstep (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
  invert 1.
  eapply cstep_step'.
  eassumption.
  eassumption.
  assumption.
Qed.

(* Bonus material: here's how to make these proofs much more automatic.  We
 * won't explain the features being used here. *)

Hint Constructors plug step0 cstep.

Theorem step_cstep_snazzy : forall v c v' c',
  step (v, c) (v', c')
  -> cstep (v, c) (v', c').
Proof.
  induct 1; repeat match goal with
                   | [ H : cstep _ _ |- _ ] => invert H
                   end; eauto.
Qed.

Hint Resolve step_cstep_snazzy.

Lemma step0_step_snazzy : forall v c v' c',
  step0 (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
  invert 1; eauto.
Qed.

Hint Resolve step0_step_snazzy.

Lemma cstep_step'_snazzy : forall C c0 c,
  plug C c0 c
  -> forall v' c'0 v c', step0 (v, c0) (v', c'0)
  -> plug C c'0 c'
  -> step (v, c) (v', c').
Proof.
  induct 1; simplify; repeat match goal with
                             | [ H : plug _ _ _ |- _ ] => invert1 H
                             end; eauto.
Qed.

Hint Resolve cstep_step'_snazzy.

Theorem cstep_step_snazzy : forall v c v' c',
  cstep (v, c) (v', c')
  -> step (v, c) (v', c').
Proof.
  invert 1; eauto.
Qed.

(** * Determinism *)

(* Each of the relations we have defined turns out to be deterministic.  Let's
 * prove it. *)

Theorem eval_det : forall v c v1,
  eval v c v1
  -> forall v2, eval v c v2
  -> v1 = v2.
Proof.
  (* induct 1. 3: { intro. intro. invert' H1. apply IHeval2. apply IHeval1 in H5. subst. assumption. } intro. intro. invert H. equality. intro.  intro. invert H. equality. intro. intro. invert H1. firstorder. firstorder. *)
  induct 1; invert 1; try first_order.
  (* [invert 1] is new *)

  apply IHeval2.
  apply IHeval1 in H5.
  subst.
  assumption.

  apply IHeval2.
  apply IHeval1 in H7.
  subst.
  assumption.
Qed.

Theorem step_det : forall s out1,
  step s out1
  -> forall out2, step s out2
  -> out1 = out2.
Proof.
  induct 1; invert 1; try first_order.

  apply IHstep in H5.
  equality.

  invert H.

  invert H4.
Qed.

Theorem cstep_det : forall s out1,
  cstep s out1
  -> forall out2, cstep s out2
  -> out1 = out2.
Proof.
  simplify.
  cases s; cases out1; cases out2.
  eapply step_det.
  apply cstep_step.
  eassumption.
  apply cstep_step.
  eassumption.
Qed.

(** * Example of how easy it is to add concurrency to a contextual semantics *)

Module Concurrent.
  (* Let's add a construct for *parallel execution* of two commands.  Such
   * parallelism may be nested arbitrarily. *)
  Inductive cmd :=
  | Skip
  | Assign (x : var) (e : arith)
  | Sequence (c1 c2 : cmd)
  | If (e : arith) (then_ else_ : cmd)
  | While (e : arith) (body : cmd)
  | Parallel (c1 c2 : cmd).

  Notation "x <- e" := (Assign x e%arith) (at level 75).
  Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
  Notation "'when' e 'then' then_ 'else' else_ 'done'" := (If e%arith then_ else_) (at level 75, e at level 0).
  Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).
  Infix "||" := Parallel.

  (* We need surprisingly few changes to the contextual semantics, to explain
   * this new feature.  First, we allow a hole to appear on *either side* of a
   * [Parallel].  In other words, the "scheduler" may choose either "thread" to
   * run next. *)
  Inductive context :=
  | Hole
  | CSeq (C : context) (c : cmd)
  | CPar1 (C : context) (c : cmd)
  | CPar2 (c : cmd) (C : context).

  (* We explain the meaning of plugging the new contexts in the obvious way. *)
  Inductive plug : context -> cmd -> cmd -> Prop :=
  | PlugHole : forall c, plug Hole c c
  | PlugSeq : forall c C c' c2,
    plug C c c'
    -> plug (CSeq C c2) c (Sequence c' c2)
  | PlugPar1 : forall c C c' c2,
    plug C c c'
    -> plug (CPar1 C c2) c (Parallel c' c2)
  | PlugPar2 : forall c C c' c1,
    plug C c c'
    -> plug (CPar2 c1 C) c (Parallel c1 c').

  (* The only new step rules are for "cleaning up" finished "threads," which
   * have reached the point of being [Skip] commands. *)
  Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
  | Step0Assign : forall v x e,
    step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
  | Step0Seq : forall v c2,
    step0 (v, Sequence Skip c2) (v, c2)
  | Step0IfTrue : forall v e then_ else_,
    interp e v <> 0
    -> step0 (v, If e then_ else_) (v, then_)
  | Step0IfFalse : forall v e then_ else_,
    interp e v = 0
    -> step0 (v, If e then_ else_) (v, else_)
  | Step0WhileTrue : forall v e body,
    interp e v <> 0
    -> step0 (v, While e body) (v, Sequence body (While e body))
  | Step0WhileFalse : forall v e body,
    interp e v = 0
    -> step0 (v, While e body) (v, Skip)
  | Step0Par1 : forall v c,
    step0 (v, Parallel Skip c) (v, c).

  Inductive cstep : valuation * cmd -> valuation * cmd -> Prop :=
  | CStep : forall C v c v' c' c1 c2,
    plug C c c1
    -> step0 (v, c) (v', c')
    -> plug C c' c2
    -> cstep (v, c1) (v', c2).

  (** Example: stepping a specific program. *)

  (* Here's the classic cautionary-tale program about remembering to lock your
   * concurrent threads. *)
  Definition prog :=
    ("a" <- "n";;
     "n" <- "a" + 1)
    || ("b" <- "n";;
        "n" <- "b" + 1).

  Hint Constructors plug step0 cstep.

  (* The naive "expected" answer is attainable. *)
  Theorem correctAnswer : forall n, exists v, cstep^* ($0 $+ ("n", n), prog) (v, Skip)
                                              /\ v $? "n" = Some (n + 2).
  Proof.
    eexists; propositional.
    unfold prog.

    econstructor.
    eapply CStep with (C := CPar1 (CSeq Hole _) _); eauto.

    econstructor.
    eapply CStep with (C := CPar1 Hole _); eauto.

    econstructor.
    eapply CStep with (C := CPar1 Hole _); eauto.

    econstructor.
    eapply CStep with (C := Hole); eauto.

    econstructor.
    eapply CStep with (C := CSeq Hole _); eauto.

    econstructor.
    eapply CStep with (C := Hole); eauto.

    econstructor.
    eapply CStep with (C := Hole); eauto.

    econstructor.

    simplify.
    f_equal.
    ring.
  Qed.

  (* But so is the "wrong" answer! *)
  Theorem wrongAnswer : forall n, exists v, cstep^* ($0 $+ ("n", n), prog) (v, Skip)
                                            /\ v $? "n" = Some (n + 1).
  Proof.
    eexists; propositional.
    unfold prog.

    econstructor.
    eapply CStep with (C := CPar1 (CSeq Hole _) _); eauto.

    econstructor.
    eapply CStep with (C := CPar2 _ (CSeq Hole _)); eauto.

    econstructor.
    eapply CStep with (C := CPar1 Hole _); eauto.

    econstructor.
    eapply CStep with (C := CPar2 _ Hole); eauto.

    econstructor.
    eapply CStep with (C := CPar1 Hole _); eauto.

    econstructor.
    eapply CStep with (C := Hole); eauto.

    econstructor.
    eapply CStep with (C := Hole); eauto.

    econstructor.

    simplify.
    equality.
  Qed.

  (** Proving equivalence with non-contextual semantics *)

  (* To give us something interesting to prove, let's also define a
   * non-contextual small-step semantics.  Note how we have to do some more
   * explicit threading of mutable state through recursive invocations. *)
  Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
  | StepAssign : forall v x e,
    step (v, Assign x e) (v $+ (x, interp e v), Skip)
  | StepSeq1 : forall v c1 c2 v' c1',
    step (v, c1) (v', c1')
    -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
  | StepSeq2 : forall v c2,
    step (v, Sequence Skip c2) (v, c2)
  | StepIfTrue : forall v e then_ else_,
    interp e v <> 0
    -> step (v, If e then_ else_) (v, then_)
  | StepIfFalse : forall v e then_ else_,
    interp e v = 0
    -> step (v, If e then_ else_) (v, else_)
  | StepWhileTrue : forall v e body,
    interp e v <> 0
    -> step (v, While e body) (v, Sequence body (While e body))
  | StepWhileFalse : forall v e body,
    interp e v = 0
    -> step (v, While e body) (v, Skip)
  | StepParSkip1 : forall v c,
    step (v, Parallel Skip c) (v, c)
  | StepPar1 : forall v c1 c2 v' c1',
    step (v, c1) (v', c1')
    -> step (v, Parallel c1 c2) (v', Parallel c1' c2)
  | StepPar2 : forall v c1 c2 v' c2',
    step (v, c2) (v', c2')
    -> step (v, Parallel c1 c2) (v', Parallel c1 c2').

  Hint Constructors step.

  (* Now, an automated proof of equivalence.  Actually, it's *exactly* the same
   * proof we used for the old feature set! *)

  Theorem step_cstep : forall v c v' c',
    step (v, c) (v', c')
    -> cstep (v, c) (v', c').
  Proof.
    induct 1; repeat match goal with
                     | [ H : cstep _ _ |- _ ] => invert H
                     end; eauto.
  Qed.

  Hint Resolve step_cstep.

  Lemma step0_step : forall v c v' c',
    step0 (v, c) (v', c')
    -> step (v, c) (v', c').
  Proof.
    invert 1; eauto.
  Qed.

  Hint Resolve step0_step.

  Lemma cstep_step' : forall C c0 c,
    plug C c0 c
    -> forall v' c'0 v c', step0 (v, c0) (v', c'0)
    -> plug C c'0 c'
    -> step (v, c) (v', c').
  Proof.
    induct 1; simplify; repeat match goal with
                               | [ H : plug _ _ _ |- _ ] => invert1 H
                               end; eauto.
  Qed.

  Hint Resolve cstep_step'.

  Theorem cstep_step : forall v c v' c',
    cstep (v, c) (v', c')
    -> step (v, c) (v', c').
  Proof.
    invert 1; eauto.
  Qed.
End Concurrent.


Require Import List.
Require Import String.
Open Scope string_scope.

Inductive expr : Set :=
| Var : string -> expr
| App : expr -> expr -> expr
| Lam : string -> expr -> expr.

Coercion Var : string >-> expr.

Notation "X @ Y" := (App X Y) (at level 49).
Notation "\ X , Y" := (Lam X Y) (at level 50).

Check (\"x", \"y", "x").
Check (\"x", \"y", "y").
Check ((\"x", "x" @ "x") @ (\"x", "x" @ "x")).

(** e1[e2/x] = e3 *)
Inductive Subst : expr -> expr -> string ->
                  expr -> Prop :=
| SubstVar_same:
    forall e x,
      Subst (Var x) e x e
| SubstVar_diff:
    forall e x1 x2,
      x1 <> x2 ->
      Subst (Var x1) e x2 (Var x1)
| SubstApp:
    forall e1 e2 e x e1' e2',
      Subst e1 e x e1' ->
      Subst e2 e x e2' ->
      Subst (App e1 e2) e x (App e1' e2')
| SubstLam_same:
    forall e1 x e,
      Subst (Lam x e1) e x (Lam x e1)
| SubstLam_diff:
    forall e1 x1 x2 e e1',
      x1 <> x2 ->
      Subst e1 e x2 e1' ->
      Subst (Lam x1 e1) e x2 (Lam x1 e1').

Lemma subst_test_1:
  Subst (\"x", "y") "z" "y"
        (\"x", "z").
Proof.
  apply SubstLam_diff.
  - discriminate.
  - apply SubstVar_same.
Qed.

Lemma subst_test_2:
  Subst (\"x", "x") "z" "x"
        (\"x", "x").
Proof.
  apply SubstLam_same.
Qed.

(**
Call By Name
<<
       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

  -----------------------------
    (\x. e1) e2 --> e1[e2/x]
>>
*)

Inductive step_cbn : expr -> expr -> Prop :=
| CBN_crunch:
    forall e1 e1' e2,
      step_cbn e1 e1' ->
      step_cbn (App e1 e2) (App e1' e2)
| CBN_subst:
    forall x e1 e2 e1',
      Subst e1 e2 x e1' ->
      step_cbn (App (Lam x e1) e2) e1'.

Notation "e1 ==> e2" := (step_cbn e1 e2) (at level 51).

Lemma sstep_test_1:
  (\"x", "x") @ "z" ==> "z".
Proof.
  apply CBN_subst.
  apply SubstVar_same.
Qed.

Lemma Lam_nostep_cbn:
  forall x e1 e2,
  ~ (\x, e1 ==> e2).
Proof.
  intros. intro. inversion H.
Qed.

Ltac inv H := inversion H; subst.

(** careful to make IH sufficiently strong *)
Lemma Subst_det:
  forall e1 e2 x e3,
    Subst e1 e2 x e3 ->
    forall e3',
      Subst e1 e2 x e3' ->
      e3 = e3'.
Proof.
  induction 1; intros.
  - inv H; auto. congruence.
  - inv H0; auto. congruence.
  - inv H1.
    apply IHSubst1 in H4.
    apply IHSubst2 in H8.
    subst; auto.
  - inv H; auto. congruence.
  - inv H1; auto. congruence.
    apply IHSubst in H8; subst; auto.
Qed.

Lemma step_cbn_det:
  forall e e1,
  e ==> e1 ->
  forall e2,
  e ==> e2 ->
  e1 = e2.
Proof.
  induction 1; intros.
  - inv H0.
    + f_equal. apply IHstep_cbn; auto.
    + exfalso. apply Lam_nostep_cbn in H; auto.
  - inv H0.
    + exfalso. apply Lam_nostep_cbn in H4; auto.
    + eapply Subst_det; eauto.
Qed.

(**
Call By Value
<<

v ::= \ x . e

       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

       e2 --> e2'
  ---------------------
    v e2 --> v e2'

  -----------------------------
    (\x. e1) v --> e1[v/x]
>>
*)

Inductive value : expr -> Prop :=
| VLam :
    forall x e,
      value (Lam x e).

Inductive step_cbv : expr -> expr -> Prop :=
| CBV_crunch_l:
    forall e1 e1' e2,
      step_cbv e1 e1' ->
      step_cbv (App e1 e2) (App e1' e2)
| CBV_crunch_r:
    forall v e2 e2',
      value v ->
      step_cbv e2 e2' ->
      step_cbv (App v e2) (App v e2')
| CBV_subst:
    forall x e1 v e1',
      value v ->
      Subst e1 v x e1' ->
      step_cbv (App (Lam x e1) v) e1'.

Notation "e1 --> e2" := (step_cbv e1 e2) (at level 51).

Inductive star (step: expr -> expr -> Prop) :
  expr -> expr -> Prop :=
| star_refl:
    forall s,
      star step s s
| star_step:
    forall s1 s2 s3,
      step s1 s2 ->
      star step s2 s3 ->
      star step s1 s3.

Notation "e1 ==>* e2" := (star step_cbn e1 e2) (at level 51).
Notation "e1 -->* e2" := (star step_cbv e1 e2) (at level 51).

Ltac zex x := exists x.

Lemma can_subst:
  forall e1 e2 x,
  exists e3, Subst e1 e2 x e3.
Proof.
  intros. induction e1.
  - case (string_dec s x); intros; subst.
    + zex e2; constructor.
    + zex (Var s); constructor; auto.
  - destruct IHe1_1; destruct IHe1_2.
    exists (x0 @ x1); constructor; auto.
  - case (string_dec s x); intros; subst.
    + zex (\ x, e1); constructor; auto.
    + destruct IHe1.
      exists (\ s, x0); constructor; auto.
Qed.

Lemma cbv_cbn_can_step:
  forall e1 e2,
    e1 --> e2 ->
    exists e3, e1 ==> e3.
Proof.
  induction 1.
  - destruct IHstep_cbv as [e3 He3].
    exists (e3 @ e2). constructor; auto.
  - inv H. destruct (can_subst e e2 x).
    exists x0; constructor; auto.
  - exists e1'; constructor; auto.
Qed.

(** is the other way true? *)

(** * Church Encodings *)

(** generally assume no free vars! *)

Definition lcTrue :=
  \"x", \"y", "x".

Definition lcFalse :=
  \"x", \"y", "y".

Definition lcCond (c t f: expr) :=
  c @ t @ f.

(** <<

lcCond lcTrue e1 e2 -->* e1

>> *)

Definition lcNot :=
  \"b", "b" @ lcFalse @ lcTrue.

Definition lcAnd :=
  \"a", \"b", "a" @ "b" @ lcFalse.

Definition lcOr :=
  \"a", \"b", "a" @ lcTrue @ "b".

Definition lcMkPair :=
  \"x", \"y",
    (\"s", "s" @ "x" @ "y").

Definition lcFst :=
  \"p", "p" @ (\"x", \"y", "x").

Definition lcSnd :=
  \"p", "p" @ (\"x", \"y", "y").

(** <<

lcSnd (lcFst (lcMkPair (lcMkPair e1 e2) e3)) -->* e2

lcFst = \"p", "p" @ lcTrue

lcSnd = \"p", "p" @ lcFalse

>> *)

Definition lcNil :=
  lcMkPair @ lcFalse @ lcFalse.

Definition lcCons :=
  \"h", \"t", lcMkPair @ lcTrue @ (lcMkPair @ "h" @ "t").

Definition lcIsEmpty :=
  lcFst.

Definition lcHead :=
  \"l", lcFst @ (lcSnd @ "l").

Definition lcTail :=
  \"l", lcSnd @ (lcSnd @ "l").

(** <<

Note that lcTail lcNil does some weird stuff,
but then so does dereferencing null in C or
following null.next() in Java.

>> *)

Definition lc0 :=
  \"s", \"z", "z".

Definition lc1 :=
  \"s", \"z", "s" @ "z".

Definition lc2 :=
  \"s", \"z", "s" @ ("s" @ "z").

Definition lc3 :=
  \"s", \"z", "s" @ ("s" @ ("s" @ "z")).

Definition lc4 :=
  \"s", \"z", "s" @ ("s" @ ("s" @ ("s" @ "z"))).

(** <<

Number "n" composes first arg with itself n times,
starting with the second arg.

>> *)

Definition lcSucc :=
  \"n", \"s", \"z", "s" @ ("n" @ "s" @ "z").

Definition lcAdd :=
  \"n", \"m",
    (\"s", \"z", "n" @ lcSucc @ "m").

Definition lcMul :=
  \"n", \"m",
    (\"s", \"z", "n" @ (lcAdd @ "m") @ lc0).

Definition lcIsZero :=
  \"n",
    "n" @ (\"x", lcFalse) @ lcTrue.

(** <<
  Can keep going to get pred, minus, div, is_equal, ...
>> *)

Definition lcPred :=
  (** TODO : define pred on Church numerals *)
  "x".

(** only works for CBN! *)
Definition lcY :=
  \"f",
    (\"x", "f" @ ("x" @ "x")) @
    (\"x", "f" @ ("x" @ "x")).

(** <<

Y F
  -->* (\f, (\x, f (x x)) (\x, f (x x))) F
  -->* (\x, F (x x)) (\x, F (x x))
  -->* F ((\x, F (x x)) (\x, F (x x)))
  -->* F (Y F)

>> *)

Definition lcFactAux :=
  \"f", \"n",
  lcCond (lcIsZero @ "n")
         lc1
         (lcMul @ "n" @ ("f" @ (lcPred @ "n"))).

Definition lcFact :=
  lcY @ lcFactAux.

(** <<

lcFact 3 -->* 6

>> *)

Definition lcLet v e1 e2 :=
  (\v, e2) @ e1.


Require Import Omega.
Require Import Cubes.axioms
        Cubes.sprop_utils
        Cubes.arith_lemmas
        Cubes.hott_lemmas
        Cubes.cubes
        Cubes.cubic_dec.

(** Cartesian structure *)

(* based on the decidability part. This actually only requires the category of cubes having contractions *)

Definition fuse_cube_maps {a b c : nat} : (cube a -> cube b) * (cube a -> cube c) -> (cube a -> cube (b + c)).
  intros [f g] d [x p].
  destruct (le_lt_dec b x).
  - assert (x - b < c). apply le_plus_n with (p := b). rewrite add_S.
    rewrite <- Minus.le_plus_minus. exact p. exact l.
    apply (g d). exists (x - b). exact H.
  - apply (f d). exists x. exact l.
Defined.

Theorem fused_monotone {a b c : nat} (f : cube a -> cube b) (g : cube a -> cube c) :
  monotone f -> monotone g -> monotone (fuse_cube_maps (f, g)).
Proof.
  intros Hf Hg d e Hde [x Hx]. simpl.
  destruct (le_lt_dec b x).
  - apply Hg. exact Hde.
  - apply Hf. exact Hde.
Qed.

Definition fuse_arrows {a b c : nat} : (a ~> c) * (b ~> c) -> (a + b ~> c).
  intros [f g].
  refine ( fuse_cube_maps (f.1s, g.1s) ; _ )s.
  pose proof (arrow_monotone f). pose proof (arrow_monotone g).
  assert (admissible' (fuse_cube_maps (f.1s, g.1s))).
  apply adm_if_monotone. now apply fused_monotone.
  destruct H1 as [w H1].
  eapply spair_s. apply eq_eqs. exact H1.
Defined.

Definition split_cube_map {a b c : nat} : (cube a -> cube (b + c)) -> (cube a -> cube b) * (cube a -> cube c).
  intro f. split.
  - intros d [x p]. apply (f d). exists x. omega.
  - intros d [x p]. apply (f d). exists (b + x). unfold lt. rewrite <- add_S.
    apply Plus.plus_le_compat_l. exact p.
Defined.

Theorem splitted_monotone {a b c : nat} (f : cube a -> cube (b + c)) :
  monotone f -> monotone (fst (split_cube_map f)) /\ monotone (snd (split_cube_map f)).
Proof.
  intro Hf. split ; intros d e Hde [x Hx] ; simpl ; apply Hf ; exact Hde.
Qed.

Definition split_arrow {a b c : nat} : (a + b ~> c) -> (a ~> c) * (b ~> c).
  intro f. split.
  - refine ( fst (split_cube_map f.1s) ; _ )s.
    pose proof (arrow_monotone f). destruct (splitted_monotone f.1s H) as [H1 _].
    assert (admissible' (fst (split_cube_map f.1s))). apply adm_if_monotone. exact H1.
    destruct H0 as [w H0]. eapply spair_s. apply eq_eqs. exact H0.
  - refine ( snd (split_cube_map f.1s) ; _ )s.
    pose proof (arrow_monotone f). destruct (splitted_monotone f.1s H) as [_ H1].
    assert (admissible' (snd (split_cube_map f.1s))). apply adm_if_monotone. exact H1.
    destruct H0 as [w H0]. eapply spair_s. apply eq_eqs. exact H0.
Defined.

Theorem cartesian_lemma1 {a b c : nat} : forall f : cube a -> cube (b + c), fuse_cube_maps (split_cube_map f) = f.
  intro f.
  apply funext. intro d.
  apply funext. intros [x p].
  simpl. destruct (le_lt_dec b x).
  - assert (forall p' : b + (x - b) < b + c, exist (fun m : nat => m < b + c) (b + (x - b)) p' = exist (fun m : nat => m < b + c) x p).
    rewrite <- Minus.le_plus_minus. intro p'. rewrite (Peano_dec.le_unique (S x) (b + c) p p'). reflexivity.
    exact l.
    rewrite H. reflexivity.
  - erewrite (Peano_dec.le_unique _ _ _ p). reflexivity.
Qed.

Theorem cartesian_lemma2 {a b c : nat}
  : forall (f : cube a -> cube b) (g : cube a -> cube c), split_cube_map (fuse_cube_maps (f, g)) = (f, g).
  intros f g. apply injective_projections.
  - apply funext. intro d.
    apply funext. intros [x p].
    simpl. destruct (le_lt_dec b x).
    + assert False. omega. inversion H.
    + erewrite (Peano_dec.le_unique _ _ l p). reflexivity.
  - apply funext. intro d.
    apply funext. intros [x p].
    simpl. destruct (le_lt_dec b (b + x)).
    + assert (forall p' : b + x - b < c, exist (fun m : nat => m < c) (b + x - b) p' = exist (fun m : nat => m < c) x p).
      replace (b + x - b) with x. intro p'. erewrite (Peano_dec.le_unique _ _ p p'). reflexivity.
      omega.
      rewrite H. reflexivity.
    + assert False. omega. inversion H.
Qed.

Theorem cartesian_iso1 {a b c : nat} : fuse_arrows o split_arrow = fun x : a + b ~> c => x.
Proof.
  apply funext. intro f. apply eq_sexist.
  Opaque fuse_cube_maps. Opaque split_cube_map. simpl.
  rewrite <- (surjective_pairing (split_cube_map f.1s)).
  apply cartesian_lemma1.
Qed.

Theorem cartesian_iso2 {a b c : nat} : split_arrow o fuse_arrows = fun x : (a ~> c) * (b ~> c) => x.
Proof.
  apply funext. intros [f g]. apply injective_projections.
  - apply eq_sexist. compute.
    pose proof (cartesian_lemma2 f.1s g.1s).
    apply (f_equal fst) in H. exact H.
  - apply eq_sexist. compute.
    pose proof (cartesian_lemma2 f.1s g.1s). apply (f_equal snd) in H. exact H.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Construction.Opposite.

Generalizable All Variables.

Definition Opposite_Functor `(F : C ⟶ D) : C^op ⟶ D^op :=
  @Build_Functor (C^op) (D^op) F
    (λ (x y : C ^op) (f : x ~{ C ^op }~> y), @fmap C D F y x f)
    (λ (x y : C ^op) (f g : x ~{ C ^op }~> y), @fmap_respects _ _ F y x f g)
    (λ x : C ^op, fmap_id)
    (λ (x y z : C ^op) (f : y ~{ C ^op }~> z)
      (g : x ~{ C ^op }~> y), @fmap_comp _ _ F _ _ _ g f).

Notation "F ^op" := (@Opposite_Functor _ _ F)
  (at level 7, format "F ^op", left associativity) : functor_scope.

Open Scope functor_scope.

Corollary Opposite_Functor_invol `{F : C ⟶ D} : (F^op)^op = F.
Proof. reflexivity. Qed.

Definition contramap `{F : C^op ⟶ D} `(f : x ~{C}~> y) :
  F y ~{D}~> F x := fmap (op f).


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Definition relation (A:Type) := A -> A -> Prop.

Definition respectful
{A} (RA:A -> A -> Prop)
{B} (RB:B -> B -> Prop)
(f:A -> B) (g:A -> B) :=
  forall x y, RA x y -> RB (f x) (g y).
Infix "⇉" := respectful (at level 70, right associativity).

(*
Definition logical_intro
{A B} {R1:relation A} {R2:relation B}
{t} `{! Logical A B (t A B) }
{f g:t A B}
(p:forall x y, R1 x y -> R2 (f ⊙ x) (g ⊙ y))
: (R1 ⇉ R2) f g := p.

Definition logical_elim
{A B} (R1:relation A) (R2:relation B)
{t} `{! Logical A B (t A B) }
{f g:t A B} {x y:A}
(p1:R1 x y) (p2:(R1 ⇉ R2) f g) : R2 (f ⊙ x) (g ⊙ y) := p2 _ _ p1.
*)

Definition proper {A} (R:A -> A -> Prop) (x:A) := R x x.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import String.
Require Import Omega.

Require Import Cryptol.Coqlib.

Require Import Cryptol.AST.
Require Import Cryptol.Bitvectors.
Require Import Cryptol.Utils.

Import ListNotations.

(**************** Functions ****************)

(* convert a forced list of bits to a bitvector *)
Fixpoint to_bitv {ws : nat} (l : list strictval) : option (BitV ws) :=
  match l, ws with
  | nil, O => Some (@repr 0 0)
  | (sbit b) :: r, S n =>
    match @to_bitv n r with
    | Some bv => Some (@repr (S n) (unsigned bv + if b then (two_power_nat n) else 0))
    | None => None
    end
  | _,_ => None
  end.

Fixpoint from_bitv' (ws : nat) (n : nat) (bv : BitV ws) : list strictval :=
  match n with
  | O => nil
  | S n' => (sbit (testbit bv (Z.of_nat n')) :: from_bitv' ws n' bv)
  end.

Definition from_bitv {ws : nat} (bv : BitV ws) : list strictval :=
  from_bitv' ws ws bv.

Lemma tobit_length :
  forall l ws bv,
    @to_bitv ws l = Some bv ->
    ws = length l.
Proof.
  induction l; intros.
  unfold to_bitv in *. destruct ws; simpl in H; inv H. reflexivity.
  destruct ws; simpl in H. destruct a; simpl in H; inv H.
  destruct a; simpl in H; try solve [inv H].
  match goal with
  | [ H : context[ match ?X with _ => _ end ] |- _ ] => destruct X eqn:?
  end; inv H.
  eapply IHl in Heqo. simpl. auto.
Qed.

Lemma to_bitv_width_zero : forall l (bv : BitV 0),
  to_bitv l = Some bv -> l = nil.
Proof.
  destruct l; intros.
  - reflexivity.
  - exfalso. inversion H.
    destruct s; try congruence.
Qed.

Lemma intval_width_zero : forall (bv : BitV 0),
  intval bv = 0.
Proof.
  intros. unfold intval. destruct bv. unfold two_power_nat in intrange. simpl in intrange. omega.
Qed.

Lemma frombitv_cons : forall l width length (bv : BitV width),
  from_bitv' width length bv = l ->
    exists a,
    from_bitv' width (S length) bv = (a::l).
Proof.
  intros. simpl. rewrite H. eauto.
Qed.

Lemma frombit_nil : forall ws (bv : BitV ws),
  from_bitv bv = [] -> ws = 0%nat.
Proof.
  intros. unfold from_bitv in H. destruct ws eqn:?; try congruence.
  inversion H.
Qed.

Lemma list_helper : forall {A : Type} (l1 : list A) (l2 : list A) (v v0 : A),
   (l2 ++ v :: nil) ++ v0 :: l1 = l2 ++ (v :: v0 :: l1).
Proof.
  intros. induction l2.
  - simpl. reflexivity.
  - simpl. rewrite IHl2. reflexivity.
Qed.

Lemma lt_irrefl : forall n,
  ~(two_power_nat n < two_power_nat n).
Proof.
  intros. omega.
Qed.

Lemma testbit_power_two : forall n,
  Z.testbit (two_power_nat n) (Z.of_nat n) = true.
Proof.
  intros. rewrite Zsign_bit.
  destruct (zlt (two_power_nat n) (two_power_nat n)) eqn:?.
   - exfalso. clear Heqs.  apply lt_irrefl in l. exact l.
   - reflexivity.
   - generalize (two_power_nat_pos n). intros. split; try omega.
     rewrite two_power_nat_S. omega.
Qed.

Lemma lt_rewrite_larger : forall a b c,
  a < b ->
    b + b < c ->
    a + b < c.
Proof.
  intros. omega.
Qed.

Lemma testbit_single : forall ws l1 (b0 : BitV ws) (b : bool) len (bv : BitV (S ws)),
  len = length l1 ->
  to_bitv l1 = Some b0 ->
  repr (unsigned b0 + (if b then two_power_nat ws else 0)) = bv ->
   testbit bv (Z.of_nat len) = b.
Proof.
  induction ws; intros.
  - unfold two_power_nat in H1. simpl in H1. rewrite <- H1. apply to_bitv_width_zero in H0. subst. simpl. unfold unsigned.
    assert (intval b0 = 0). { apply intval_width_zero. }
    rewrite H. simpl. destruct b; auto.
  - rewrite <- H1. rewrite testbit_repr.
    Focus 2. unfold zwordsize. split. omega.
    apply Nat2Z.inj_lt. apply tobit_length in H0. omega.

    unfold unsigned. destruct b.
    + apply tobit_length in H0. rewrite <- H0 in H. rewrite H. rewrite Zsign_bit. destruct (zlt (intval b0 + two_power_nat (S ws)) (two_power_nat (S ws))) eqn :?.
      * exfalso. clear Heqs. generalize (intrange b0). intros. omega.
      * reflexivity.
      * split.
         -- generalize (intrange b0). intros. omega.
         -- generalize (intrange b0). intros. rewrite 3 two_power_nat_S. rewrite two_power_nat_S in H2. inversion H2. eapply lt_rewrite_larger in H4. omega. instantiate (1:=(2*(2*(2*two_power_nat ws)))). omega.
    + apply tobit_length in H0. rewrite <- H0 in H. rewrite H. rewrite Zsign_bit. destruct (zlt (intval b0 + two_power_nat (S ws)) (two_power_nat (S ws))) eqn :?.
      * exfalso. clear Heqs. generalize (intrange b0). intros. omega.
      * clear Heqs. generalize (intrange b0). intros. destruct (zlt (intval b0 + 0) (two_power_nat (S ws))) eqn:?.
         -- reflexivity.
         -- exfalso. replace (intval b0 + 0) with (intval b0) by omega. omega.
      * split.
         -- generalize (intrange b0). intros. omega.
         -- generalize (intrange b0). intros. replace (intval b0 + 0) with (intval b0) by omega. rewrite two_power_nat_S. omega.
Qed.

Lemma z_two_power_nat :
  forall x,
    2 ^ Z.of_nat x = two_power_nat x.
Proof.
  intros.
  rewrite two_power_nat_correct.
  rewrite Zpower_nat_Z.
  reflexivity.
Qed.

Lemma testbit_widen :
  forall wsbig wssmall zidx bv_z,
    (wsbig >= wssmall)%nat ->
    Z.of_nat wssmall > zidx ->
    testbit (@repr wsbig bv_z) zidx = testbit (@repr wssmall bv_z) zidx.
Proof.
  intros. unfold testbit.
  rewrite unsigned_repr_eq. rewrite unsigned_repr_eq.
  unfold modulus.
  replace (two_power_nat wsbig) with (2 ^ (Z.of_nat wsbig)).

  rewrite Z.mod_pow2_bits_low.
  replace (two_power_nat wssmall) with (2 ^ (Z.of_nat wssmall)).
  rewrite Z.mod_pow2_bits_low.
  reflexivity.
  omega.
  eapply z_two_power_nat; eauto.
  omega.
  eapply z_two_power_nat; eauto.
Qed.

Lemma repr_mod :
  forall {ws} z,
    ws <> O ->
    @repr ws z = @repr ws (z mod (@modulus ws)).
Proof.
  intros. unfold repr.
  eapply unsigned_eq. simpl.
  repeat rewrite Z_mod_modulus_eq by auto.
  rewrite Z.mod_mod. reflexivity. unfold modulus.
  generalize (two_power_nat_pos ws). intros. omega.
Qed.

Lemma testbit_tobitv : forall len ws l1 l2 v (bv : BitV ws),
  len = length l1 ->
    @to_bitv ws (l2 ++ v :: l1) = Some bv ->
    sbit (testbit bv (Z.of_nat len)) = v.
Proof.
  induction ws; intros.
  - inversion H0. destruct l2; simpl in *; try congruence. destruct v; inversion H2. destruct s; try congruence.
  - simpl in H0. destruct l2 eqn:?; simpl in *; try congruence. destruct v eqn:?; simpl in *; try congruence. destruct (to_bitv l1) eqn:?. inversion H0. f_equal. eapply testbit_single.
    + eauto.
    + eauto.
    + reflexivity.
    + inversion H0.
    + remember H as Hlen. clear HeqHlen. destruct s eqn:?; try congruence. destruct (to_bitv (l++v::l1)) eqn :?. eapply IHws in H; eauto.
      * subst. inversion H0. subst.
        clear H0. f_equal.
        erewrite testbit_widen.
        instantiate (1 := ws).

        Focus 3.
        eapply tobit_length in Heqo. rewrite Heqo.
        destruct l; simpl; auto. rewrite Zpos_P_of_succ_nat. omega.
        rewrite Zpos_P_of_succ_nat. rewrite app_length.
        simpl.
        unfold Z.of_nat. destruct (length l + S (length l1))%nat eqn :?. simpl. omega. destruct (length l1) eqn:?. simpl.
        apply Zgt_pos_0.
        rewrite Zpos_P_of_succ_nat. rewrite Zpos_P_of_succ_nat.  omega.

        Focus 2. omega.

        rewrite repr_mod.
        replace ((unsigned b0 + (if b then two_power_nat ws else 0)) mod modulus) with (unsigned b0).
        rewrite repr_unsigned. reflexivity.
        unfold modulus. destruct b.

        rewrite Zplus_mod. rewrite Z_mod_same_full. rewrite Zmod_small. rewrite Zmod_small. omega.

        unfold unsigned. generalize (intrange b0). intros. omega.
        rewrite Zmod_small. generalize (intrange b0). intros.
        assert (unsigned b0 + 0 = unsigned b0) by omega. rewrite H0.
        unfold unsigned. omega.
        unfold unsigned. generalize (intrange b0). intros. omega.
        assert (unsigned b0 + 0 = unsigned b0) by omega. rewrite H. rewrite Zmod_small. reflexivity.
        generalize (intrange b0). unfold unsigned. intros. omega.

        destruct ws.
        apply tobit_length in Heqo. symmetry in Heqo. rewrite length_zero_iff_nil in Heqo. destruct l. simpl in Heqo. inversion Heqo. inversion Heqo.

        auto.

      * congruence.
Qed.

Lemma tobit_frombit' :
  forall len v l1 l2 width (bv : BitV width),
    (width >= len)%nat ->
    to_bitv (l2++v::l1) = Some bv ->
    length l1 = len ->
    from_bitv' width len bv = l1.
Proof.
  induction len; intros.
  - simpl. apply length_zero_iff_nil in H1. auto.
  - destruct l1. inversion H1. simpl. f_equal. clear -H0 H1. destruct width.
    + inversion H1. eapply testbit_tobitv. instantiate (1:=l1). reflexivity. instantiate (1:=(l2++(cons v nil))). rewrite list_helper. assumption.
    + inversion H1. eapply testbit_tobitv. instantiate (1:=l1). reflexivity. instantiate (1:=(l2++(cons v nil))). rewrite list_helper. assumption.
    + eapply IHlen.
      * omega.
      * instantiate (1:=s). instantiate (1:=l2++(cons v nil)). rewrite list_helper. assumption.
      * inversion H1. reflexivity.
Qed.

Lemma tobit_frombit : forall l ws (bv : BitV ws),
  to_bitv l = Some bv -> from_bitv bv = l.
Proof.
  intros. destruct l.
  - apply tobit_length in H. simpl in H. destruct ws.
     + unfold from_bitv. simpl. reflexivity.
     + inversion H.
  - unfold from_bitv. destruct ws.
    + inversion H. destruct s; congruence.
    + simpl.
      assert (Datatypes.length l = ws). {
        eapply tobit_length in H.
        simpl in H. inversion H. auto.
      }
      erewrite tobit_frombit'; try solve [eauto].
      f_equal.
      eapply testbit_tobitv; eauto.
      instantiate (1 := nil). assumption.
      instantiate (2 := nil).
      eapply H.
Qed.

Lemma from_bitv'_widen :
  forall ws ws',
    (ws' >= ws)%nat ->
    forall bv,
      from_bitv' ws' ws (@repr ws' bv) = from_bitv' ws ws (@repr ws bv).
Proof.
  induction ws; intros.
  simpl. reflexivity.
  simpl. f_equal.
  repeat erewrite testbit_repr; eauto;
    unfold zwordsize.
  split. omega.
  eapply inj_lt. omega.
  split. omega.
  eapply inj_lt. omega.
  assert (S ws >= ws)%nat by omega.
  erewrite (IHws _ H0).
  eapply IHws; eauto. omega.
Qed.

Lemma Some_eq :
  forall {A} (x y : A),
    x = y ->
    Some x = Some y.
Proof.
  congruence.
Qed.

Definition Z_nat_ind
    (P : Z -> Prop)
    (Hbase : P 0)
    (Hneg : forall x, x < 0 -> P x)
    (Hpos : forall x, x >= 0 -> P x -> P (Z.succ x))
    (z : Z)
  : P z.
Proof.
  assert (z < 0 \/ z >= 0) by omega.
  destruct H. eauto.
  eapply natlike_ind; intros; eauto.
  eapply Hpos; auto; omega.
  omega.
Defined.

Lemma Z_add_bit_n :
  forall n a b,
    Z.testbit (a + b) n = xorb (Z.testbit a n) (Z.testbit b n).
Proof.
  induction n using Z_nat_ind; intros.
  repeat rewrite Ztestbit_base.
  eapply Z.odd_add.

  repeat rewrite Z.testbit_neg_r; eauto.
  replace (Z.succ n) with (n + 1) by omega.
  rewrite <- Z.shiftr_spec by omega.

  (* This is a true property, which might take a bit of work to prove, but is necessary for the proof below *)

Admitted.

Lemma frombit_tobit : forall l ws (bv : BitV ws),
  from_bitv bv = l -> to_bitv l = Some bv.
Proof.
  induction l; intros.
  - apply frombit_nil in H. subst. simpl. generalize (intval_width_zero).
    intros. f_equal. eapply f_equal. apply unsigned_eq. simpl. unfold unsigned. rewrite H. reflexivity.
  - unfold from_bitv in H. unfold from_bitv in IHl. destruct ws.
    + inversion H.
    + simpl in H. inversion H.
      destruct bv. replace ({| intval := intval; intrange := intrange |}) with (@repr (S ws) intval) in *.
      erewrite (from_bitv'_widen ws (S ws)) in * by omega.
      simpl.
      subst l. specialize (IHl _ _ eq_refl).
      rewrite IHl.
      simpl.
      eapply Some_eq.
      eapply same_bits_eq. intros.
      destruct ws.
      unfold two_power_nat in intrange. simpl in intrange.
      assert (intval = 0 \/ intval = 1) by omega.
      unfold zwordsize in H0.
      simpl in H0.
      assert (i = 0) by omega. subst i.
      simpl.
      destruct H2; subst; simpl; auto.
      rewrite Z_mod_modulus_eq by congruence.
      unfold modulus.
      unfold testbit.
      repeat rewrite unsigned_repr_eq.
      unfold modulus.
      repeat rewrite two_power_nat_equiv.
      unfold zwordsize in *.
      repeat rewrite Z.mod_pow2_bits_low; try omega; try (eapply inj_lt; omega).
      erewrite Z_add_bit_n.
      assert (i = Z.of_nat (S ws) \/ i < Z.of_nat (S ws)). {
        destruct H0.
        repeat rewrite Nat2Z.inj_succ in *.
        omega.
      }
      destruct H2.
      subst i. rewrite Z.mod_pow2_bits_high by omega.
      rewrite xorb_false_l.
      destruct (Z.testbit intval (Z.of_nat (S ws))).
      eapply Z.pow2_bits_true; eauto. omega.
      eapply Z.testbit_0_l.
      repeat rewrite Z.mod_pow2_bits_low; try omega; try (eapply inj_lt; omega).
      destruct (Z.testbit intval i);
        try rewrite xorb_true_l;
        try rewrite negb_true_iff;
        try rewrite xorb_false_l;
        try rewrite negb_false_iff;
      destruct (Z.testbit intval (Z.of_nat (S ws)));
        try solve [rewrite Z.pow2_bits_false; eauto; omega];
        eapply Z.testbit_0_l.

      unfold repr.
      eapply unsigned_eq. simpl.
      rewrite Z_mod_modulus_eq by congruence.
      unfold modulus.
      rewrite Zmod_small; auto. omega.
Qed.

(* Main theorem *)
Theorem tobit_frombit_equiv : forall l ws (bv : BitV ws),
  to_bitv l = Some bv <-> from_bitv bv = l.
Proof.
  intros. split.
  apply tobit_frombit.
  apply frombit_tobit.
Qed.


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

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

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

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.ProductMetric.
Require Import CoRN.reals.fast.CRArith.
Require Import Coq.QArith.Qpower.
Require Import Coq.QArith.Qabs.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.additional_operations.

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

Local Open Scope Q_scope.
Local Open Scope uc_scope.

(**
** Natural Integer Powers
Positive integer powers is faster than repeated multiplication.

It is uniformly continuous on an interval [[-c,c]].
*)

(* We first define repeated multiplication to prove correctness. *)
Fixpoint CRpower_slow (x : CR) (n : nat) { struct n }
  := match n with
     | O => 1%CR
     | S p => (x * CRpower_slow x p)%CR
     end.

Lemma CRpower_slow_wd : forall (x y : CR) (n : nat),
    msp_eq x y -> msp_eq (CRpower_slow x n) (CRpower_slow y n).
Proof.
  induction n.
  - intros. reflexivity.
  - intros. simpl (CRpower_slow x (S n)).
    rewrite (IHn H). rewrite H. reflexivity.
Qed.

Lemma Qpower_positive_abs_le : forall (q:Q) (c : Qpos) (n : positive),
    Qabs q <= `c
    -> Qabs (Qpower_positive q n) <= Qpower_positive (` c) n.
Proof.
  intros q c.
  induction n.
  - intros. simpl (Qpower_positive q n~1).
    rewrite Qabs_Qmult.
    simpl (Qpower_positive (` c) n~1).
    apply (Qle_trans _ (`c * Qabs (Qpower_positive q n * Qpower_positive q n))).
    apply Qmult_le_compat_r. exact H.
    apply Qabs_nonneg. apply Qmult_le_l.
    apply Qpos_ispos.
    rewrite Qabs_Qmult.
    apply (Qle_trans _ (Qpower_positive (`c) n * Qabs (Qpower_positive q n))).
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qabs_nonneg.
    rewrite Qmult_comm.
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qpower_pos_positive, Qpos_nonneg.
  - intros. simpl (Qpower_positive q n~0).
    rewrite Qabs_Qmult. simpl.
    apply (Qle_trans _ (Qpower_positive (`c) n * Qabs (Qpower_positive q n))).
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qabs_nonneg.
    rewrite Qmult_comm.
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qpower_pos_positive, Qpos_nonneg.
  - intros. exact H.
Qed.

 (* The derivative of fun z => z^p is fun z => p * z^(p-1)
   which is bounded by p*c^(p-1) on [-c,c]. *)
Lemma Qdiff_power : forall (n : nat) (x y : Q) (c : Qpos),
    (-`c <= x <= `c)
    -> (-`c <= y <= `c)
    -> Qabs (x^Z.of_nat n - y^Z.of_nat n)
      <= Qabs(x-y) * (Z.of_nat n#1) * (`c) ^ (Z.pred (Z.of_nat n)).
Proof.
  induction n.
  - intros. apply Qmult_le_0_compat.
    apply Qmult_le_0_compat. apply Qabs_nonneg.
    discriminate. apply (Qpos_nonneg (Qpos_power c (Z.pred (Z.of_nat 0)))).
  - intros. change (S n) with (1 + n)%nat.
    rewrite Nat2Z.inj_add, Qpower_plus', Qpower_plus'.
    simpl (x ^ Z.of_nat 1).
    simpl (y ^ Z.of_nat 1).
    setoid_replace (x * x ^ Z.of_nat n - y * y ^ Z.of_nat n)%Q
      with ((x-y)*x ^ Z.of_nat n + y * (x ^ Z.of_nat n - y ^ Z.of_nat n))%Q
      by (unfold equiv, stdlib_rationals.Q_eq; ring).
    apply (Qle_trans _ _ _ (Qabs_triangle _ _)).
    rewrite Qabs_Qmult, Qabs_Qmult.
    apply (Qle_trans _ (Qabs (x-y) * (`c) ^ Z.of_nat n
             + Qabs (x - y) * (Z.of_nat n # 1) * ` c ^ Z.pred (Z.of_nat n) * Qabs y)).
    apply Qplus_le_compat.
    + rewrite Qmult_comm, (Qmult_comm (Qabs (x-y))).
      apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
      destruct n. apply Qle_refl.
      apply Qpower_positive_abs_le.
      apply AbsSmall_Qabs, H.
    + rewrite Qmult_comm. apply Qmult_le_compat_r.
      2: apply Qabs_nonneg. apply IHn. exact H. exact H0.
    + clear IHn.
      rewrite <- Qmult_assoc, <- Qmult_assoc, <- Qmult_plus_distr_r.
      rewrite Qmult_comm, <- Qmult_assoc, (Qmult_comm (Qabs (x-y))).
      apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
      apply (Qle_trans _ (` c ^ Z.of_nat n + (Z.of_nat n # 1) * (` c ^ (Z.of_nat n)))).
      apply Qplus_le_r.
      rewrite Qmult_comm, (Qmult_comm (Z.of_nat n # 1)).
      apply Qmult_le_compat_r.
      apply (Qle_trans _ (`c ^ Z.of_nat 1 * ` c ^ Z.pred (Z.of_nat n))).
      rewrite Qmult_comm. apply Qmult_le_compat_r.
      simpl. apply AbsSmall_Qabs. exact H0.
      apply Qpower_pos. apply Qpos_nonneg.
      rewrite <- Qpower_plus. 2: apply Qpos_nonzero.
      replace (Z.of_nat 1 + Z.pred (Z.of_nat n))%Z with (Z.of_nat n).
      apply Qle_refl.
      rewrite Z.add_1_l. rewrite Z.succ_pred. reflexivity.
      unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg.
      rewrite <- (Qmult_1_l (` c ^ Z.of_nat n)) at 1.
      rewrite <- Qmult_plus_distr_l.
      setoid_replace (1 + (Z.of_nat n # 1)) with (Z.of_nat 1 + Z.of_nat n#1).
      rewrite Qmult_comm.
      rewrite (Qmult_comm (Z.of_nat 1 + Z.of_nat n#1)).
      apply Qmult_le_compat_r.
      replace (Z.pred (Z.of_nat 1 + Z.of_nat n)) with (Z.of_nat n).
      apply Qle_refl.
      rewrite <- Nat2Z.inj_add. rewrite Nat2Z.inj_succ.
      rewrite <- Zpred_succ. reflexivity.
      rewrite <- Nat2Z.inj_add. discriminate.
      unfold equiv, stdlib_rationals.Q_eq, Qeq, Qplus, Qnum, Qden.
      simpl (1*1)%Z. rewrite Z.mul_1_r, Z.mul_1_r.
      simpl (1*1)%positive. rewrite Z.mul_1_r. reflexivity.
    + rewrite <- Nat2Z.inj_add. discriminate.
    + rewrite <- Nat2Z.inj_add. discriminate.
Qed.

Section CRpower_N.

Variable n : N. (* Binary integers are faster than unary integers *)

(* To compute x^n, we bound x by c and the modulus becomes
   fun e => e / (n * c^(n-1)) *)
Definition Qpower_N_modulus (c:Qpos) (e:Qpos) : QposInf :=
  match n with
  | N0 => QposInfinity
  | Npos p => Qpos2QposInf (e* Qpos_inv ((p#1)*Qpos_power c (Z.pred (Zpos p))))
  end.

Lemma Qpower_N_uc_prf (c:Qpos) :
  @is_UniformlyContinuousFunction
    Q_as_MetricSpace Q_as_MetricSpace
    (fun x => Qpower (QboundAbs c x) (Z_of_N n)) (Qpower_N_modulus c).
Proof.
 unfold Qpower_N_modulus.
 destruct n as [|p].
 - simpl. intros e x y E. apply ball_refl, Qpos_nonneg.
 - clear n. intros e x y E. unfold ball_ex in E.
   simpl (Z.of_N (N.pos p)).
   apply AbsSmall_Qabs.
   apply AbsSmall_Qabs in E.
   assert (-` c <= QboundAbs c x ∧ QboundAbs c x <= ` c).
   { split. apply Qmax_ub_l.
     apply Qmax_lub.
     apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
     apply Qpos_nonneg. apply Qmin_lb_l. }
   assert (- ` c <= QboundAbs c y ∧ QboundAbs c y <= ` c).
   { split. apply Qmax_ub_l.
     apply Qmax_lub.
     apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
     apply Qpos_nonneg. apply Qmin_lb_l. }
   pose proof (positive_nat_Z p).
   rewrite <- H1.
   apply (Qle_trans _ _ _ (Qdiff_power (Pos.to_nat p) _ _ c H H0)).
   clear H H0.
   rewrite <- Qmult_assoc.
   apply (Qle_trans _ (Qabs (x-y) * ((Z.pos p # 1) * ` c ^ Z.pred (Z.pos p)))).
   rewrite H1.
   apply Qmult_le_compat_r.
   apply QboundAbs_contract.
   apply (Qpos_nonneg ((p#1) * Qpos_power c (Z.pred (Z.pos p)))).
   apply (Qle_trans _ (`e * / proj1_sig ((Z.pos p # 1)%Q ↾ eq_refl * Qpos_power c (Z.pred (Z.pos p)))%Qpos * ((Z.pos p # 1) * ` c ^ Z.pred (Z.pos p)))).
   apply Qmult_le_compat_r.
   apply E.
   apply (Qpos_nonneg ((p#1) * Qpos_power c (Z.pred (Z.pos p)))).
   rewrite Qmult_comm, Qmult_assoc.
   apply Qle_shift_div_r.
   apply (Qpos_ispos ((p#1) * Qpos_power c (Z.pred (Z.pos p)))).
   rewrite Qmult_comm. apply Qle_refl.
Qed.

Definition Qpower_N_uc (c:Qpos) :  Q_as_MetricSpace --> Q_as_MetricSpace :=
Build_UniformlyContinuousFunction (Qpower_N_uc_prf c).

(** CRpower_positive_bounded works on [[-c,c]]. *)
Definition CRpower_N_bounded (c:Qpos) : CR --> CR :=
Cmap QPrelengthSpace (Qpower_N_uc c).

End CRpower_N.

Lemma Cmap_wd_bounded
  : forall (Y : MetricSpace)
      (f g : Q_as_MetricSpace --> Y) (x : CR) (c : Qpos),
    (forall q:Q, -`c <= q <= `c -> msp_eq (f q) (g q))
    -> (- ' (proj1_sig c) <= x /\ x <= ' (proj1_sig c))%CR
    -> msp_eq (Cmap_fun QPrelengthSpace f x) (Cmap_fun QPrelengthSpace g x).
Proof.
  intros.
  setoid_replace x with (CRboundAbs c x).
  2: symmetry; apply CRboundAbs_Eq; apply H0.
  pose (fun e => QposInf_min (mu f e) (mu g e)) as mufg.
  assert (∀ e : Qpos, QposInf_le (mufg e) (mu f e)).
  { intro e. unfold QposInf_le, mufg.
    destruct (mu f e). 2: trivial.
    simpl. destruct (mu g e). 2: apply Qle_refl.
    apply Qpos_min_lb_l. }
  pose proof (uc_prf_smaller f mufg H1). clear H1.
  setoid_replace f with (Build_UniformlyContinuousFunction H2).
  2: apply ucEq_equiv; intro q; reflexivity.
  assert (∀ e : Qpos, QposInf_le (mufg e) (mu g e)).
  { intro e. unfold QposInf_le, mufg.
    destruct (mu g e). 2: trivial.
    simpl. destruct (mu f e). 2: apply Qle_refl.
    apply Qpos_min_lb_r. }
  pose proof (uc_prf_smaller g mufg H1). clear H1.
  setoid_replace g with (Build_UniformlyContinuousFunction H3).
  2: apply ucEq_equiv; intro q; reflexivity.
  intros e1 e2.
  assert (forall y, eq (QposInf_bind (fun e : Qpos => e) y) y) as elim_bind.
  { intro y. destruct y; reflexivity. }
  simpl.
  rewrite elim_bind, elim_bind. clear elim_bind.
  assert (forall a, Qmax (- ` c) (Qmin (` c) a) <= ` c).
  { intro a. apply Qmax_lub.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    apply Qpos_nonneg. apply Qmin_lb_l. }
  rewrite Qplus_0_r.
  destruct (mufg e1) as [q|] eqn:des.
  - rewrite H.
    apply (mu_sum QPrelengthSpace e2 (cons e1 nil)
                  (Build_UniformlyContinuousFunction H3)).
    simpl. rewrite des. simpl. destruct (mufg e2) eqn:des2.
    simpl. apply AbsSmall_Qabs.
    apply (Qle_trans _ (Qabs (approximate x q - approximate x q0))).
    apply QboundAbs_contract.
    apply AbsSmall_Qabs. apply (regFun_prf x).
    simpl. trivial.
    split. apply Qmax_ub_l. apply H1.
  - rewrite <- H.
    apply (mu_sum QPrelengthSpace e2 (cons e1 nil) f).
    simpl. unfold mufg in des.
    destruct (mu f e1) as [q|]. exfalso.
    simpl in des. destruct (mu g e1); inversion des.
    simpl. trivial.
    split. apply Qmax_ub_l. apply H1.
Qed.

Lemma CRpower_N_bounded_step : forall (n:N) (c:Qpos) (x : CR),
    (forall e, - (proj1_sig c) <= approximate x e)
    -> (forall e, approximate x e <= proj1_sig c)
    -> (CRpower_N_bounded (1+n) c x
       == x * CRpower_N_bounded n c x)%CR.
Proof.
  assert (forall i j : Q, i<=j -> Qmax i j == j)%Q as elim_max.
  { intros. apply (Qle_max_r i j), H. }
  assert (forall i j : Q, j<=i -> Qmin i j == j)%Q as elim_min.
  { intros. apply (Qle_min_r i j), H. }
  intros.
  assert (x <= ' ` c)%CR as xupper.
  { intro e. simpl. unfold Cap_raw. simpl.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    rewrite <- Qle_minus_iff. apply H0. }
  assert (- ' ` c <= x)%CR as xlower.
  { intro e. simpl. unfold Cap_raw. simpl.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    rewrite <- Qle_minus_iff. apply H. }
  destruct n as [|n].
  - setoid_replace (CRpower_N_bounded 0 c x) with 1%CR.
    2: intros e1 e2; apply Qball_Reflexive; rewrite Qplus_0_r; apply (Qpos_nonneg (e1+e2)).
    rewrite CRmult_1_r. simpl (1+0)%N.
    intros e1 e2. simpl.
    rewrite Qplus_0_r.
    rewrite elim_min. 2: apply H0.
    rewrite elim_max. 2: apply H.
    setoid_replace (` e1 + ` e2)%Q
      with (` (e1 * Qpos_inv (1 ↾ eq_refl * Qpos_power c 0))%Qpos + ` e2).
    apply (regFun_prf x).
    apply Qplus_comp. 2: reflexivity.
    simpl. change (/ (1*1)) with 1.
    rewrite Qmult_1_r. reflexivity.
  - rewrite CRmult_comm.
    pose (Qpos_max c (Qpos_power c (Z_of_N (N.pos n)))) as b.
    rewrite <- (CRmult_bounded_mult c).
    2: exact xlower. 2: exact xupper.
    rewrite (CRmult_bounded_weaken c b).
    2: exact xlower. 2: exact xupper. 2: apply Qpos_max_ub_l.
    rewrite (CRmult_uncurry_eq b).
    unfold CRpower_N_bounded.
    transitivity (Cmap QPrelengthSpace
                       (uc_compose (Qmult_uncurry b)
                                   (uc_compose (together (Qpower_N_uc (N.pos n) c)
                                                        (uc_id Q_as_MetricSpace))
                                               (diag Q_as_MetricSpace)))
                       x).
    + apply Cmap_wd_bounded with (c:=c).
      intros q H1. destruct H1.
      apply Qball_0.
      change (Qpower_positive (Qmax (- ` c) (Qmin (` c) q)) (1+n)
              ==
  Qmax (- ` b) (Qmin (` b) (Qpower_positive (Qmax (- ` c) (Qmin (` c) q)) n)) *
  Qmax (- ` b) (Qmin (` b) q)).
      rewrite (elim_min _ q). 2: exact H2.
      rewrite (elim_max _ q). 2: exact H1.
      2: exact (conj xlower xupper).
      rewrite (elim_min _ q).
      rewrite (elim_max _ q).
      rewrite Qpower_plus_positive. simpl.
      rewrite Qmult_comm. apply Qmult_comp. 2: reflexivity.
      assert (Qabs q <= `c).
      { apply AbsSmall_Qabs. split. exact H1. exact H2. }
      pose proof (Qpower_positive_abs_le q c n H3). clear H3.
      apply AbsSmall_Qabs in H4. destruct H4.
      rewrite elim_min, elim_max. reflexivity.
      apply (Qle_trans _ (-(Qpower_positive (`c) n))).
      apply Qopp_le_compat.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
      exact H3.
      apply (Qle_trans _ (Qpower_positive (`c) n)).
      exact H4.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
      apply (Qle_trans _ (-`c)). apply Qopp_le_compat, Qpos_max_ub_l.
      exact H1.
      apply (Qle_trans _ (`c)). apply H2. apply Qpos_max_ub_l.
    + rewrite (fast_MonadLaw2 QPrelengthSpace
                              (ProductMS_prelength QPrelengthSpace QPrelengthSpace)).
      apply Cmap_wd. apply ucEq_equiv. intro a; reflexivity.
      intros e1 e2. split.
      rewrite Qplus_0_r.
      apply (mu_sum QPrelengthSpace e2 (cons e1 nil) (Qpower_N_uc (N.pos n) c)).
      apply (@ball_weak_le Q_as_MetricSpace
            (proj1_sig (Qpos_min
                   (e1 *
                    Qpos_inv
                      ((n # 1) *
                       Qpos_power c (Z.pred (Zpos n)) )) e1
             + (e2 *
                    Qpos_inv
                      ((n # 1) *
                       Qpos_power c (Z.pred (Zpos n)) )))%Qpos)).
      apply Qplus_le_l.
      apply Qpos_min_lb_l.
      apply (regFun_prf x).
      apply (@ball_weak_le Q_as_MetricSpace
            (proj1_sig (Qpos_min
                   (e1 *
                    Qpos_inv
                      ((n # 1) *
                       Qpos_power c (Z.pred (Zpos n)) )) e1
             + e2)%Qpos)).
      apply Qplus_le_l.
      rewrite Qplus_0_r.
      apply Qpos_min_lb_r.
      apply (regFun_prf x).
    + intro e. simpl.
      unfold Cap_raw; simpl.
      apply (Qle_trans _ 0).
      apply (Qopp_le_compat 0), Qpos_nonneg.
      rewrite <- Qle_minus_iff.
      apply (Qle_trans _ (-Qpower_positive (` c) n)).
      apply Qopp_le_compat.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
      assert (forall i j :Q, -j <= i -> -i <= j).
      { intros. rewrite <- (Qopp_involutive j).
        apply Qopp_le_compat, H1. }
      apply H1. clear H1.
      apply (Qle_trans _ _ _ (Qle_Qabs _)).
      rewrite Qabs_opp.
      apply (Qpower_positive_abs_le
                    (Qmax (- ` c)
                          (Qmin (` c)
          (approximate x
             ((1 # 2) * e *
              Qpos_inv
                ((n # 1) *
                 Qpos_power c
                            (Z.pred (Zpos n)) ))%Qpos))) c n).
      apply AbsSmall_Qabs. split. apply Qmax_ub_l.
      apply Qmax_lub.
      apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
      apply Qpos_nonneg. apply Qmin_lb_l.
    + intro e. simpl.
      unfold Cap_raw; simpl.
      apply (Qle_trans _ 0).
      apply (Qopp_le_compat 0), Qpos_nonneg.
      rewrite <- Qle_minus_iff.
      apply (Qle_trans _ _ _ (Qle_Qabs _)).
      apply (Qle_trans _ (Qpower_positive (` c) n)).
      apply (Qpower_positive_abs_le
                    (Qmax (- ` c)
                          (Qmin (` c)
          (approximate x
             ((1 # 2) * e *
              Qpos_inv
                ((n # 1) *
                 Qpos_power c
                            (Z.pred (Zpos n)) ))%Qpos))) c n).
      apply AbsSmall_Qabs. split. apply Qmax_ub_l.
      apply Qmax_lub.
      apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
      apply Qpos_nonneg. apply Qmin_lb_l.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
Qed.

Lemma CRpower_N_bounded_correct : forall (n:N) (c:Qpos) (x : CR),
    (- (' (proj1_sig c)) <= x /\ x <= 'proj1_sig c)%CR
    -> (CRpower_slow x (N.to_nat n) == CRpower_N_bounded n c x)%CR.
Proof.
  assert (∀ (n : nat) (c : Qpos) (x : CR),
    (forall e, - (proj1_sig c) <= approximate x e)
    -> (forall e, approximate x e <= proj1_sig c)
    → msp_eq (CRpower_slow x n) (CRpower_N_bounded (N.of_nat n) c x)).
  induction n.
  - intros. intros e1 e2. simpl. apply Qball_Reflexive.
    rewrite Qplus_0_r.
    apply (Qpos_nonneg (e1+e2)).
  - intros. change (S n) with (1+n)%nat.
    rewrite Nnat.Nat2N.inj_add.
    change (N.of_nat 1) with 1%N.
    rewrite CRpower_N_bounded_step. 2: exact H.
    change (CRpower_slow x (1 + n)) with (x * CRpower_slow x n)%CR.
    apply CRmult_wd. reflexivity. apply IHn. exact H.
    exact H0. exact H0.
  - intros.
    transitivity (CRpower_N_bounded (N.of_nat (N.to_nat n)) c x).
    2: rewrite Nnat.N2Nat.id; reflexivity.
    transitivity (CRpower_N_bounded (N.of_nat (N.to_nat n)) c (CRboundAbs c x)).
    transitivity (CRpower_slow (CRboundAbs c x) (N.to_nat n)).
    apply CRpower_slow_wd. symmetry.
    apply CRboundAbs_Eq. apply H0. apply H0.
    apply H. intro e. simpl. apply Qmax_ub_l.
    intros e. apply Qmax_lub.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    apply Qpos_nonneg. apply Qmin_lb_l.
    apply Cmap_wd. apply ucEq_equiv; intro a; reflexivity.
    apply CRboundAbs_Eq. apply H0. apply H0.
Qed.

Lemma CRpower_N_bounded_weaken : forall (n:N) (c1 c2:Qpos) x,
    ((- (' (proj1_sig c1)) <= x /\ x <= 'proj1_sig c1)
     -> (proj1_sig c1 <= proj1_sig c2)%Q ->
     CRpower_N_bounded n c1 x == CRpower_N_bounded n c2 x)%CR.
Proof.
 intros n c1 c2 x Hx Hc.
 simpl in x.
 rewrite <- CRpower_N_bounded_correct.
 rewrite <- CRpower_N_bounded_correct.
 reflexivity. 2: exact Hx. destruct Hx.
 split.
 - apply (@CRle_trans _ (-'(proj1_sig c1))%CR).
   apply CRopp_le_compat, CRle_Qle, Hc. exact H.
 - apply (CRle_trans H0). apply CRle_Qle, Hc.
Qed.

(** [CRpower_positive_bounded] is should be used when a known bound
on the absolute value of x is available. *)
#[global]
Instance CRpower_N: Pow CR N := λ x n, ucFun (CRpower_N_bounded n (CR_b (1#1) x)) x.
Arguments CRpower_N x%type n%N.

Lemma CRpower_N_bounded_N_power : forall (n : N) (c:Qpos) (x:CR),
((- (' (proj1_sig c)) <= x /\ x <= 'proj1_sig c) ->
CRpower_N_bounded n c x == CRpower_N x n)%CR.
Proof.
 intros n c x Hc.
 assert (- ('proj1_sig (CR_b (1#1) x)) <= x
         /\ x <= ('proj1_sig (CR_b (1#1) x)))%CR as Hx.
 { split.
   rewrite -> CRopp_Qopp.
   apply CR_b_lowerBound.
  apply CR_b_upperBound. }
 unfold CRpower_N.
 generalize (CR_b (1#1) x) Hx.
 clear Hx.
 intros d Hd.
 destruct (Qlt_le_dec (proj1_sig c) (proj1_sig d)).
 apply CRpower_N_bounded_weaken. exact Hc. apply Qlt_le_weak, q.
 symmetry. apply CRpower_N_bounded_weaken; assumption.
Qed.

Lemma CRpower_N_correct : forall (n:N) x,
    (CRpower_slow x (N.to_nat n) == CRpower_N x n)%CR.
Proof.
 intros n x.
 rewrite <- (CRpower_N_bounded_N_power n (CR_b (1#1) x)).
 apply CRpower_N_bounded_correct.
 split. apply (CR_b_lowerBound (1#1) x).
 apply CR_b_upperBound.
 split. apply (CR_b_lowerBound (1#1) x).
 apply CR_b_upperBound.
Qed.

Lemma CRpower_N_correct' : forall (n:nat) x,
    (CRpower_slow x n == CRpower_N x (N_of_nat n))%CR.
Proof.
 intros n x.
 etransitivity; [| apply CRpower_N_correct].
 now rewrite Nnat.nat_of_N_of_nat.
Qed.

#[global]
Hint Rewrite CRpower_N_correct' : IRtoCR.

#[global]
Instance: Proper (eq ==> QposEq ==> @msp_eq _) Qpower_N_uc.
Proof.
  intros p1 p2 Ep e1 e2 Ee. apply ucEq_equiv.
  intro x.
  apply ball_closed.
  intros e epos.
  simpl. unfold QposEq in Ee.
  rewrite Ep, Ee.
  apply Qball_Reflexive.
  rewrite Qplus_0_l.
  apply Qlt_le_weak, epos.
Qed.

#[global]
Instance: Proper (eq ==> QposEq ==> @msp_eq _) CRpower_N_bounded.
Proof.
  intros p1 p2 Ep e1 e2 Ee.
  apply ucEq_equiv.
  intro x. simpl. rewrite Ep, Ee. reflexivity.
Qed.

#[global]
Instance: Proper (@msp_eq _ ==> eq ==> @msp_eq _) CRpower_N.
Proof.
 intros x1 x2 Hx ? n Hn. subst.
 transitivity (CRpower_N_bounded n (CR_b (1 # 1) x1) x2).
  change (ucFun (CRpower_N_bounded n (CR_b (1#1) x1)) x1==ucFun (CRpower_N_bounded n (CR_b (1#1) x1)) x2)%CR.
  apply uc_wd; assumption.
 apply CRpower_N_bounded_N_power.
 split; rewrite <- Hx.
  rewrite -> CRopp_Qopp.
  apply CR_b_lowerBound.
 apply CR_b_upperBound.
Qed.
(* end hide *)

#[global]
Instance: NatPowSpec CR N _.
Proof.
  split; unfold pow.
    apply _.
   intros x. change (cast Q CR 1 = CR1). now apply rings.preserves_1.
  intros x n.
  rewrite <- CRpower_N_correct.
  rewrite Nnat.nat_of_Nplus.
  simpl.
  rewrite CRpower_N_correct. reflexivity.
Qed.


From ExtLib.Structures Require Export
     Monads.
From ExtLib.Structures Require Import
     Functor Applicative.
Require Import List.
Import ListNotations.

From QuickChick Require Import Tactics.

Import MonadNotation.
Open Scope monad_scope.

Set Bullet Behavior "Strict Subproofs".

(* A lazy list *)
(* Laziness is implemented by just thunking the computation for the tail
   of a cons-cell. Since each such tail is used exactly once, there is no
   point in using ocaml's 'lazy' that memoizes computation and results in
   unnecessary overheads.
 *)
Inductive LazyList (A : Type) : Type :=
| lnil : LazyList A
| lcons : A -> (unit -> (LazyList A)) -> LazyList A.

Arguments lnil {A}.
Arguments lcons {A} _ _.

Fixpoint lazy_append {A : Type} (l1 : LazyList A) (l2 : LazyList A) : LazyList A :=
  match l1 with
  | lnil => l2
  | lcons x l1' => lcons x (fun _ => (lazy_append (l1' tt) l2))
  end.

Fixpoint lazy_append' {A : Type} (l1 : LazyList A) (l2 : unit -> LazyList A) : LazyList A :=
  match l1 with
  | lnil => l2 tt

(*
    match l2 tt with
    | lnil => lsing x
    | l2' => lcons x (fun _ => l2')
    end
*)
  | lcons x l1' => lcons x (fun _ => (lazy_append' (l1' tt) l2))
  end.

Fixpoint lazy_take {A : Type} (n : nat) (l : LazyList A) : LazyList A :=
  match n with
  | 0 => lnil
  | S n' => match l with
            | lnil => lnil
            | lcons h ts => lcons h (fun _ => (lazy_take n' (ts tt)))
            end
  end.

(* Functor instace for LazyList *)
Fixpoint mapLazyList {A B : Type} (f : A -> B) (l : LazyList A) : LazyList B :=
  match l with
  | lnil => lnil
  | lcons x l' => lcons (f x) (fun _ => (mapLazyList f (l' tt)))
  end.

#[global] Instance FunctorLazyList : Functor LazyList :=
  {
    fmap := @mapLazyList
  }.

(* Monad and applicative instances for LazyList *)
(* Injecting into a monad must crucially use the singleton constructor. *)
Definition retLazyList {A : Type} (a : A) : LazyList A :=
  lcons a (fun _ => lnil).
(*   lcons _ a (fun _ => (lnil _)). *)

Fixpoint concatLazyList {A : Type} (l : LazyList (LazyList A)) : LazyList A :=
  match l with
  | lnil => lnil
  | lcons x l' => lazy_append x (concatLazyList (l' tt))
  end.

Definition bindLazyList {A B : Type} (l : LazyList A) (f : A -> LazyList B) : LazyList B :=
  concatLazyList (mapLazyList f l).

#[global] Instance MonadLazyList : Monad LazyList :=
  {
    ret := @retLazyList;
    bind := @bindLazyList
  }.

Definition apLazyList {A B : Type} (lab : LazyList (A -> B)) (la : LazyList A) : LazyList B :=
  ab <- lab;;
  a <- la;;
  ret (ab a).

#[global] Instance ApplicativeLazyList : Applicative LazyList :=
  {
    pure := @retLazyList;
    ap := @apLazyList
  }.

Definition apComp {F: Type -> Type} `{Functor F} {A B C : Type} (f : B -> C) (fab : F (A -> B)) : F (A -> C) :=
  fmap (fun g => fun a => f (g a)) fab.

(* Guard definition, because ExtLib doesn't have Alternative *)
Definition guard (b : bool) : LazyList unit :=
  match b with
  | true => ret tt
  | false => lnil
  end.

(* Lazy list in *)
Fixpoint In_ll {A : Type} (a : A) (l : LazyList A) : Prop :=
  match l with
  | lnil => False
  | lcons h ts => h = a \/ In_ll a (ts tt)
  end.

Fixpoint All_ll {A : Type} (P : A -> Prop) (l : LazyList A) : Prop :=
  match l with
  | lnil => True
  | lcons h ts => P h /\ All_ll P (ts tt)
  end.

From Coq Require Import ssreflect.
Lemma lazy_in_map_iff :
  forall (A B : Type) (f : A -> B) (l : LazyList A) (y : B),
  In_ll y (mapLazyList f l) <-> (exists x : A, f x = y /\ In_ll x l).
Proof.
  move => A B f l; induction l => y; split => [HIn | [x [Hfx HIn]]].
  - inversion HIn.
  - inversion HIn.
  - simpl in *.
    destruct HIn as [Hf | HIn].
    + exists a; split; auto.
    + apply H in HIn.
      destruct HIn as [x [Hf HIn]].
      exists x; split; auto.
  - destruct HIn as [Hf | HIn]; subst; simpl in *; auto.
    right; apply H.
    exists x; auto.
Qed.

    (*
Section Ind.

  Variable A : Type.
  Variable P : LazyList A -> Prop.
  Variable Hnil  : P (lnil).
  Variable Hsing : forall (a : A), P (lsing a).
  Variable Hcons : forall (a : A) (l : LazyList A), P l -> P (lcons a (fun _ => l)).

  Fixpoint better_ll_ind (l : LazyList A) : P l :=
    match l with
    | lnil => Hnil
    | lsing x => Hsing x
    | lcons a tl => @Hcons a (tl tt) (better_ll_ind (tl tt))
    end.

End Ind.
 *)

Lemma lazy_in_app_or :
  forall (A : Type) (l m : LazyList A) (a : A), In_ll a (lazy_append l m) -> In_ll a l \/ In_ll a m.
Proof.
  intros A l.
  induction l; intros m h Hyp; simpl in *; auto.
  - destruct Hyp; subst; simpl in *; auto.
    rewrite or_assoc.
    apply H in H0.
    destruct H0; auto.
Qed.

Lemma lazy_in_or_app :
  forall (A : Type) (l m : LazyList A) (a : A), In_ll a l \/ In_ll a m -> In_ll a (lazy_append l m).
Proof.
  intros A l.
  induction l; intros m h HIn; simpl in *.
  - destruct HIn as [Contra | HIn]; [ contradiction | auto ].
  - destruct HIn as [[HEq | HIn] | HIn]; subst; simpl in *; auto.
Qed.

Fixpoint LazyList_to_list {A : Type} (l : LazyList A) : list A :=
  match l with
  | lnil => nil
  | lcons x x0 => x :: LazyList_to_list (x0 tt)
  end.

Fixpoint list_to_LazyList {A : Type} (l : list A) : LazyList A :=
  match l with
  | nil => lnil
  | cons x x0 => lcons x (fun _ => (list_to_LazyList x0))
  end.

Theorem nil_lazylist :
  forall A (l : LazyList A),
    [] = LazyList_to_list l -> l = lnil.
Proof.
  intros A l H.
  destruct l; simpl in *; auto; inversion H.
Qed.

Theorem lazy_in_map:
  forall (A B : Type) (f : A -> B) (l : LazyList A) (x : A), In_ll x l -> In_ll (f x) (fmap f l).
Proof.
  intros A B f l.
  induction l; intros x HIn.
  - inversion HIn.
  - destruct HIn as [Hax | Hin]; subst; auto.
    + left. auto.
    + right. auto.
Qed.

Lemma lazy_append_nil_r :
  forall {B : Type} (b : B) l,
    In_ll b l ->
    In_ll b (lazy_append l lnil).
Proof.
  intros B b l H.
  induction l.
  - inversion H.
  - simpl in *. firstorder.
Qed.

Lemma lazy_append_sing_r :
  forall {B : Type} (b x : B) l,
    In_ll b l ->
    In_ll b (lazy_append l (lcons x (fun _ => lnil))).
Proof.
  intros B b x l H.
  induction l.
  - inversion H.
  - simpl in *. firstorder.
Qed.

Lemma lazy_append_in_l :
  forall {B : Type} ll (b : B) l,
    In_ll b l ->
    In_ll b (lazy_append l ll).
Proof.
  intros B ll; induction ll; intros b l0 HIn.
  - auto using lazy_append_nil_r.
  - induction l0.
    + inversion HIn.
    + simpl in *. firstorder.
Qed.

Lemma lazy_append_in_r :
  forall {B : Type} (b : B) l ll,
    In_ll b ll ->
    In_ll b (lazy_append l ll).
Proof.
  intros B b l ll H.
  induction l; simpl; auto.
Qed.

Lemma lazy_concat_in :
  forall {B : Type} (b : B) l ll,
    In_ll b l ->
    In_ll l ll ->
    In_ll b (concatLazyList ll).
Proof.
  intros B b l ll Hb Hbll.
  induction ll; simpl in *; subst; auto.
  destruct Hbll as [Hal | Hinl]; subst;
    auto using lazy_append_in_l, lazy_append_in_r.
Qed.

Fixpoint join_list_lazy_list {A : Type} (l : list (LazyList A)) : LazyList A :=
  match l with
  | nil => lnil
  | cons h ts => lazy_append h (join_list_lazy_list ts)
  end.

Fixpoint joint_list_lazy_list_list {A : Type} (l : list (LazyList A)) : list A :=
  match l with
  | nil => nil
  | cons h ts => (LazyList_to_list h) ++ (joint_list_lazy_list_list ts)
  end.

Fixpoint lazy_seq {A : Type}
           (s : A -> A) (lo : A) (len : nat) :=
  match len with
  | O => lnil
  | S len' => lcons lo (fun tt => lazy_seq s (s lo) len')
  end.

Definition mapLazyListProof {A B : Type}
         (l : LazyList A)
         (f : forall (x : A), In_ll x l -> B) :
  LazyList B.
Proof.
  induction l.
  - apply lnil.
  - apply lcons.
    + apply (f a).
      left; reflexivity.
    + specialize (X tt).
      refine (fun u => _).
      apply X.
      intros x In.
      apply (f x).
      right; auto.
Defined.

Definition bindLazyListPf {A B : Type}
           (l : LazyList A)
           (f : forall (x : A),
               In_ll x l -> LazyList B) : LazyList B :=
  (concatLazyList (mapLazyListProof l f)).

Fixpoint filter_LazyList {A} (p : A -> bool) (l : LazyList A) :=
  match l with
  | lnil => lnil
  | lcons h t => if p h then
                   lcons h (fun tt => filter_LazyList p (t tt))
                 else filter_LazyList p (t tt)
  end.

Require Import Coq.Logic.ClassicalFacts.

Axiom EM : excluded_middle.

Lemma In_ll_Dec {A : Type} (* {_ : Dec_Eq A} *) (x : A) l :
  (LazyList.In_ll x l) \/ (~ LazyList.In_ll x l ).
Proof.
  induction l.
  - right. intros Hc; inv Hc.
  - assert (Hem := EM (x = a)). destruct Hem.
    + left; eauto. left; eauto.
    + destruct (H tt).
      * left. right. eassumption.
      * right. intros Hc. inv Hc; eauto.
Qed.

Lemma lazy_concat_in' :
  forall {B : Type} (b : B) ll,
    LazyList.In_ll b (LazyList.concatLazyList ll) ->
    exists l, LazyList.In_ll b l /\ LazyList.In_ll l ll.
Proof.
  intros B b ll Hbll.
  induction ll; simpl in *; subst; auto.
  - exfalso; eauto.
  - eapply LazyList.lazy_in_app_or in Hbll. inv Hbll; eauto.
    eapply H in H0. destruct H0 as [l' [Hin1 Hin2]].
    eexists. split; eauto.
Qed.


From stdpp Require Import gmap.

(** Abstract Notion of Timestamps with Total Order. *)

Section Time.

  Class DB_time := {
    Time : Type;
    TM_lt' : relation Time;
    TM_lt := strict TM_lt';
    TM_lt_TO :> TotalOrder (TM_lt);
    TM_EqDecision :> EqDecision Time;
   }.

  Class Timed {dbt: DB_time} (T : Type) := time : T → Time.

  Notation "t1 '<ₜ' t2" :=
    (TM_lt (time t1) (time t2)) (at level 70, no associativity).
  Notation "t1 '≤ₜ' t2" :=
    (TM_lt (time t1) (time t2) ∨ (time t1 = time t2)) (at level 70, no associativity).
  Notation "t1 '=ₜ' t2" :=
    (time t1 = time t2) (at level 70, no associativity).

  Definition IsMaximum {T : Type} `{!DB_time} `{!EqDecision T}
             `{!Countable T} `{!Timed T} (X : gset T) (mx : T) :=
    mx ∈ X ∧ ∀ t, t ∈ X → (¬ t = mx) → t <ₜ mx.

  Class Maximals_Computing `{!DB_time} :=
    {
      Maximum : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T), option T;
      Maximum_correct : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T),
          (∀ x y, x ∈ X → y ∈ X → x =ₜ y → x = y) →
          (∀ x, Maximum X = Some x ↔ IsMaximum X x);
    }.

  End Time.

Notation "s '<ₜ@{' d '}' t" :=
  (TM_lt (@time d _ _ s) (@time d _ _ t))
    (at level 70, no associativity, format "s  '<ₜ@{' d '}'  t").
Notation "s '≤ₜ@{' d '}' t" :=
  (TM_lt (@time d _ _ s) (@time d _ _ t) ∨  (@time d _ _ s) = (@time d _ _ t))
    (at level 70, no associativity, format "s  '≤ₜ@{' d '}'  t").
Notation "s '=ₜ@{' d '}' t" :=
  ((@time d _ _ s) = (@time d _ _ t))
    (at level 70, no associativity, format "s  '=ₜ@{' d '}'  t").

Notation "s '<ₜ' t" :=
  (TM_lt (time s) (time t)) (at level 70, no associativity).
Notation "s '≤ₜ' t" :=
  (TM_lt (time s) (time t) ∨ (time s = time t)) (at level 70, no associativity).
Notation "s '=ₜ' t" :=
  (time s = time t) (at level 70, no associativity).