Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.
Inductive color : Type :=
  | black : color
  | white : color
  | primary : rgb -> color.

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_equ_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_equ x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

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

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

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export Reals.
Require Export tactics2.
Require Export Coquelicot.Rcomplements.

(*Require Export CoRN.reals.CReals.*)

(**

  Some useful lemmas about reals which we used in our proofs.

*)

Hint Rewrite Rminus_0_r.
Hint Rewrite Ropp_0.
Hint Rewrite Rabs_R0.
Hint Rewrite Rmult_1_l : core.
Hint Rewrite Rmult_1_r : core.
Hint Rewrite Rmult_0_l : core.
Hint Rewrite Rmult_0_r : core.
Hint Rewrite Rplus_0_l : core.
Hint Rewrite Rplus_0_r : core.
Hint Rewrite Nat.sub_diag : core.
Hint Rewrite minus0 : core.
Hint Rewrite pow_O : core.
Hint Rewrite Nat.mul_1_r : core.
Hint Rewrite Nat.add_0_r : core.
Hint Rewrite Rinv_1 : core.
Hint Rewrite Rplus_opp_l : core.
Hint Rewrite Rminus_0_l : core.
Hint Rewrite pow1 : core.
Hint Rewrite Ropp_involutive : core.
Hint Rewrite Rcomplements.Rdiv_1 : core.

(** Dummy real number *)
Definition DumR : R := 0.

(** for non zero elements, division by zero returns zero *)
Lemma zero_div_is_zero :
  forall (r : R), r <> R0 -> (0 / r)%R = R0.
Proof.
  intros r d.
  rewrite (Fdiv_def Rfield).
  rewrite Rmult_0_l; auto.
Qed.

(** plus and minus are comutative *)
Lemma Rplus_minus_comm :
  forall r1 r2 r3 : R,
    (r1 + r2 - r3)%R = (r2 + (r1 - r3))%R.
Proof.
  intros r1 r2 r3.
  repeat rewrite (Rsub_def (F_R Rfield)).
  rewrite (Radd_comm (F_R Rfield) r1 r2).
  rewrite <- (Radd_assoc (F_R Rfield) r2 r1).
  auto.
Qed.

(** subtraction of two same numbers equals zero *)
Lemma Rminus_same :
  forall r, (r - r)%R = R0.
Proof.
  intros r.
  rewrite (Rsub_def (F_R Rfield) r).
  rewrite (Ropp_def (F_R Rfield)); auto.
Qed.
Hint Rewrite Rminus_same.

(** R1 as posreal *)
Definition R1pos : posreal := mkposreal R1 Rlt_0_1.

(* this definition is used in definition of dynamic semantics of programs *)
(** returns all reals which are greater or equal than zero *)
Record preal : Set :=
  mk_preal
    {
      preal_r :> R;
      preal_cond : (0 <= preal_r)%R
    }.
Hint Resolve preal_cond : core.

(* this definition is used in definition of dynamic semantics of programs *)
(** returns all reals which are greater or equal than zero, but less or equal than r  *)
Record preal_upto (r : R) : Set :=
  mk_preal_upto
    {
      preal_upto_preal :> preal;
      preal_upto_cond : (preal_upto_preal <= r)%R
    }.

Lemma preal_upto_are_pos :
  forall r (z : preal_upto r), (0 <= z)%R.
Proof.
  introv.
  destruct z as [x z]; simpl.
  destruct x; simpl in *; auto.
Qed.

Lemma lt_preal_upto_trans :
  forall (r : R)
         (r1 : preal_upto r)
         (r2 : preal_upto r1),
    (preal_upto_preal r1 r2 <= r)%R.
Proof.
  introv.
  destruct r1 as [rr1 cr1].
  destruct r2 as [rr2 cr2].
  simpl in *.
  eapply Rle_trans; eauto.
Qed.

Definition ex_preal_upto_trans
           (r : R)
           (r1 : preal_upto r)
           (r2 : preal_upto r1) : preal_upto r :=
  mk_preal_upto
    r
    (preal_upto_preal r1 r2)
    (lt_preal_upto_trans r r1 r2).

Lemma Rmult_lt_pos :
  forall r1 r2 : R, (0 < r1)%R -> (0 < r2)%R -> (0 < r1 * r2)%R.
Proof.
  introv lt0r1 lt0r2.
  pose proof (Rmult_le_0_lt_compat 0 r1 0 r2) as q.
  autorewrite with core in q; apply q; auto; try apply Rle_refl.
Qed.

Definition posreal_plus (p1 p2 : posreal) : posreal :=
  match p1, p2 with
  | mkposreal r1 c1, mkposreal r2 c2 =>
    mkposreal (r1 + r2) (Rplus_lt_0_compat r1 r2 c1 c2)
  end.

Definition posreal_half (p : posreal) : posreal :=
  mkposreal (p / 2) (Rcomplements.is_pos_div_2 p).

Lemma posreal_eq_two_halves :
  forall p : posreal, pos p = (p / 2) + (p / 2).
Proof.
  introv;apply double_var.
Qed.

Definition posreal_min (p1 p2 : posreal) : posreal :=
  mkposreal (Rmin p1 p2) (Rmin_stable_in_posreal p1 p2).

(** definition of zero for preal type *)
Definition R0preal : preal := mk_preal R0 (Rle_refl 0).
(** definition of one for preal type *)
Definition R1preal : preal := mk_preal R1 Rle_0_1.

(* Used in definition of interpretation of primed terms *)
Fixpoint big_sum {T} (vars : list T) (f : T -> R) : R :=
  match vars with
  | [] => R0
  | h :: t => Rplus (f h) (big_sum t f)
  end.

Lemma R_move_sub1 :
  forall (a b c d : R),
    (a - b <= c - d)%R -> (a <= c - (d - b))%R.
Proof.
  introv h.
  apply (Rplus_le_compat_r b) in h.
  repeat rewrite (Rsub_def (F_R Rfield)) in h.
  rewrite <- (Radd_assoc (F_R Rfield)) in h.
  autorewrite with core in *.
  rewrite <- (Radd_assoc (F_R Rfield)) in h.

  rewrite (Rsub_def (F_R Rfield) c (d - b)%R).
  rewrite Ropp_minus_distr'.
  rewrite (Rsub_def (F_R Rfield)).
  rewrite (Radd_comm (F_R Rfield) b); auto.
Qed.


Add LoadPath "coq/examples".
Require Import Example.
Require Import Vector.
Require Import List.
Require Import Ornamental.Ornaments.

From Coq Require Import Arith.

(* syntax to match paper *)
Notation vector := Vector.t.
Notation consV n t v := (Vector.cons _ t n v).
Notation nilV := Vector.nil.

Set DEVOID search prove coherence.
Set DEVOID search prove equivalence.
Set DEVOID lift type.

(* Usually, we use this: *)
Definition vanilla_uip
  : forall (x y : nat) (p1 p2 : x = y), p1 = p2
:= Eqdep_dec.UIP_dec Nat.eq_dec.

(*
 * Okay, now let's try to state and prove a lemma that doens't
 * depend on UIP on the type nat, but rather depends
 * on the list and vector types. First:
 *)
Find ornament list vector as ltv.

(*
 * Next, define the adjoints:
 *)

Definition section_adjoint T := Adjoint.fg_id' (ltv_inv T) (ltv T) (ltv_retraction T) (ltv_section T).
Definition retraction_adjoint T := Adjoint.fg_id' (ltv T) (ltv_inv T) (ltv_section T) (ltv_retraction T).

Lemma is_adjoint_section T (pv : sigT (vector T)) : ltv_section T (ltv_inv T pv) = f_equal (ltv_inv T) (retraction_adjoint T pv).
Proof.
  apply Adjoint.g_adjoint.
Defined.

Lemma is_adjoint_retraction T (l : list T) : ltv_retraction T (ltv T l) = f_equal (ltv T) (section_adjoint T l).
Proof.
  apply Adjoint.g_adjoint.
Defined.

(*
Lemma mocha_uip :
  forall (T : Type) (n : nat) (l : list T) (p1 p2 : projT1 (ltv T l) = ltv_index T l),
    p1 = p2.
Proof.
  intros T n l. destruct (ltv_coh T l). remember (ltv T l) as s.

 unfold ltv. simpl.

 remember (ltv T l) as s. induction s.

 Check ltv_coh.

 apply (Eqdep_dec.UIP_dec Nat.eq_dec).*)

(* Try the Jason thing first: *)
Definition ltv_u (A : Type) (n : nat) (ll : { l : list A & ltv_index A l = n}) : vector A n :=
  eq_rect
    (ltv_index _ (projT1 ll))
    (vector A)
    (eq_rect
      (projT1 (ltv _ (projT1 ll)))
      (vector A)
      (projT2 (ltv _ (projT1 ll)))
      (ltv_index _ (projT1 ll))
      (ltv_coh _ (projT1 ll)))
    n
    (projT2 ll). (* ltv_index A l = n *)

Definition ltv_inv_u (A : Type) (n : nat) (v : vector A n) : { l : list A & ltv_index A l = n} :=
  existT
    (fun (l : list A) => ltv_index _ l = n)
    (ltv_inv _ (existT _ n v))
    (eq_rect
      (projT1 (ltv A (ltv_inv A (existT _ n v))))
      (fun n0 : nat => n0 = n)
      (eq_rect
        (existT _ n v)
        (fun s : sigT (vector A) => projT1 s = n)
        (eq_refl (projT1 (existT _ n v)))
        (ltv A (ltv_inv A (existT _ n v)))
        (eq_sym (ltv_retraction _ (existT _ n v))))
      (ltv_index _ (ltv_inv _ (existT _ n v)))
      (ltv_coh _ (ltv_inv _ (existT _ n v)))).

Lemma section_u : forall A n v, ltv_inv_u A n (ltv_u A n v) = v.
Proof.
  intros A n [l H]; apply eq_sigT_uncurried; subst n.
  cbv [ltv_u ltv_inv_u ltv_coh].
  cbn [projT1 projT2 eq_rect].
  change (existT _ (ltv_index A l) (projT2 (ltv A l))) with (ltv A l).
  exists (section_adjoint _ _).
  rewrite (is_adjoint_retraction A l).
  destruct (section_adjoint A l).
  reflexivity.
Qed.

Lemma retraction_u : forall A n v, ltv_u A n (ltv_inv_u A n v) = v.
Proof.
  cbv [ltv_u ltv_inv_u].
  cbn [projT1 projT2].
  intros.
  set (p := ltv_retraction A (existT _ n v)).
  set (q := ltv_coh _ _).
  clearbody p q.
  cbv beta in *.
  generalize dependent (ltv A (ltv_inv A (existT _ n v))).
  intros [x y] p q.
  cbn [projT1 projT2] in *.
  subst x.
  inversion_sigma.
  repeat match goal with H : _ = ?v |- _ => is_var v; destruct H end.
  reflexivity.
Qed.

(* So, what variant of UIP do we get this way? It should be in the proof of section somewhere. *)
(* TODO WIP, see issue 39 *)

Definition zip := packed_list.zip.
Definition zip_with := packed_list.zip_with.

Lemma uip_instance:
  forall (A B : Type) (n : nat)
    (l : list A) (H : hs_to_coqV_p.list_to_t_index A l = n)
    (pl2 : {l2 : list B & length l2 = n}),
  eq_rect
    (hs_to_coq.zip_with A B (A * B) pair l (projT1 pl2))
    (fun l3 : list (A * B) => length l3 = n)
    (packed_list.zip_with_length A B (A * B) pair n l (projT1 pl2) (id H) (projT2 pl2))
    (hs_to_coq.zip A B l (projT1 pl2))
    (hs_to_coq.zip_with_is_zip A B l (projT1 pl2)) =
  packed_list.zip_length A B n l (projT1 pl2) (id H) (projT2 pl2).
Proof.
  intros.
  apply (Eqdep_dec.UIP_dec Nat.eq_dec). (* <- what we want to replace *)
Defined.

Lemma zip_with_is_zip :
  forall A B n (pl1 : { l1 : list A & length l1 = n }) (pl2 : { l2 : list B & length l2 = n }),
    zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2.
Proof.
  intros A B n pl1.
  apply packed_list_rect with (P := fun (pl1 : {l1 : list A & length l1 = n}) => forall pl2 : {l2 : list B & length l2 = n}, zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2).
  intros l H pl2.
  unfold zip_with, zip, packed_list_rect, hs_to_coqV_p.list_to_t_rect, packed_rect. simpl.
  apply eq_existT_uncurried.
  (* list proof: *)
  exists (hs_to_coq.zip_with_is_zip A B l (projT1 pl2)).
  (* length invariant: *)
  apply uip_instance.
Defined.


From Hammer Require Import Hammer.

Require Import FunctionalExtensionality.
Require Import Lra.
From Topology Require Export RTopology.
From Topology Require Export ProductTopology.

Lemma continuous_at_iff_continuity_pt
{f : R -> R} {x : R} :
@continuous_at RTop RTop f x <-> continuity_pt f x.
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.continuous_at_iff_continuity_pt".
split.
- intros H eps H0.
assert (neighbourhood (inverse_image f [r : R | Rabs (r - f x) < eps]) x) as H1.
apply RTop_neighborhood_is_neighbourhood, H, open_neighborhood_is_neighborhood.
split.
+ replace [r : R | Rabs (r - f x) < eps] with [r : R | f x - eps < r < f x + eps]
by (FiniteIntersectionLemmas.extensionality_ensembles;
constructor;
apply Rabs_def1 + apply Rabs_def2 in H1;
lra).
apply R_interval_open.
+ constructor.
apply Rabs_def1; lra.
+ destruct H1 as [[alp H1] H2].
exists alp.
split; trivial.
intros x0 [? H3].
now destruct (H2 _ H3) as [[?]].
- intros H U HU.
apply RTop_neighborhood_is_neighbourhood.
pose HU as H0.
apply RTop_neighborhood_is_neighbourhood in H0.
destruct H0 as [[eps H0] H1],
(H eps H0) as [alp [H2 H3]].
exists (mkposreal alp H2).
intros x' H'.
constructor.
destruct (Req_dec x x').
+ subst.
destruct HU as [V [[H4 H5] H6]].
now apply H6.
+ now apply H1, H3.
Qed.

Lemma continuous_iff_continuity
{f : R -> R} :
@continuous RTop RTop f <-> continuity f.
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.continuous_iff_continuity".
split;
intros H ?.
- now apply continuous_at_iff_continuity_pt,
continuous_func_continuous_everywhere.
- apply pointwise_continuity.
intro.
now apply continuous_at_iff_continuity_pt.
Qed.

Lemma Rplus_continuous: continuous_2arg Rplus (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rplus_continuous".
apply pointwise_continuity_2arg.
intros.
red.
pose proof (RTop_metrization (x+y)).
apply continuous_at_neighborhood_basis with
(metric_topology_neighborhood_basis R_metric (x+y)).
- apply open_neighborhood_basis_is_neighborhood_basis,
RTop_metrization.
- intros.
destruct H0.
exists ([ p:point_set RTop * point_set RTop | let (x',y'):=p in
In (open_ball _ R_metric x (r/2)) x' /\
In (open_ball _ R_metric y (r/2)) y' ]).
repeat split;
try (rewrite metric_zero; apply R_metric_is_metric + lra).
+ apply ProductTopology2_basis_is_basis.
constructor;
[ destruct (RTop_metrization x) |
destruct (RTop_metrization y)];
apply (open_neighborhood_basis_elements (open_ball _ _ _ _));
constructor; lra.
+ destruct x0 as [x' y'],
H1 as [[[] []]].
unfold R_metric.
replace (x'+y' - (x+y)) with ((x'-x) + (y'-y)) by ring.
apply Rle_lt_trans with (Rabs (x'-x) + Rabs(y'-y)).
* apply Rabs_triang.
* replace r with (r/2+r/2) by field.
now apply Rplus_lt_compat.
Qed.

Corollary sum_continuous: forall (X:TopologicalSpace)
(f g:point_set X -> point_set RTop) (x:point_set X),
continuous_at f x -> continuous_at g x ->
continuous_at (fun x:point_set X => f x + g x) x (Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.sum_continuous".
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere,
Rplus_continuous.
Qed.

Lemma Rminus_continuous: continuous_2arg Rminus
(X:=RTop) (Y:=RTop) (Z:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rminus_continuous".
unfold Rminus.
apply pointwise_continuity_2arg; intros.
red.
pose proof (sum_continuous _
(fun p:point_set (ProductTopology2 RTop RTop) => fst p)
(fun p:point_set (ProductTopology2 RTop RTop) => -snd p) (x,y)).
simpl in H.
match goal with |- continuous_at ?f ?q =>
replace f with (fun p:R*R => fst p + - snd p) end.
- apply sum_continuous.
+ apply continuous_func_continuous_everywhere,
product2_fst_continuous.
+ eapply (continuous_composition_at (Y:=RTop));
apply continuous_func_continuous_everywhere.
* apply Ropp_continuous.
* apply product2_snd_continuous.
- extensionality p.
now destruct p.
Qed.

Corollary diff_continuous: forall (X:TopologicalSpace)
(f g:point_set X -> point_set RTop) (x:point_set X),
continuous_at f x -> continuous_at g x ->
continuous_at (fun x:point_set X => f x - g x) x (Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.diff_continuous".
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
exact Rminus_continuous.
Qed.

Lemma const_multiple_func_continuous: forall c:R,
continuous (fun x:R => c*x) (X:=RTop) (Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.const_multiple_func_continuous".
intros.
apply continuous_iff_continuity,
continuity_mult.
- apply continuity_const.
red.
now intros.
- intro.
apply derivable_continuous_pt, derivable_pt_id.
Qed.

Corollary const_multiple_continuous: forall (X:TopologicalSpace)
(f:point_set X -> point_set RTop) (c:R) (x:point_set X),
continuous_at f x -> continuous_at (fun x:point_set X => c * f x) x
(Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.const_multiple_continuous".
intros.
apply continuous_composition_at; trivial.
apply continuous_func_continuous_everywhere,
const_multiple_func_continuous.
Qed.

Lemma Rmult_continuous_at_origin: continuous_at_2arg Rmult 0 0
(X:=RTop) (Y:=RTop) (Z:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rmult_continuous_at_origin".
red.
pose proof (RTop_metrization 0).
apply continuous_at_neighborhood_basis with
(metric_topology_neighborhood_basis R_metric 0).
- apply open_neighborhood_basis_is_neighborhood_basis.
replace (0*0) with 0 by auto with real.
apply H.

- intros.
destruct H0.
exists (characteristic_function_to_ensemble
(fun p:point_set RTop * point_set RTop => let (x',y'):=p in
In (open_ball _ R_metric 0 r) x' /\
In (open_ball _ R_metric 0 1) y' )).
repeat split.
+ apply ProductTopology2_basis_is_basis.
constructor;
destruct H.
* apply (open_neighborhood_basis_elements (open_ball _ R_metric 0 r)).
now constructor.
* apply (open_neighborhood_basis_elements (open_ball _ R_metric 0 1)).
constructor; red; auto with real.
+ rewrite metric_zero; trivial.
apply R_metric_is_metric.
+ rewrite metric_zero; auto with real.
apply R_metric_is_metric.
+ destruct H1.
destruct x as [x y].
destruct H1 as [[] []].
unfold R_metric in *.
replace (x*y-0) with (x*y) by auto with real.
replace (x-0) with x in H1 by auto with real.
replace (y-0) with y in H2 by auto with real.
rewrite Rabs_mult.
replace r with (r*1) by auto with real.
apply Rmult_le_0_lt_compat;
apply Rabs_pos + trivial.
Qed.

Lemma Rmult_continuous: continuous_2arg Rmult (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rmult_continuous".
apply pointwise_continuity_2arg.
intros x0 y0.
red.
match goal with |- continuous_at ?f ?q => replace f with
(fun p:point_set RTop*point_set RTop =>
(fst p - x0) * (snd p - y0) + y0 * fst p + x0 * snd p - x0 * y0) end.
- apply diff_continuous.
+ apply sum_continuous.
* apply sum_continuous.
** apply continuous_composition_at_2arg with RTop RTop.
*** simpl.
replace (x0-x0) with 0 by ring.
replace (y0-y0) with 0 by ring.
apply Rmult_continuous_at_origin.
*** apply diff_continuous;
apply continuous_func_continuous_everywhere;
apply product2_fst_continuous + apply continuous_constant.
*** apply diff_continuous;
apply continuous_func_continuous_everywhere;
apply product2_snd_continuous + apply continuous_constant.
** apply const_multiple_continuous,
continuous_func_continuous_everywhere;
apply product2_fst_continuous.
* apply const_multiple_continuous,
continuous_func_continuous_everywhere;
apply product2_snd_continuous.
+ apply continuous_func_continuous_everywhere;
apply continuous_constant.
- extensionality p.
destruct p.
simpl.
ring.
Qed.

Corollary product_continuous: forall (X:TopologicalSpace)
(f g:point_set X -> point_set RTop) (x:point_set X),
continuous_at f x -> continuous_at g x ->
continuous_at (fun x:point_set X => f x * g x) x (Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.product_continuous".
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
exact Rmult_continuous.
Qed.

Lemma Rinv_continuous (x : R) :
x <> 0 -> @continuous_at RTop RTop Rinv x.
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rinv_continuous".
intros.
apply continuous_at_iff_continuity_pt,
continuity_pt_inv; trivial.
apply derivable_continuous_pt, derivable_pt_id.
Qed.

Lemma Rdiv_continuous: forall x y:R, y <> 0 ->
continuous_at_2arg Rdiv x y (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rdiv_continuous".
intros.
red.
match goal with |- continuous_at ?f ?q => replace f with
(fun p:point_set RTop * point_set RTop => fst p * / snd p) end.
- apply product_continuous.
+ apply continuous_func_continuous_everywhere;
apply product2_fst_continuous.
+ apply continuous_composition_at.
* simpl.
now apply Rinv_continuous.
* apply continuous_func_continuous_everywhere;
apply product2_snd_continuous.
- extensionality p.
now destruct p.
Qed.

Corollary quotient_continuous: forall (X:TopologicalSpace)
(f g:point_set X -> point_set RTop) (x0:point_set X),
continuous_at f x0 -> continuous_at g x0 -> g x0 <> 0 ->
continuous_at (fun x:point_set X => f x / g x) x0 (Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.quotient_continuous".
intros.
apply continuous_composition_at_2arg; trivial.
apply Rdiv_continuous; trivial.
Qed.

Lemma Rabs_continuous: continuous Rabs (X:=RTop) (Y:=RTop).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.Rabs_continuous".
apply pointwise_continuity.
intros.
apply metric_space_fun_continuity with R_metric R_metric;
try apply RTop_metrization.
intros.
exists eps; split; trivial.
intros.
apply Rle_lt_trans with (2 := H0).
apply Rabs_triang_inv2.
Qed.

From Topology Require Export Homeomorphisms.

Lemma open_interval_homeomorphic_to_real_line:
let U:=characteristic_function_to_ensemble
(fun x:point_set RTop => -1 < x < 1) in
homeomorphic RTop (SubspaceTopology U).
Proof. hammer_hook "RFuncContinuity" "RFuncContinuity.open_interval_homeomorphic_to_real_line".
intros.
assert (forall x:R, -1 < x / (1 + Rabs x) < 1).
intros.
assert (0 < 1 + Rabs x).
apply Rlt_le_trans with 1; auto with real.
pattern 1 at 1; replace 1 with (1+0) by auto with real.
apply Rplus_le_compat_l.
apply Rabs_pos.
apply and_comm; apply Rabs_def2.
unfold Rdiv; rewrite Rabs_mult.
rewrite Rabs_Rinv.
rewrite (Rabs_right (1 + Rabs x)); try (left; trivial).
pattern 1 at 2; replace 1 with ((1 + Rabs x) * / (1 + Rabs x)).
apply Rmult_lt_compat_r.
apply Rinv_0_lt_compat; trivial.
pattern (Rabs x) at 1; replace (Rabs x) with (0 + Rabs x); auto with real.
field.
apply Rgt_not_eq; trivial.
apply Rgt_not_eq; trivial.

assert (forall x:point_set RTop, In U (x / (1 + Rabs x))).
intros; constructor; apply H.
From Topology Require Import ContinuousFactorization.
exists (continuous_factorization _ _ H0).
exists (fun x:point_set (SubspaceTopology U) =>
(subspace_inc U x) / (1 - Rabs (subspace_inc U x))).
apply factorization_is_continuous.
apply pointwise_continuity; intros.
apply quotient_continuous.
apply continuous_func_continuous_everywhere; apply continuous_identity.
apply sum_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply continuous_func_continuous_everywhere; apply Rabs_continuous.
apply Rgt_not_eq.
apply Rlt_le_trans with 1; auto with real.
pattern 1 at 1; replace 1 with (1+0) by auto with real.
apply Rplus_le_compat_l.
apply Rabs_pos.

apply pointwise_continuity; intros.
apply quotient_continuous.
apply continuous_func_continuous_everywhere; apply subspace_inc_continuous.
apply diff_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply continuous_composition_at.
apply continuous_func_continuous_everywhere; apply Rabs_continuous.
apply continuous_func_continuous_everywhere; apply subspace_inc_continuous.
apply Rgt_not_eq.
apply Rgt_minus.
red.
destruct x as [x [[]]]; simpl.
apply Rabs_def1; trivial.

simpl.
intros.
unfold Rabs at 1 3; destruct Rcase_abs.
rewrite Rabs_left.
field.
split; intro; lra.
assert (/ (1 + -x) > 0).
apply Rinv_0_lt_compat.
lra.
replace 0 with (x*0) by auto with real.
apply Rmult_lt_gt_compat_neg_l; trivial.

rewrite Rabs_right.
field.
split; intro; lra.
assert (/ (1+x) > 0).
apply Rinv_0_lt_compat.
lra.
apply Rle_ge.
apply Rge_le in r.
red in H1.
unfold Rdiv.
replace 0 with (0 * / (1+x)); auto with real.

intros.
destruct y as [x].
simpl.
From ZornsLemma Require Import Proj1SigInjective.
apply subset_eq_compatT.
destruct i.
destruct H1.
assert (Rabs x < 1).
apply Rabs_def1; trivial.

unfold Rabs at 1 3; destruct Rcase_abs.
rewrite Rabs_left.
field.
split; intro; lra.
replace (1 - -x) with (1+x) by ring.
assert (/ (1+x) > 0).
apply Rinv_0_lt_compat.
lra.
unfold Rdiv.
replace 0 with (x*0) by auto with real.
apply Rmult_lt_gt_compat_neg_l; trivial.

rewrite Rabs_right.
field.
split; intro; lra.
assert (/ (1-x) > 0).
apply Rinv_0_lt_compat.
apply Rgt_minus; trivial.
unfold Rdiv.
red in H4.
apply Rge_le in r.
apply Rle_ge.
replace 0 with (0 * / (1-x)); auto with real.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XRseries.
Require Import XPartSum.
Local Open Scope XR_scope.

  (**********)
Lemma sum_N_predN :
  forall (An:nat -> R) (N:nat),
    (0 < N)%nat -> sum_f_R0 An N = sum_f_R0 An (pred N) + An N.
Proof.
  intros.
  replace N with (S (pred N)).
  rewrite tech5.
  reflexivity.
  symmetry ; apply S_pred with 0%nat; assumption.
Qed.

  (**********)
Lemma sum_plus :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun l:nat => An l + Bn l) N = sum_f_R0 An N + sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  reflexivity.
  do 3 rewrite tech5.
  rewrite HrecN.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_comm.
reflexivity.
Qed.

  (* The main result *)
Theorem cauchy_finite :
  forall (An Bn:nat -> R) (N:nat),
    (0 < N)%nat ->
    sum_f_R0 An N * sum_f_R0 Bn N =
    sum_f_R0 (fun k:nat => sum_f_R0 (fun p:nat => An p * Bn (k - p)%nat) k) N +
    sum_f_R0
    (fun k:nat =>
      sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat)
      (pred (N - k))) (pred N).
Proof.
  intros; induction  N as [| N HrecN].
  elim (lt_irrefl _ H).
  cut (N = 0%nat \/ (0 < N)%nat).
  intro; elim H0; intro.
  rewrite H1; simpl.
rewrite Rmult_plus_distr_l.
rewrite Rmult_plus_distr_r.
rewrite Rmult_plus_distr_r.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_comm.
reflexivity.
  replace (pred (S N)) with (S (pred N)).
  do 5 rewrite tech5.
  rewrite Rmult_plus_distr_r; rewrite Rmult_plus_distr_l; rewrite (HrecN H1).
  repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  replace (pred (S N - S (pred N))) with 0%nat.
  rewrite Rmult_plus_distr_l;
    replace
      (sum_f_R0 (fun l:nat => An (S (l + S (pred N))) * Bn (S N - l)%nat) 0) with
      (An (S N) * Bn (S N)).
  repeat rewrite <- Rplus_assoc;
    do 2 rewrite <- (Rplus_comm (An (S N) * Bn (S N)));
      repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  rewrite <- minus_n_n; cut (N = 1%nat \/ (2 <= N)%nat).
  intro; elim H2; intro.
  rewrite H3; simpl.
rewrite Rmult_plus_distr_r.
rewrite Rmult_plus_distr_l.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
rewrite Rplus_comm.
reflexivity.
  replace
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
      (pred N)) with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (pred (N - k)))) (pred (pred N)) +
      sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
  replace (sum_f_R0 (fun p:nat => An p * Bn (S N - p)%nat) N) with
    (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N) +
      An 0%nat * Bn (S N)).
  repeat rewrite <- Rplus_assoc;
    rewrite <-
      (Rplus_comm (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)))
      ; repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  replace
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
        (pred (S N - k))) (pred N)) with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (N - k))) (pred N) +
      Bn (S N) * sum_f_R0 (fun l:nat => An (S l)) (pred N)).
  rewrite (decomp_sum An N H1); rewrite Rmult_plus_distr_r;
    repeat rewrite <- Rplus_assoc; rewrite <- (Rplus_comm (An 0%nat * Bn (S N)));
      repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  repeat rewrite <- Rplus_assoc;
    rewrite <-
      (Rplus_comm (sum_f_R0 (fun i:nat => An (S i)) (pred N) * Bn (S N)))
      ;
      rewrite <-
	(Rplus_comm (Bn (S N) * sum_f_R0 (fun i:nat => An (S i)) (pred N)))
	; rewrite (Rmult_comm (Bn (S N))); repeat rewrite Rplus_assoc;
	  apply Rplus_eq_compat_l.
  replace
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (N - k))) (pred N)) with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (pred (N - k)))) (pred (pred N)) +
      An (S N) * sum_f_R0 (fun l:nat => Bn (S l)) (pred N)).
  rewrite (decomp_sum Bn N H1); rewrite Rmult_plus_distr_l.
  set
    (Z :=
      sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (pred (N - k)))) (pred (pred N)));
    set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)).
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_comm.
reflexivity.
  rewrite
    (sum_N_predN
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (N - k))) (pred N)).
  replace
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (N - k))) (pred (pred N))) with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (pred (N - k))) + An (S N) * Bn (S k)) (
	  pred (pred N))).
  rewrite
    (sum_plus
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (pred (N - k)))) (fun k:nat => An (S N) * Bn (S k))
      (pred (pred N))).
  repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  replace (pred (N - pred N)) with 0%nat.
  simpl; rewrite <- minus_n_O.
  replace (S (pred N)) with N.
  replace (sum_f_R0 (fun k:nat => An (S N) * Bn (S k)) (pred (pred N))) with
    (sum_f_R0 (fun k:nat => Bn (S k) * An (S N)) (pred (pred N))).
  rewrite <- (scal_sum (fun l:nat => Bn (S l)) (pred (pred N)) (An (S N)));
    rewrite (sum_N_predN (fun l:nat => Bn (S l)) (pred N)).
  replace (S (pred N)) with N.
rewrite Rmult_plus_distr_l.
reflexivity.
  apply S_pred with 0%nat; assumption.
  apply lt_pred; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
  apply sum_eq; intros; apply Rmult_comm.
  apply S_pred with 0%nat; assumption.
  replace (N - pred N)%nat with 1%nat.
  reflexivity.
  pattern N at 1; replace N with (S (pred N)).
  rewrite <- minus_Sn_m.
  rewrite <- minus_n_n; reflexivity.
  apply le_n.
  symmetry ; apply S_pred with 0%nat; assumption.
  apply sum_eq; intros;
    rewrite
      (sum_N_predN (fun l:nat => An (S (S (l + i))) * Bn (N - l)%nat)
	(pred (N - i))).
  replace (S (S (pred (N - i) + i))) with (S N).
  replace (N - pred (N - i))%nat with (S i).
  reflexivity.
  rewrite pred_of_minus; apply INR_eq; repeat rewrite minus_INR.
  rewrite S_INR; simpl.
unfold Rminus.
repeat rewrite Ropp_plus_distr.
repeat rewrite Ropp_involutive.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply INR_le; rewrite minus_INR.
  apply Rplus_le_reg_l with (INR i - R1).
  replace (INR i - R1 + INR 1) with (INR i).
2:{ simpl.
unfold Rminus. rewrite Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_r. reflexivity.
}
  replace (INR i - R1 + (INR N - INR i)) with (INR N - INR 1).
2:{
simpl.
symmetry.
unfold Rminus.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_assoc.
rewrite Rplus_comm.
rewrite Rplus_opp_l.
rewrite Rplus_0_l.
reflexivity.
}
  rewrite <- minus_INR.
  apply le_INR; apply le_trans with (pred (pred N)).
  assumption.
  rewrite <- pred_of_minus; apply le_pred_n.
  apply le_trans with 2%nat.
  apply le_n_Sn.
  assumption.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  rewrite <- pred_of_minus.
  apply le_trans with (pred N).
  apply le_S_n.
  replace (S (pred N)) with N.
  replace (S (pred (N - i))) with (N - i)%nat.
  apply (fun p n m:nat => plus_le_reg_l n m p) with i; rewrite le_plus_minus_r.
  apply le_plus_r.
  apply le_trans with (pred (pred N));
    [ assumption | apply le_trans with (pred N); apply le_pred_n ].
  apply S_pred with 0%nat.
  apply plus_lt_reg_l with i; rewrite le_plus_minus_r.
  replace (i + 0)%nat with i; [ idtac | ring ].
  apply le_lt_trans with (pred (pred N));
    [ assumption | apply lt_trans with (pred N); apply lt_pred_n_n ].
  apply lt_S_n.
  replace (S (pred N)) with N.
  apply lt_le_trans with 2%nat.
  apply lt_n_Sn.
  assumption.
  apply S_pred with 0%nat; assumption.
  assumption.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply S_pred with 0%nat; assumption.
  apply le_pred_n.
  apply INR_eq; rewrite pred_of_minus; do 3 rewrite S_INR; rewrite plus_INR;
    repeat rewrite minus_INR.
  simpl.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
symmetry.
unfold Rminus.
repeat rewrite Rplus_assoc.
rewrite (Rplus_comm (-R1)).
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_r.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply INR_le.
  rewrite minus_INR.
  apply Rplus_le_reg_l with (INR i - R1).
  replace (INR i - R1 + INR 1) with (INR i).
2:{
simpl.
unfold Rminus.
rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
}
  replace (INR i - R1 + (INR N - INR i)) with (INR N - INR 1).
2:{
simpl.
symmetry.
unfold Rminus.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_l.
reflexivity.
}
  rewrite <- minus_INR.
  apply le_INR.
  apply le_trans with (pred (pred N)).
  assumption.
  rewrite <- pred_of_minus.
  apply le_pred_n.
  apply le_trans with 2%nat.
  apply le_n_Sn.
  assumption.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply lt_le_trans with 1%nat.
  apply lt_O_Sn.
  apply INR_le.
  rewrite pred_of_minus.
  repeat rewrite minus_INR.
  apply Rplus_le_reg_l with (INR i - R1).
  replace (INR i - R1 + INR 1) with (INR i).
2:{
simpl.
unfold Rminus.
rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
}
  replace (INR i - R1 + (INR N - INR i - INR 1)) with (INR N - INR 1 - INR 1).
  repeat rewrite <- minus_INR.
  apply le_INR.
  apply le_trans with (pred (pred N)).
  assumption.
  do 2 rewrite <- pred_of_minus.
  apply le_n.
  apply (fun p n m:nat => plus_le_reg_l n m p) with 1%nat.
  rewrite le_plus_minus_r.
  simpl; assumption.
  apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
  apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
  simpl.
unfold Rminus.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
symmetry.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_l.
rewrite Rplus_comm.
reflexivity.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
  rewrite le_plus_minus_r.
  replace (i + 1)%nat with (S i).
  replace N with (S (pred N)).
  apply le_n_S.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_pred_n.
  symmetry ; apply S_pred with 0%nat; assumption.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; reflexivity.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply lt_le_trans with 1%nat.
  apply lt_O_Sn.
  apply le_S_n.
  replace (S (pred N)) with N.
  assumption.
  apply S_pred with 0%nat; assumption.
  replace
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
        (pred (S N - k))) (pred N)) with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (N - k)) + An (S k) * Bn (S N)) (pred N)).
  rewrite
    (sum_plus
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
        (pred (N - k))) (fun k:nat => An (S k) * Bn (S N))).
  apply Rplus_eq_compat_l.
  rewrite scal_sum; reflexivity.
  apply sum_eq; intros; rewrite Rplus_comm;
    rewrite
      (decomp_sum (fun l:nat => An (S (l + i)) * Bn (S N - l)%nat)
	(pred (S N - i))).
  replace (0 + i)%nat with i; [ idtac | ring ].
  rewrite <- minus_n_O; apply Rplus_eq_compat_l.
  replace (pred (pred (S N - i))) with (pred (N - i)).
  apply sum_eq; intros.
  replace (S N - S i0)%nat with (N - i0)%nat; [ idtac | reflexivity ].
  replace (S i0 + i)%nat with (S (i0 + i)).
  reflexivity.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; simpl.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
rewrite Rplus_comm.
reflexivity.
  cut ((N - i)%nat = pred (S N - i)).
  intro; rewrite H5; reflexivity.
  rewrite pred_of_minus.
  apply INR_eq; repeat rewrite minus_INR.
  rewrite S_INR; simpl.
unfold Rminus.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
  apply le_trans with N.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
  rewrite le_plus_minus_r.
  replace (i + 1)%nat with (S i).
  apply le_n_S.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl.
reflexivity.
  apply le_trans with N.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  replace (pred (S N - i)) with (S N - S i)%nat.
  replace (S N - S i)%nat with (N - i)%nat; [ idtac | reflexivity ].
  apply plus_lt_reg_l with i.
  rewrite le_plus_minus_r.
  replace (i + 0)%nat with i; [ idtac | ring ].
  apply le_lt_trans with (pred N).
  assumption.
  apply lt_pred_n_n.
  assumption.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  rewrite pred_of_minus.
  apply INR_eq; repeat rewrite minus_INR.
  repeat rewrite S_INR; simpl.
rewrite Rplus_0_l.
unfold Rminus.
rewrite Ropp_plus_distr.
repeat rewrite Rplus_assoc.
reflexivity.
  apply le_trans with N.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
  rewrite le_plus_minus_r.
  replace (i + 1)%nat with (S i).
  apply le_n_S.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl.
reflexivity.
  apply le_trans with N.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply le_n_S.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  rewrite Rplus_comm.
  rewrite (decomp_sum (fun p:nat => An p * Bn (S N - p)%nat) N).
  rewrite <- minus_n_O.
  apply Rplus_eq_compat_l.
  apply sum_eq; intros.
  reflexivity.
  assumption.
  rewrite Rplus_comm.
  rewrite
    (decomp_sum
      (fun k:nat =>
	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
      (pred N)).
  rewrite <- minus_n_O.
  replace (sum_f_R0 (fun l:nat => An (S (l + 0)) * Bn (N - l)%nat) (pred N))
    with (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
  apply Rplus_eq_compat_l.
  apply sum_eq; intros.
  replace (pred (N - S i)) with (pred (pred (N - i))).
  apply sum_eq; intros.
  replace (i0 + S i)%nat with (S (i0 + i)).
  reflexivity.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; simpl.
repeat rewrite Rplus_assoc. reflexivity.
  cut (pred (N - i) = (N - S i)%nat).
  intro; rewrite H5; reflexivity.
  rewrite pred_of_minus.
  apply INR_eq.
  repeat rewrite minus_INR.
  repeat rewrite S_INR; simpl.
rewrite Rplus_0_l.
unfold Rminus.
rewrite Ropp_plus_distr.
repeat rewrite Rplus_assoc.
reflexivity.
  apply le_trans with (S (pred (pred N))).
  apply le_n_S; assumption.
  replace (S (pred (pred N))) with (pred N).
  apply le_pred_n.
  apply S_pred with 0%nat.
  apply lt_S_n.
  replace (S (pred N)) with N.
  apply lt_le_trans with 2%nat.
  apply lt_n_Sn.
  assumption.
  apply S_pred with 0%nat; assumption.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
  rewrite le_plus_minus_r.
  replace (i + 1)%nat with (S i).
  replace N with (S (pred N)).
  apply le_n_S.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_pred_n.
  symmetry ; apply S_pred with 0%nat; assumption.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl.
reflexivity.
  apply le_trans with (pred (pred N)).
  assumption.
  apply le_trans with (pred N); apply le_pred_n.
  apply sum_eq; intros.
  replace (i + 0)%nat with i; [ reflexivity | trivial ].
  apply lt_S_n.
  replace (S (pred N)) with N.
  apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
  apply S_pred with 0%nat; assumption.
  inversion H1.
  left; reflexivity.
  right; apply le_n_S; assumption.
  simpl.
  replace (S (pred N)) with N.
  reflexivity.
  apply S_pred with 0%nat; assumption.
  simpl.
  cut ((N - pred N)%nat = 1%nat).
  intro; rewrite H2; reflexivity.
  rewrite pred_of_minus.
  apply INR_eq; repeat rewrite minus_INR.
  simpl.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
  apply lt_le_S; assumption.
  rewrite <- pred_of_minus; apply le_pred_n.
  simpl; symmetry ; apply S_pred with 0%nat; assumption.
  inversion H.
  left; reflexivity.
  right; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | exact H1 ].
Qed.


Require Import Examples.AutoSep.

(** * Always-0 *)

Definition always0S res : spec := SPEC reserving res
  PRE[_] Emp
  POST[R] [| R = 0 |].

Definition always0 := bmodule "always0" {{
  bfunction "main"("f") [always0S 2]
    "f" <-- Lambda() [always0S 0]
      Return 0
    end;;

    "f" <-- ICall "f"()
    [PRE[_, R] [| R = 0 |]
     POST[R'] [| R' = 0 |] ];;
    Return "f"
  end
}}.

Hint Extern 1 (@eq W _ _) => words.

Theorem always0Ok : moduleOk always0.
  vcgen; abstract (post; try icall (@nil string); (sep_auto; auto)).
Qed.

(** * Add three numbers *)

Definition add3S : spec := SPEC("x", "y", "z") reserving 5
  PRE[V] Emp
  POST[R] [| R = V "x" ^+ V "y" ^+ V "z" |].

Definition addS : spec := SPEC("x", "y") reserving 0
  PRE[V] Emp
  POST[R] [| R = V "x" ^+ V "y" |].

Definition add3 := bmodule "add3" {{
  bfunction "add3"("x", "y", "z", "f", "tmp") [add3S]
    "f" <-- Lambda("x", "y") [addS]
      Return "x" + "y"
    end;;

    "tmp" <-- ICall "f"("x", "y")
    [PRE[V, R] Emp
     POST[R'] [| R' = R ^+ V "z" |]];;

    Return "tmp" + "z"
  end
}}.

Theorem add3Ok : moduleOk add3.
  vcgen; abstract (post; try icall ("x" :: "y" :: nil); (sep_auto; auto)).
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.theory.categories
  MathClasses.categories.varieties.
Require
  MathClasses.varieties.rings.

Section initial_maps.
  Variable A : Type.

  Class IntegersToRing :=
    integers_to_ring: ∀ R `{Mult R} `{Plus R} `{One R} `{Zero R} `{Negate R}, A → R.

  Context `{IntegersToRing} `{Ring A} `{∀ `{Ring B}, SemiRing_Morphism (integers_to_ring B)}.

  Global Instance integer_initial_arrow: InitialArrow (rings.object A).
   intro y.
   exists (λ u, match u return A → y u with tt => integers_to_ring (y tt) end).
   abstract (apply rings.encode_morphism_only; apply _).
  Defined. (* for some reason [Program] isn't cooperating here. look into it *)

  Lemma integer_initial (same_morphism : ∀ `{Ring B} {h :  A → B} `{!SemiRing_Morphism h}, integers_to_ring B = h) :
    Initial (rings.object A).
  Proof.
    intros y [x h] [] ?. simpl in *.
    apply same_morphism.
      apply rings.decode_variety_and_ops.
     apply (@rings.decode_morphism_and_ops _ _ _ _ _ _ _ _ _ h).
    reflexivity.
  Qed.
End initial_maps.

#[global]
Instance: Params (@integers_to_ring) 8 := {}.

Class Integers A {e plus mult zero one negate} `{U : IntegersToRing A} :=
  { integers_ring:> @Ring A e plus mult zero one negate
  ; integers_to_ring_mor:> ∀ `{Ring B}, SemiRing_Morphism (integers_to_ring A B)
  ; integers_initial:> Initial (rings.object A) }.

Section specializable.
  Context (Z N : Type) `{Integers Z} `{Naturals N}.

  Class IntAbs := int_abs_sig : ∀ x,
    { n : N | naturals_to_semiring N Z n = x } + { n : N | naturals_to_semiring N Z n = -x }.

  Definition int_abs `{ia : IntAbs} (x : Z) : N :=
    match int_abs_sig x with
    | inl (n↾_) => n
    | inr (n↾_) => n
    end.

  Definition int_to_nat `{Zero N} `{ia : IntAbs} (x : Z) : N :=
    match int_abs_sig x with
    | inl (n↾_) => n
    | inr (n↾_) => 0
    end.
End specializable.

#[global]
Instance: Params (@int_abs) 10 := {}.
#[global]
Instance: Params (@int_abs_sig) 10 := {}.
#[global]
Instance: Params (@int_to_nat) 11 := {}.


Require Import Axiom_Extensionality.
Require Import Axiom_ProofIrrelevance.
Require Import Cast.
Require Import JMEq.
Require Import Category3.

Lemma eq_Category3 : forall (c c':Category3) (p: A3 c = A3 c'),
    (forall f:A3 c, cast p (source3 c f) = source3 c' (cast p f)) ->
    (forall f:A3 c, cast p (target3 c f) = target3 c' (cast p f)) ->
    (forall f g:A3 c,
    cast (toOption p) (compose3 c f g) = compose3 c' (cast p f) (cast p g)) ->
    c = c'.
Proof.
    intros c1 c2 p Hs Ht Hc.
    destruct c1 as [A1 s1 t1 cmp1 pss1 pts1 ptt1 pst1 pd1 ps1 pt1 pl1 pr1 pa1].
    destruct c2 as [A2 s2 t2 cmp2 pss2 pts2 ptt2 pst2 pd2 ps2 pt2 pl2 pr2 pa2].
    simpl in p. simpl in Hs. simpl in Ht. simpl in Hc.
    revert pss1 pts1 ptt1 pst1 pd1 ps1 pt1 pl1 pr1 pa1.
    revert Hs Ht Hc. revert s1 t1 cmp1.
    rewrite p.
    intros s1 t1 cmp1 Hs Ht Hc.
    simpl in Hs. simpl in Ht. simpl in Hc.
    rewrite (proof_irrelevance _ (toOption eq_refl) eq_refl) in Hc. simpl in Hc.
    apply extensionality in Hs.
    apply extensionality in Ht.
    apply extensionality2 in Hc.
    rewrite Hs, Ht, Hc.
    intros pss1 pts1 ptt1 pst1 pd1 ps1 pt1 pl1 pr1 pa1.
    rewrite (proof_irrelevance _ pss1 pss2).
    rewrite (proof_irrelevance _ pts1 pts2).
    rewrite (proof_irrelevance _ ptt1 ptt2).
    rewrite (proof_irrelevance _ pst1 pst2).
    rewrite (proof_irrelevance _ pd1 pd2).
    rewrite (proof_irrelevance _ ps1 ps2).
    rewrite (proof_irrelevance _ pt1 pt2).
    rewrite (proof_irrelevance _ pl1 pl2).
    rewrite (proof_irrelevance _ pr1 pr2).
    rewrite (proof_irrelevance _ pa1 pa2).
    reflexivity.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(* Jean-Francois.Monin@lannion.cnet.fr                                      *)
(* January 1995, Coq V5.10                                                  *)
(*                                                                          *)
(****************************************************************************)
(*                                Naccu_cc.v                                *)
(****************************************************************************)

Require Import tests.
Require Import specif.
Require Import cps_N.

Section algocc.

Load "DeclareN".

Let T_aux (m n : nat) := {n' : nat | n = n' &  ~ m <= n'}.

Ltac Split_condsum c1 c2 c3 := intros s; elim s; clear s; intros c1 c2 c3.

Theorem ex_deb_cc_V1 : forall (m : nat) (t : tree), N (RESU m t).
intros m t.
Ncallcc ipattern:(c).
Napply (condsum_accu m 0 t).
  intro s_cond; elim s_cond; intros n Hnt Hmn.
  Nunit; refine (exres _ _ false _); auto.
  apply Sf; generalize Hmn; rewrite Hnt; auto.

  cut (forall n : nat, (m <= n -> P_overweight_accu m 0 t) -> N (T_aux m n)).
    intro g.

    cut
     (forall a : nat,
      (P_overweight_accu m a t -> P_overweight_accu m 0 t) ->
      N (condsum_accu m a t));
     [ intro comprec; apply comprec; intro Hd; apply Hd | idtac ].

     pattern t at 1 3 in |- *; elim t.
       intros n a e.
       Napplift (g (a + n));
        [ intro sn;
           refine (let (b, _, _) := sn in condsum_accu_intro _ _ _ b _ _);
           auto
        | auto ].

      Hint Resolve deb_left_accu_plus deb_right_accu_plus deb_accu_plus_r.
       intros t1 R1 t2 R2 a e.
       Napply (condsum_accu m a t1);
        [ Split_condsum ipattern:(an1) ipattern:(Han1t1) ipattern:(Hman1)
        | apply R1; auto ].
       Napply (condsum_accu m an1 t2);
        [ Split_condsum ipattern:(an) ipattern:(Hant2) ipattern:(Hmn)
        | apply R2; rewrite Han1t1; auto ].
       Nunit; refine (condsum_accu_intro _ _ _ an _ _); auto.
       rewrite Hant2; rewrite Han1t1; rewrite plus_assoc_reverse;
        auto.

     (* definition de g *)

     intros n e.
     case (le_dec m n).
       intro le_mn; Nthrow c; Nunit; refine (exres _ _ true _); auto.
          apply St; cut (P_overweight_accu m 0 t); auto.

       intro Nle_mn; Nunit; refine (exist2 _ _ n _ _); auto.
Qed.

End algocc.
(* -------------------- *)

Theorem F_overweight_accu_cc : forall (m : nat) (t : tree), RESU m t.
  intros m t; apply (ex_deb_cc_V1 (RESU m t) m t).
  intro x; exact x.
Qed.


(* Theorems about high level protocol *)

Require Import Program Arith CpdtTactics High_def.

Definition agree' (bi : option bool) (bj : option bool) : Prop :=
  match bi, bj with
  | Some bi, Some bj => bi = bj
  | _, _ => True
  end.

Definition agree (gs : HGlobalState) : Prop := forall i j, agree' (Hextract gs i) (Hextract gs j).

Record HInitialParams := HInitP {h_inputs : nat -> bool; h_n : nat}.

Definition HinitLS (b : bool) :=
  HHonest b None.

Definition HinitGS (params : HInitialParams) :=
  let input := h_inputs params in
  let n := h_n params in
  HGS n (fun i => if (i <? n) then Some (HinitLS (input i)) else None).

Definition HisValid (params : HInitialParams) (gs : HGlobalState) :=
  HSteps (HinitGS params) gs.

Lemma Hextract_agree : forall gs b, (exists i, Hextract gs i = Some b) -> agree gs -> (forall i, agree' (Hextract gs i) (Some b)).
Proof.
  intros.
  inversion H.
  clear H.
  unfold agree in H0.
  specialize (H0 i x).
  rewrite H1 in H0.
  auto.
Qed.

Lemma agree_same_or_none : forall b' b, agree' (b') (Some b) -> b' = None \/ b' = Some b.
Proof.
  intros.
  destruct b'.
  right.
  inversion H.
  auto.
  left.
  auto.
Qed.

Lemma Hextract_agree_same_or_none : forall gs b, (exists i, Hextract gs i = Some b) -> agree gs -> (forall i, (Hextract gs i) = None \/ (Hextract gs i) = Some b).
Proof.
  intros.
  apply agree_same_or_none.
  apply Hextract_agree ; auto.
Qed.

Lemma HStep_keeps_agreement : forall gs gs', HStep gs gs' -> agree gs -> agree gs'.
Proof.
  intros.
  inversion H.
  - subst ; auto.
  - subst.
    inversion H1.
    clear H1.
    unfold agree.
    destruct gs'.
    destruct gs.
    intros.
    unfold Hstep_decide in H3.
    inversion H3.
    subst.
    unfold agree in H0.
    specialize (H0 i0 j).
    clear H H3.
    unfold Hextract.
    remember (i0 <? hg_n0) as inrange_i0.
    remember (j <? hg_n0) as inrange_j.
    destruct (inrange_i0) ; unfold agree'; auto.
    destruct (inrange_j).
    + remember (i0 =? i) as isi_i0.
      remember (j =? i) as isi_j.
      destruct (isi_i0).
      destruct (isi_j).
      * remember (Hextract_loc match h_localstates0 i with
                   | Some ls => Some (Hstep_decide_loc ls b)
                   | None => None
                   end) as hi.
        destruct hi ; auto.
      * remember (Hextract_loc match h_localstates0 i with
                   | Some ls => Some (Hstep_decide_loc ls b)
                   | None => None
                   end) as hi.
        specialize (H2 j).
        simpl in H2.
        rewrite <- Heqinrange_j in H2.
        rewrite H2.
        destruct hi ; auto.
      * specialize (H2 i0).
        simpl in H2.
        rewrite <- Heqinrange_i0 in H2.
        rewrite H2.
        auto.
    + destruct (Hextract_loc (if i0 =? i then match h_localstates0 i with
                                    | Some ls => Some (Hstep_decide_loc ls b)
                                    | None => None
                                    end else h_localstates0 i0)) ; auto.
  - subst.
    specialize (Hextract_agree_same_or_none gs b).
    inversion H1.
    clear H1.
    intros.
    unfold agree.
    intros.
    assert (Hextract gs i0 = None \/ Hextract gs i0 = Some b).
    crush.
    assert (Hextract gs j = None \/ Hextract gs j = Some b).
    crush.
    destruct gs.
    destruct gs'.
    intros.
    unfold agree.
    unfold Hstep_decide in H3.
    inversion H3.
    subst.
    clear H H3.
    unfold Hextract.
    unfold Hextract in H4.
    unfold Hextract in H5.
    intros.
    remember hg_n as n.
    remember h_localstates as localstates.
    remember (i0 <? n) as inrange_i0.
    remember (j <? n) as inrange_j.
    destruct (inrange_i0) ; unfold agree'; auto.
    destruct (inrange_j).
    + remember (i0 =? i) as isi_i0.
      remember (j =? i) as isi_j.
      destruct (isi_i0).
      destruct (isi_j).
      * remember (Hextract_loc match localstates i with
                   | Some ls => Some (Hstep_decide_loc ls b)
                   | None => None
                   end) as hi.
        destruct hi ; auto.
      * remember (Hextract_loc match localstates i with
                   | Some ls => Some (Hstep_decide_loc ls b)
                   | None => None
                   end) as hi.
        inversion H5.
        { rewrite H. destruct hi ; auto. }
        { rewrite H.
          specialize (beq_nat_true i0 i).
          intros.
          rewrite <- H3 in Heqhi.
          inversion H4.
          unfold Hextract_loc in H6.
          destruct (localstates i0).
          simpl in Heqhi.
          destruct h.
          simpl in Heqhi.
          rewrite Heqhi ; auto.
          simpl in Heqhi.
          rewrite Heqhi.
          auto.
          unfold Hextract_loc in H6.
          destruct (localstates i0).
          destruct h.
          simpl in Heqhi.
          rewrite Heqhi ; auto.
          inversion H6.
          rewrite <- Heqisi_i0.
          auto. }
      * inversion H4.
        rewrite H. auto.
        rewrite H.
        destruct (isi_j).
        { destruct (localstates i).
          simpl.
          destruct h.
          simpl.
          auto.
          simpl.
          auto. }
        { inversion H5 ; rewrite H3 ; auto. }
    + destruct (Hextract_loc (if i0 =? i then match localstates i with
                                    | Some ls => Some (Hstep_decide_loc ls b)
                                    | None => None
                                    end else localstates i0)) ; auto.
Qed.

Theorem HSteps_keeps_agreement : forall gs gs', HSteps gs gs' -> agree gs -> agree gs'.
Proof.
  intros.
  induction H.
  - apply (HStep_keeps_agreement gs gs' H H0).
  - specialize (IHHSteps H0).
    apply (HStep_keeps_agreement gs' gs'' H1 IHHSteps).
Qed.

Theorem HinitGS_keeps_agreement : forall input n0, agree (HinitGS (HInitP input n0)).
Proof.
  intros.
  unfold HinitGS.
  unfold agree.
  intros.
  simpl.
  destruct (i <? n0) ; destruct (j <? n0) ; unfold agree' ; unfold HinitLS ; unfold Hextract_loc ; auto.
Qed.

Theorem HAgreement : forall params gs, HisValid params gs -> agree gs.
Proof.
  intros.
  apply (HSteps_keeps_agreement (HinitGS params) gs H).
  apply HinitGS_keeps_agreement.
Qed.


Require Import Word.

Open Scope word_scope.

Goal forall w1 w2 w3 w4 : word 32,
  w1 & (w2 | ~w3 & w4) == (w2 | ~w3) & (w4 & w1 | w1 & w2).
Proof.
  weq_bool.
Qed.

Goal forall w : word 32, w | ~wfalse 32 == ~(w & ~w).
Proof.
  weq_bool.
Qed.

Goal forall w1 w2 w3 : word 32, ~ (w2 == w3) ->
  w1 & ~(wof_N 32 1 << w2) & (wof_N 32 1 << w3) == w1 & (wof_N 32 1 << w3).
Proof.
  weq_bool. wand_1_wshl_weqf w2 w3. assumption.
Qed.

Module Word32 : Word with Definition n := 32.
Definition n : nat := 32.
End Word32.

Module RingWord32 := RingWord Word32.
Import RingWord32.

Goal forall w1 w2 w3 w4 : word 32,
  (w1 + w3 - w2 * w4) * w4 + w1 ==
  (w4 + wof_N 32 1) * w1 - w4 * w2 * w4 + w4 * w3.
Proof.
  intros. change 32 with Word32.n; ring.
Qed.


Set  Implicit Arguments.
Unset Strict Implicit.

Require Import QArith.

(*Avoid clash with Ssreflect*)
Delimit Scope Q_scope with coq_Qscope.
Definition Qcoq := Q.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
Import GRing.Theory Num.Def Num.Theory.

Require Import OUVerT.numerics combinators games
        compile OUVerT.orderedtypes OUVerT.dyadic.
Require Import lightserver staging.

(** Topology:

            r0: x
          ----------
         /  r1: 10x \
    SRC 0 ---------- 1 SNK
         \          /
          ----------
            r2: x
 *)

Local Open Scope ring_scope.

(*Operational type classes mean we can't forget to declare the following instances:*)
Instance r1_scalar : ScalarClass rat_realFieldType := 10%:R.
Instance r1_scalarAxiom : ScalarAxiomClass r1_scalar. Proof. by []. Qed.

(*Here's the base type corresponding to the topology above:*)
Definition base :=
  ([finType of resource] *
   scalarType scalar_val [finType of resource] *
   [finType of resource])%type.

(*The following predicate limits the valid strategies to r0, r1, or r2:*)
Instance base_predClass : PredClass base :=
  fun b =>
    match b with
    | (RYes,Wrap RNo,RNo) => true
    | (RNo,Wrap RYes,RNo) => true
    | (RNo,Wrap RNo,RYes) => true
    | _ => false
    end.

(*Type t wraps base in a sigma type over predicate base_predClass:*)
Definition t := [finType of {b : base | the_pred b}].

(*(*Typeclass resolution regression stack*)
Variable f : {ffun 'I_10 -> base}.
Variable i : 'I_10.
Check (cost) i f : rat.
Instance _1 : CostClass 10 rat_realFieldType [finType of base] := _.
Instance _2 : CostAxiomClass (cN:=10) (rty:=rat_realFieldType) (cT:=[finType of base]) _1 := _.
Instance _3 : @game [finType of base] 10 rat_realFieldType _1 _ _ _ := _.
Require Import smooth.
Instance _4 : @smooth [finType of base] 10 rat_realFieldType _1 _ _ _ _ _ _ _ _ := _.*)

Require Import smooth.

(*Game t is (5/3,1/3)-smooth:*)
Lemma t_smooth N (x x' : {ffun 'I_N -> t}) (i : 'I_N) :
  \sum_(i < N) (cost) i ((upd i x) x') <=
  (Q_to_rat (5#3)%Q * Cost x' + Q_to_rat (1#3)%Q * Cost x)%R.
Proof.
  have H:
    \sum_(i < N) (cost) i ((upd i x) x') <= (lambda of t * Cost x' + mu of t * Cost x)%R
    by apply: smoothness_axiom.
  have H1: lambda of t = Q_to_rat (5 # 3)%Q by [].
  have H2: mu of t = Q_to_rat (1 # 3)%Q by [].
  rewrite H1 H2 in H.
  apply: H.
Qed.


Require Export SO_syntax.

Fixpoint conjSO_exFO_relatSO alpha : bool :=
  match alpha with
    predSO _ _ => true
  | relatSO _ _ => true
  | eqFO _ _ => false
  | allFO _ _ => false
  | exFO x beta => conjSO_exFO_relatSO beta
  | negSO _ => false
  | conjSO beta1 beta2 =>
    if conjSO_exFO_relatSO beta1 then conjSO_exFO_relatSO beta2 else false
  | disjSO _ _ => false
  | implSO _ _ => false
  | allSO _ _ => false
  | exSO _ _ => false
  end.


Require Import QArith.
Require Import ZNatPairs.

(**
    encode(k1, k2) = (k1 + k2) * (k1 + k2 + 1) / 2 + k2
**)

Definition encode (k : (nat * nat)) : Q :=
1.

(**
    decode(z):
        w = floor ( (sqrt(8z + 1) - 1) / 2
        t = (w^2 + w) / 2
        y = z - t
        x = w - y
        return <x, y>
**)

Definition decode (z : Q) : (nat * nat) :=
(O, O).

Theorem decode_encode : forall x y ,
    decode (encode (x, y)) = (x, y).

Theorem encode_decode : forall z ,
    encode (decode z) = z.


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


From Flocq Require Import Bits.
Require Import Byte.
Require Import BinNums ZArith.BinInt.

(* TODO: this to circumvent Flocq's "binary" representation of floats *)

Definition Z_of_byte (b : byte) : Z :=
  let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, b8))))))) := Byte.to_bits b in
  let inj (b : bool) := if b then Z.one else Z.zero in
  Zplus (inj b1) (Z.mul 256 (
  Zplus (inj b1) (Z.mul 256 (
  Zplus (inj b3) (Z.mul 256 (
  Zplus (inj b4) (Z.mul 256 (
  Zplus (inj b5) (Z.mul 256 (
  Zplus (inj b6) (Z.mul 256 (
  Zplus (inj b7) (Z.mul 256 (
  (inj b8))))))))))))))).

(* little endian *)
Fixpoint Z_of_bytes_aux (acc : Z) (factor : Z) (bs : list byte) :=
  match bs with
  | nil => acc
  | cons b bs' => Z_of_bytes_aux (Z.add acc (Z.mul factor (Z_of_byte b))) (Zplus 256 factor) bs'
  end.

Definition Z_of_bytes (bs : list byte) :=
  Z_of_bytes_aux Z.zero Z.one bs.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     bicategory.adjoint
     bicategory.equivalence.

Definition representable_faithful
           {C : BiCategory}
           {X Y Z : C}
           {f : C⟦X,Y⟧} {g : C⟦Y,X⟧}
           (η : id₁ X ==> g · f)
           (k₁ k₂ : C⟦Z,X⟧)
           (α β : k₁ ==> k₂)
           `{IsIsomorphism _ _ _ η}
  : f ◅ α = f ◅ β -> α = β.
Proof.
  intros Hαβ.
  rewrite (whisker_l_iso_id₁ η _ _ α).
  rewrite (whisker_l_iso_id₁ η _ _ β).
  rewrite (whisker_l_eq k₁ k₂ α β Hαβ).
  reflexivity.
Qed.

Definition representable_full
           {C : BiCategory}
           {X Y Z : C}
           {f : C⟦X,Y⟧} {g : C⟦Y,X⟧}
           (η : id₁ X ==> g · f)
           (θ : f · g ==> id₁ Y)
           `{IsIsomorphism _ _ _ η}
           (k₁ k₂ : C⟦Z,X⟧)
           (α : f · k₁ ==> f · k₂)
  : k₁ ==> k₂.
Proof.
  refine (_ ∘ left_unit_inv _).
  refine (_ ∘ η ▻ _).
  refine (_ ∘ assoc _ _ _).
  refine (_ ∘ g ◅ α).
  refine (_ ∘ assoc_inv _ _ _).
  refine (_ ∘ (η^-1)%bicategory ▻ k₂).
  apply left_unit.
Defined.

Definition full_spec
           {C : BiCategory}
           {X Y Z : C}
           {f : C⟦X,Y⟧} {g : C⟦Y,X⟧}
           (η : id₁ X ==> g · f)
           (θ : f · g ==> id₁ Y)
           `{IsIsomorphism _ _ _ η}
           `{IsIsomorphism _ _ _ θ}
           (k₁ k₂ : C⟦Z,X⟧)
           (α : f · k₁ ==> f · k₂)
  : f ◅ (representable_full η θ k₁ k₂ α) = α.
Proof.
  refine (representable_faithful (θ^-1)%bicategory (f · k₁) (f · k₂) _ α _).
  apply (vcomp_cancel_right (assoc _ _ _) _ _).
  rewrite <- whisker_l_hcomp.
  apply (vcomp_cancel_left (assoc_inv _ _ _) _ _).
  rewrite <- !vcomp_assoc.
  rewrite assoc_right, vcomp_left_identity.
  apply (vcomp_cancel_left (η^-1%bicategory ▻ k₂) _ _).
  apply (vcomp_cancel_left (left_unit k₂) _ _).
  apply (vcomp_cancel_right (η ▻ k₁) _ _).
  apply (vcomp_cancel_right (left_unit_inv k₁) _ _).
  rewrite <- !vcomp_assoc.
  rewrite <- whisker_l_iso_id₁.
  reflexivity.
Qed.

Section EquivToAdjEquiv.
  Context `{Funext}
          {C : BiCategory}
          {X Y : C}.
  Variable (f : C⟦X,Y⟧)
           (Hf : is_equivalence f).

  Local Definition g : C⟦Y,X⟧ := equiv_inv Hf.
  Local Definition η : id₁ X ==> g · f := (sect f Hf)^-1%bicategory.
  Local Definition θ : f · g ==> id₁ Y := retr f Hf.

  Local Definition ε : f · g ==> id₁ Y.
  Proof.
    apply (representable_full θ^-1%bicategory η^-1%bicategory).
    exact ((right_unit_inv g)
             ∘ left_unit g
             ∘ η^-1%bicategory ▻ g
             ∘ assoc_inv _ _ _).
  Defined.

  Definition equiv_to_adjequiv_d : is_left_adjoint_d f.
  Proof.
    make_is_left_adjoint.
    - exact (equiv_inv Hf).
    - exact (sect f Hf)^-1.
    - exact ε.
  Defined.

  Local Definition first_triangle_law
    : (right_unit g)
        ∘ g ◅ ε
        ∘ assoc g f g
        ∘ η ▻ g
        ∘ left_unit_inv _
      = id₂ g.
  Proof.
    rewrite !vcomp_assoc.
    rewrite (full_spec _ _ _ _ _).
    rewrite <- !vcomp_assoc.
    rewrite right_unit_left, vcomp_left_identity.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
    rewrite assoc_right, vcomp_left_identity.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite <- interchange.
    rewrite !vcomp_right_identity ; simpl.
    rewrite vcomp_right_inverse.
    rewrite hcomp_id₂.
    rewrite vcomp_left_identity.
    rewrite left_unit_left.
    reflexivity.
  Qed.

  Definition whisker_ηg
    : η ▻ g = (right_unit g ∘ g ◅ ε ∘ assoc g f g)^-1%bicategory ∘ left_unit g.
  Proof.
    refine (vcomp_move_L_Mp _ _ _ _).
    rewrite <- (vcomp_left_identity (left_unit g)).
    refine (vcomp_move_L_pM _ _ _ _).
    apply first_triangle_law.
  Qed.

  Local Definition η_natural
    : η ▻ (g · f) ∘ left_unit_inv (g · f) ∘ η
      =
      (g · f) ◅ η ∘ right_unit_inv (g · f) ∘ η.
  Proof.
    unfold bc_whisker_l, bc_whisker_r.
    rewrite !vcomp_assoc.
    rewrite left_unit_inv_natural, right_unit_inv_natural.
    rewrite <- !vcomp_assoc.
    rewrite <- !interchange.
    rewrite !vcomp_right_identity, !vcomp_left_identity.
    rewrite right_unit_V_id_is_left_unit_V_id.
    reflexivity.
  Qed.

  Local Definition η_natural_help
    : η ▻ (g · f) ∘ left_unit_inv (g · f)
      =
      (g · f) ◅ η ∘ right_unit_inv (g · f)
    := vcomp_cancel_right η _ _ η_natural.

  Local Definition η_whisker_l_hcomp
    : (g · f) ◅ η = assoc_inv g f (g · f) ∘ g ◅ (f ◅ η) ∘ assoc g f (id₁ X).
  Proof.
    rewrite !vcomp_assoc.
    refine (vcomp_move_L_Mp _ _ _ _) ; simpl.
    unfold bc_whisker_l.
    rewrite <- hcomp_id₂.
    rewrite assoc_natural.
    reflexivity.
  Qed.

  Local Definition η_whisker_r_hcomp
    : η ▻ (g · f) = assoc (g · f) g f ∘ η ▻ g ▻ f ∘ assoc_inv (id₁ X) g f.
  Proof.
    refine (vcomp_move_L_pM _ _ _ _) ; simpl.
    rewrite assoc_natural.
    rewrite hcomp_id₂.
    reflexivity.
  Qed.

  Local Definition help1
    : assoc (g · f) g f ∘ (η ▻ g ∘ left_unit_inv _) ▻ f
      =
      (assoc_inv g f (g · f))
        ∘ g ◅ (f ◅ η)
        ∘ assoc g f (id₁ X)
        ∘ right_unit_inv (g · f).
  Proof.
    rewrite <- η_whisker_l_hcomp.
    rewrite bc_whisker_r_compose.
    rewrite left_unit_inv_assoc.
    rewrite <- !vcomp_assoc.
    rewrite assoc_natural.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite assoc_left, vcomp_left_identity.
    rewrite hcomp_id₂.
    exact η_natural_help.
  Qed.

  Local Definition help2
    : g ◅ (assoc f g f ∘ ε^-1%bicategory ▻ f ∘ left_unit_inv _)
      =
      g ◅ (f ◅ η ∘ right_unit_inv f).
  Proof.
    rewrite !bc_whisker_l_compose.
    rewrite !vcomp_assoc.
    unfold bc_whisker_l.
    rewrite <- triangle_l_inv.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite <- assoc_natural.
    pose help1 as p.
    rewrite whisker_ηg in p.
    rewrite !vcomp_inverse in p.
    rewrite !vcomp_assoc in p.
    rewrite left_unit_left, vcomp_right_identity in p.
    rewrite !bc_whisker_r_compose in p.
    rewrite <- !vcomp_assoc in p.
    rewrite right_unit_inv_assoc in p.
    rewrite !vcomp_assoc in p.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^) in p.
    rewrite assoc_left, vcomp_left_identity in p.
    rewrite <- bc_whisker_l_compose in p.
    rewrite <- !vcomp_assoc in p.
    rewrite inverse_pentagon_5 in p.
    rewrite !vcomp_assoc in p.
    refine (vcomp_cancel_left (assoc_inv g f (g · f)) _ _ _).
    rewrite !vcomp_assoc.
    rewrite <- !bc_whisker_l_compose.
    exact p.
  Qed.

  Local Definition help3
    : assoc f g f ∘ ε^-1%bicategory ▻ f ∘ left_unit_inv f
      =
      f ◅ η ∘ right_unit_inv f.
  Proof.
    unshelve refine (representable_faithful _ _ _ _ _ help2).
    apply (equivalence_inv (Build_Equivalence f Hf)).
  Qed.

  Definition equiv_to_adjequiv_isadj : is_adjunction equiv_to_adjequiv_d.
  Proof.
    make_is_adjunction ; cbn.
    - exact first_triangle_law.
    - rewrite !vcomp_assoc.
      rewrite <- help3.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
      rewrite assoc_right, vcomp_left_identity.
      rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite <- bc_whisker_r_compose.
      rewrite vcomp_right_inverse.
      unfold bc_whisker_r.
      rewrite hcomp_id₂, vcomp_left_identity.
      rewrite left_unit_left.
      reflexivity.
  Defined.

  Definition equiv_to_adjequiv_left_adj : is_left_adjoint f
    := Build_is_left_adjoint equiv_to_adjequiv_d equiv_to_adjequiv_isadj.

  Definition equiv_to_adjequiv
    : X ≃ Y
    := Build_adjoint_equivalence equiv_to_adjequiv_left_adj _ _.
End EquivToAdjEquiv.

Definition comp_adjequiv
           `{Funext}
           {C : BiCategory}
           {X Y Z : C}
  : X ≃ Y -> Y ≃ Z -> X ≃ Z
  := fun f₁ f₂ => equiv_to_adjequiv (f₂ · f₁) (comp_isequiv f₂ f₁).


(**
We determine that the path space of the torus
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.NumberSystems.Integers.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.

Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import algebra.groupoid_polynomials.
Require Import algebra.groupoid_endpoints.
Require Import algebra.groupoid_homotopies.
Require Import displayed_algebras.displayed_algebra.
Require Import initial_grpd_alg.W_poly.
Require Import initial_grpd_alg.initial_groupoid_algebra.
Require Import initial_grpd_alg.is_initial.
Require Import existence.hit_existence.
Require Import examples.torus.

Require Import fundamental_groups.loops.

Local Open Scope cat.

(**
Initial groupoid algebra for the torus constructed in a special way.
We will use this conclude that the fundamental group of the circle is the integers
 *)
Definition torus_initial_algebra_precategory_data
  : precategory_data.
Proof.
  use make_precategory_data.
  - use make_precategory_ob_mor.
    + exact unit.
    + exact (λ _ _, hz × hz).
  - exact (λ _, hzzero ,, hzzero).
  - exact (λ _ _ _ x y, (hzplus (pr1 x) (pr1 y) ,, hzplus (pr2 x) (pr2 y))).
Defined.

Definition torus_initial_algebra_is_precategory
  : is_precategory torus_initial_algebra_precategory_data.
Proof.
  use make_is_precategory.
  - intros ; apply pathsdirprod ; apply hzplusl0.
  - intros ; apply pathsdirprod ; apply hzplusr0.
  - intros ; apply pathsdirprod ; refine (!_) ; apply hzplusassoc.
  - intros ; apply pathsdirprod ; apply hzplusassoc.
Qed.

Definition torus_initial_algebra_precategory
  : precategory.
Proof.
  use make_precategory.
  - exact torus_initial_algebra_precategory_data.
  - exact torus_initial_algebra_is_precategory.
Defined.

Definition torus_initial_algebra_homsets
  : has_homsets torus_initial_algebra_precategory.
Proof.
  intros x y.
  apply isasetdirprod ; apply isasetsetquot.
Qed.

Definition torus_initial_algebra_category
  : category.
Proof.
  use make_category.
  - exact torus_initial_algebra_precategory.
  - exact torus_initial_algebra_homsets.
Defined.

Definition torus_initial_algebra_is_pregroupoid
  : is_pregroupoid torus_initial_algebra_category.
Proof.
  intros tt1 tt2 z.
  use make_is_z_isomorphism.
  - exact (hzsign (pr1 z) ,, hzsign (pr2 z)).
  - split.
    + apply pathsdirprod ; apply hzrminus.
    + apply pathsdirprod ; apply hzlminus.
Defined.

Definition torus_initial_algebra_carrier
  : groupoid.
Proof.
  use make_groupoid.
  - exact torus_initial_algebra_category.
  - exact torus_initial_algebra_is_pregroupoid.
Defined.

(** It forms a groupoid algebra *)
Definition torus_initial_algebra_base_data
  : functor_data
      (⦃ point_constr torus_signature ⦄ torus_initial_algebra_carrier : groupoid)
      (torus_initial_algebra_carrier).
Proof.
  use make_functor_data.
  - exact (λ x, x).
  - exact (λ _ _ _, hzzero ,, hzzero).
Defined.

Definition torus_initial_algebra_base_is_functor
  : is_functor torus_initial_algebra_base_data.
Proof.
  split.
  - exact (λ _, idpath _).
  - intro ; intros ; apply pathsdirprod ; refine (!_) ; apply hzplusr0.
Qed.

Definition torus_initial_algebra_base
  : (⦃ point_constr torus_signature ⦄ torus_initial_algebra_carrier : groupoid)
    ⟶
    torus_initial_algebra_carrier.
Proof.
  use make_functor.
  - exact torus_initial_algebra_base_data.
  - exact torus_initial_algebra_base_is_functor.
Defined.

Definition torus_initial_prealgebra
  : hit_prealgebra_grpd torus_signature.
Proof.
  use make_hit_prealgebra_grpd.
  - exact torus_initial_algebra_carrier.
  - exact torus_initial_algebra_base.
Defined.

Definition circle_initial_algebra_loop_l_data
  : nat_trans_data
      (sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra)
      (sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra)
  := λ _, hzone ,, hzzero.

Definition circle_initial_algebra_loop_l_is_nat_trans
  : is_nat_trans
      _ _
      circle_initial_algebra_loop_l_data.
Proof.
  intro ; intros.
  apply pathsdirprod ; refine (hzplusl0 _ @ !(hzplusr0 _)).
Qed.

Definition torus_initial_algebra_loop_l
  : sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra
    ⟹
    sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra.
Proof.
  use make_nat_trans.
  - exact circle_initial_algebra_loop_l_data.
  - exact circle_initial_algebra_loop_l_is_nat_trans.
Defined.

Definition circle_initial_algebra_loop_r_data
  : nat_trans_data
      (sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra)
      (sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra)
  := λ _, hzzero ,, hzone.

Definition circle_initial_algebra_loop_r_is_nat_trans
  : is_nat_trans
      _ _
      circle_initial_algebra_loop_r_data.
Proof.
  intro ; intros.
  apply pathsdirprod ; refine (hzplusl0 _ @ !(hzplusr0 _)).
Qed.

Definition torus_initial_algebra_loop_r
  : sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra
    ⟹
    sem_endpoint_grpd_data_functor_data constr torus_initial_prealgebra.
Proof.
  use make_nat_trans.
  - exact circle_initial_algebra_loop_r_data.
  - exact circle_initial_algebra_loop_r_is_nat_trans.
Defined.

Definition torus_initial_path_algebra
  : hit_path_algebra_grpd torus_signature.
Proof.
  use make_hit_path_algebra_grpd.
  - exact torus_initial_prealgebra.
  - intro j.
    induction j.
    + exact torus_initial_algebra_loop_l.
    + exact torus_initial_algebra_loop_r.
Defined.

Definition torus_initial_algebra
  : hit_algebra_grpd torus_signature.
Proof.
  use make_algebra_grpd.
  - exact torus_initial_path_algebra.
  - abstract (intros j z p ; apply idpath).
Defined.

(** The UMP for 1-cells *)
Local Notation "f ^ z" := (morph_power f z).

Section TorusInitialAlgUMPOne.
  Variable (G : hit_algebra_grpd torus_signature).

  Local Notation "'Gl'" := (pr1 (alg_path_grpd G p_left) tt).
  Local Notation "'Gr'" := (pr1 (alg_path_grpd G p_right) tt).

  Definition torus_initial_algebra_ump_1_carrier_data_0
    : alg_carrier_grpd G
    := alg_constr_grpd G tt.

  Definition torus_initial_algebra_ump_1_carrier_data_1
             (z : hz × hz)
    : alg_carrier_grpd G ⟦ torus_initial_algebra_ump_1_carrier_data_0 ,
                           torus_initial_algebra_ump_1_carrier_data_0 ⟧
    := double_power Gl Gr (pr1 z) (pr2 z).

  Definition torus_initial_algebra_ump_1_carrier_data
    : functor_data
        torus_initial_algebra_precategory_data
        (alg_carrier_grpd G).
  Proof.
    use make_functor_data.
    - exact (λ _, torus_initial_algebra_ump_1_carrier_data_0).
    - exact (λ _ _, torus_initial_algebra_ump_1_carrier_data_1).
  Defined.

  Definition torus_initial_algebra_ump_1_carrier_is_functor
    : is_functor torus_initial_algebra_ump_1_carrier_data.
  Proof.
    split.
    - intro.
      simpl.
      cbn -[hz].
      apply id_right.
    - intros ? ? ?.
      cbn -[hz] ; unfold torus_initial_algebra_ump_1_carrier_data_1.
      intros f g.
      etrans.
      {
        apply maponpaths_2.
        exact (morph_power_plus Gl (pr1 f) (pr1 g)).
      }
      etrans.
      {
        apply maponpaths.
        exact (morph_power_plus Gr (pr2 f) (pr2 g)).
      }
      refine (assoc' _ _ _ @ _ @ assoc _ _ _).
      apply maponpaths.
      refine (assoc _ _ _ @ _ @ assoc' _ _ _).
      apply maponpaths_2.
      refine (power_commute Gl Gr _ (pr1 g) (pr2 f)).
      exact (alg_homot_grpd G com tt (idpath _)).
  Qed.

  Definition torus_initial_algebra_ump_1_carrier
    : torus_initial_algebra_carrier ⟶ alg_carrier_grpd G.
  Proof.
    use make_functor.
    - exact torus_initial_algebra_ump_1_carrier_data.
    - exact torus_initial_algebra_ump_1_carrier_is_functor.
  Defined.

  Definition torus_initial_algebra_ump_1_commute_data
    : nat_trans_data
        (functor_composite_data
           torus_initial_algebra_base_data
           torus_initial_algebra_ump_1_carrier_data)
        (functor_composite_data
           (poly_act_functor
              torus_point_constr
              torus_initial_algebra_ump_1_carrier)
           (alg_constr_grpd G)).
  Proof.
    intros x.
    induction x ; simpl.
    apply id₁.
  Defined.

  Definition torus_initial_algebra_ump_1_commute_is_nat_trans
    : is_nat_trans
        _ _
        torus_initial_algebra_ump_1_commute_data.
  Proof.
    intros x y f.
    induction x, y.
    simpl.
    cbn.
    rewrite !id_left.
    assert (f = idpath _) as p.
    { apply isapropunit. }
    rewrite p.
    exact (!(functor_id (alg_constr_grpd G : _ ⟶ _) _)).
  Qed.

  Definition torus_initial_algebra_ump_1_commute
    : functor_composite_data
        torus_initial_algebra_base_data
        torus_initial_algebra_ump_1_carrier_data
      ⟹
      functor_composite_data
        (poly_act_functor
           torus_point_constr
           torus_initial_algebra_ump_1_carrier)
        (alg_constr_grpd G).
  Proof.
    use make_nat_trans.
    - exact torus_initial_algebra_ump_1_commute_data.
    - exact torus_initial_algebra_ump_1_commute_is_nat_trans.
  Defined.

  Definition torus_initial_prealgebra_ump_1
    : pr11 torus_initial_algebra --> pr11 G.
  Proof.
    use make_hit_prealgebra_mor.
    - exact torus_initial_algebra_ump_1_carrier.
    - exact torus_initial_algebra_ump_1_commute.
  Defined.

  Definition torus_initial_algebra_ump_1
    : torus_initial_algebra --> G.
  Proof.
    use make_algebra_map_grpd.
    use make_hit_path_alg_map_grpd.
    - exact torus_initial_prealgebra_ump_1.
    - abstract
        (intros j x ;
         simpl ;
         induction j, x ;
         [ cbn ;
           do  3 refine (id_right _ @ _) ;
           refine (!(id_left _))
         | cbn ;
           refine (id_right _ @ _) ;
           refine (id_left _ @ _) ;
           refine (id_right _ @ _) ;
           refine (!(id_left _))]).
  Defined.
End TorusInitialAlgUMPOne.

Local Notation "'loopl'" := (hzone ,, hzzero : torus_initial_algebra_carrier ⟦ tt , tt ⟧).
Local Notation "'loopr'" := (hzzero ,, hzone : torus_initial_algebra_carrier ⟦ tt , tt ⟧).

Definition loopl_power_n
           (n : hz)
  : loopl ^ n
    =
    (n ,, hzzero : torus_initial_algebra_carrier ⟦ tt , tt ⟧).
Proof.
  revert n.
  use hz_ind.
  - apply idpath.
  - simpl ; intros n IHn.
    rewrite nattohzandS.
    rewrite morph_power_plus.
    rewrite IHn.
    cbn ; apply idpath.
  - simpl ; intros n IHn.
    rewrite toℤneg_S.
    unfold hzminus.
    rewrite morph_power_plus.
    rewrite IHn.
    apply pathsdirprod.
    + simpl.
      rewrite !hzplusr0.
      apply idpath.
    + simpl.
      rewrite !hzplusr0.
      apply idpath.
Qed.

Definition loopr_power_n
           (n : hz)
  : loopr ^ n
    =
    (hzzero ,, n : torus_initial_algebra_carrier ⟦ tt , tt ⟧).
Proof.
  revert n.
  use hz_ind.
  - apply idpath.
  - simpl ; intros n IHn.
    rewrite nattohzandS.
    rewrite morph_power_plus.
    rewrite IHn.
    cbn ; apply idpath.
  - simpl ; intros n IHn.
    rewrite toℤneg_S.
    unfold hzminus.
    rewrite morph_power_plus.
    rewrite IHn.
    apply pathsdirprod.
    + simpl.
      rewrite !hzplusr0.
      apply idpath.
    + simpl.
      rewrite !hzplusr0.
      apply idpath.
Qed.

Definition is_double_power
           (f : torus_initial_algebra_carrier ⟦ tt , tt ⟧)
  : f
    =
    double_power
      loopl
      loopr
      (pr1 f)
      (pr2 f).
Proof.
  induction f as [n m].
  unfold double_power ; simpl.
  rewrite loopl_power_n.
  rewrite loopr_power_n.
  refine (!_).
  apply pathsdirprod.
  - apply hzplusr0.
  - apply hzplusl0.
Qed.

Definition torus_alg_mor_on_loop_l
           {G₁ G₂ : hit_algebra_grpd torus_signature}
           (F : G₁ --> G₂)
  : # (pr111 F : _ ⟶ _) (alg_path_grpd G₁ p_left tt) · (pr112 (pr11 F)) tt
    =
    (pr112 (pr11 F)) tt · alg_path_grpd G₂ p_left tt.
Proof.
  pose (pr21 F p_left) as m.
  simpl in m.
  pose (nat_trans_eq_pointwise m tt) as p.
  exact p.
Qed.

Definition torus_alg_mor_on_loop_r
           {G₁ G₂ : hit_algebra_grpd torus_signature}
           (F : G₁ --> G₂)
  : # (pr111 F : _ ⟶ _) (alg_path_grpd G₁ p_right tt) · (pr112 (pr11 F)) tt
    =
    (pr112 (pr11 F)) tt · alg_path_grpd G₂ p_right tt.
Proof.
  pose (pr21 F p_right) as m.
  simpl in m.
  pose (nat_trans_eq_pointwise m tt) as p.
  exact p.
Qed.

Section TorusInitialAlgUMPTwo.
  Variable (G : hit_algebra_grpd torus_signature)
           (F₁ F₂ : torus_initial_algebra --> G).

  Local Notation "'Gl'" := (pr1 (alg_path_grpd G p_left) tt).
  Local Notation "'Gr'" := (pr1 (alg_path_grpd G p_right) tt).

  Definition torus_initial_algebra_ump_2_carrier_data
    : nat_trans_data (pr111 (pr1 F₁)) (pr111 (pr1 F₂))
    := λ x, pr11 (pr211 F₁) x · grpd_inv (pr11 (pr211 F₂) x).

  Definition torus_initial_algebra_ump_2_is_nat_trans
    : is_nat_trans _ _ torus_initial_algebra_ump_2_carrier_data.
  Proof.
    intros x y.
    induction x, y.
    unfold torus_initial_algebra_ump_2_carrier_data.
    intro f.
    refine (assoc _ _ _ @ _).
    refine (!_) ; use move_grpd_inv_left.
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        exact (is_double_power f).
      }
      apply functor_on_double_power.
    }
    etrans.
    {
      apply (double_power_swap
               (torus_alg_mor_on_loop_l F₁)
               (torus_alg_mor_on_loop_r F₁)).
    }
    refine (assoc' _ _ _ @ _).
    do 2 refine (_ @ assoc _ _ _).
    apply maponpaths.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          exact (is_double_power f).
        }
        apply functor_on_double_power.
      }
      apply (double_power_swap
               (torus_alg_mor_on_loop_l F₂)
               (torus_alg_mor_on_loop_r F₂)).
    }
    refine (assoc _ _ _ @ _).
    apply maponpaths_2.
    refine (assoc _ _ _ @ _).
    refine (_ @ id_left _).
    apply maponpaths_2.
    refine (!_).
    use move_grpd_inv_right.
    exact (!(id_right _)).
  Qed.

  Definition torus_initial_algebra_ump_2_carrier
    : pr111 (pr1 F₁) ⟹ pr111 (pr1 F₂).
  Proof.
    use make_nat_trans.
    - exact torus_initial_algebra_ump_2_carrier_data.
    - exact torus_initial_algebra_ump_2_is_nat_trans.
  Defined.

  Definition torus_initial_algebra_ump_2
    : F₁ ==> F₂.
  Proof.
    simple refine (((_ ,, _) ,, λ _, tt) ,, tt).
    - exact torus_initial_algebra_ump_2_carrier.
    - abstract
        (use nat_trans_eq ;
         [ apply (pr1 (pr111 G))
         | simpl ;
           intro x ;
           unfold torus_initial_algebra_ump_2_carrier_data ;
           rewrite <- assoc ;
           apply maponpaths ;
           rewrite (functor_id (pr21 (pr1 G))) ;
           refine (!_) ;
           apply move_grpd_inv_right ;
           rewrite id_right ;
           apply idpath]).
  Defined.
End TorusInitialAlgUMPTwo.

Section TorusInitialAlgUMPEq.
  Variable (G : hit_algebra_grpd torus_signature)
           (F₁ F₂ : torus_initial_algebra --> G)
           (τ₁ τ₂ : F₁ ==> F₂).

  Definition torus_ump_eq
    : τ₁ = τ₂.
  Proof.
    use subtypePath.
    { intro ; apply isapropunit. }
    use subtypePath.
    { intro ; use impred ; intro ; apply isapropunit. }
    use subtypePath.
    { intro ; apply grpd_bicat. }
    use nat_trans_eq.
    { apply (pr1 (pr111 G)). }
    intro x ; induction x.
    pose (nat_trans_eq_pointwise (pr211 τ₁) tt) as p.
    pose (nat_trans_eq_pointwise (pr211 τ₂) tt) as q.
    cbn in p, q.
    rewrite (functor_id (pr21 (pr1 G))), id_right in p.
    rewrite (functor_id (pr21 (pr1 G))), id_right in q.
    pose (maponpaths (λ z, z · grpd_inv (pr11 (pr211 F₂) tt)) (p @ !q)) as r.
    simpl in r.
    refine (_ @ r @ _).
    - rewrite <- assoc.
      refine (!(id_right _) @ _).
      apply maponpaths.
      apply move_grpd_inv_left.
      rewrite id_left.
      apply idpath.
    - rewrite <- assoc.
      refine (!_).
      refine (!(id_right _) @ _).
      apply maponpaths.
      apply move_grpd_inv_left.
      rewrite id_left.
      apply idpath.
  Qed.
End TorusInitialAlgUMPEq.

Definition torus_initial_algebra_unique_maps
  : is_biinitial torus_initial_algebra.
Proof.
  use make_is_biinitial.
  - exact torus_initial_algebra_ump_1.
  - intros G f g.
    use make_invertible_2cell.
    + exact (torus_initial_algebra_ump_2 G f g).
    + apply hit_alg_is_invertible_2cell.
  - exact torus_ump_eq.
Defined.

(** Path space of the circle at base *)
Definition torus_path_space_base
  : UU
  := ((pr111 (initial_groupoid_algebra torus_signature) : groupoid)
        ⟦ poly_initial_alg torus_point_constr tt
        , poly_initial_alg torus_point_constr tt ⟧).

Definition torus_path_space_base_is_ZZ
  : torus_path_space_base ≃ hz × hz.
Proof.
  pose (left_adjoint_equivalence_grpd_algebra_is_fully_faithful
          (biinitial_unique_adj_eqv
             torus_initial_algebra_unique_maps
             (initial_groupoid_algebra_is_initial _))
          (poly_initial_alg torus_point_constr tt)
          (poly_initial_alg torus_point_constr tt))
    as f.
  exact (make_weq _ f).
Defined.

Definition torus_path_space_encode_decode
  : torus_base torus = torus_base torus
    ≃
    torus_path_space_base
  := hit_path_space
       torus_signature
       (poly_initial_alg torus_point_constr tt)
       (poly_initial_alg torus_point_constr tt).

Definition torus_path_space_is_ZZ
  : torus_base torus = torus_base torus ≃ hz × hz
  := (torus_path_space_base_is_ZZ ∘ torus_path_space_encode_decode)%weq.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.

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

Section Star.

  Variable A : Type.
  Variable R : relation A.

  Inductive star: relation A:=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

  Lemma star_one:
    forall a b, R a b -> star a b.
  Proof.
    eauto using star.
  Qed.

  Lemma star_trans:
    forall a b, star a b -> forall c, star b c -> star a c.
  Proof.
    induction 1; eauto using star.
  Qed.

  Hypothesis R_functional:
    forall a b c, R a b -> R a c -> b = c.

  Lemma star_star_inv:
    forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
  Proof.
    induction 1; intros.
    - auto.
    - inversion H1; subst.
      + right. eauto using star.
      + assert (b = b0) by (eapply R_functional; eauto). subst b0.
        apply IHstar; auto.
  Qed.

  Definition irred a : Prop := forall b, ~(R a b).

  Lemma finseq_unique:
    forall a b b',
      star a b -> irred b ->
      star a b' -> irred b' ->
      b = b'.
  Proof.
    intros. destruct (star_star_inv _ _ H _ H1).
    - inversion H3; subst. auto. elim (H0 _ H4).
    - inversion H3; subst. auto. elim (H2 _ H4).
  Qed.

End Star.

#[export]
Hint Constructors star : core.

#[export]
Hint Resolve star_trans star_one : core.

Definition mul_dstep := star dexp DunfieldStep.
Notation "e ->>* e'" := ((star dexp DunfieldStep) e e') (at level 68).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).
Notation "e ^ x"        := (open_exp_wrt_exp e (e_var_f x)).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "R 'star'" := (star exp R) (at level 69).

Notation "t ->* t'" := (step star t t') (at level 68).

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` F).
(*
Definition typed e A : Prop := Dtyping nil e A.
Definition well_typed e : Prop := exists A, Dtyping nil e A.
*)
(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred exp step v.
Proof.
  introv.
  unfold irred.
  induction v; introv H;
    inverts* H;
    unfold not;
    intros;
    inverts* H.
Qed.

Lemma value_no_step : forall (v t: exp),
    value v -> v ->* t -> v = t.
Proof.
  introv Val Red.
  induction* Red.
  lets : step_not_value Val H.
  tryfalse.
Qed.

Lemma multi_red_app1 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* t1' -> (e_app t1 t2) ->* (e_app t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_app2 : forall v t t',
    value v -> lc_exp v -> t ->* t' -> (e_app v t) ->* (e_app v t').
Proof.
  introv Val ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge1 : forall t1 t2 t1',
    lc_exp t2 ->
    t1 ->* t1' ->
    (e_merge t1 t2) ->* (e_merge t1' t2).
Proof.
  introv ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge2 : forall v1 t2 t2',
    value v1 -> lc_exp v1 ->
    t2 ->* t2' ->
    (e_merge v1 t2) ->* (e_merge v1 t2').
Proof.
  introv Val ? Red.
  induction* Red.
Qed.

Lemma multi_red_merge3 : forall t1 t2 v1 v2,
    value v1 -> value v2 -> lc_exp v1 -> lc_exp t2 ->
    t1 ->* v1 -> t2 ->* v2 ->
    (e_merge t1 t2) ->* (e_merge v1 v2).
Proof.
  intros.
  apply star_trans with (b := e_merge v1 t2).
  sapply* multi_red_merge1.
  sapply* multi_red_merge2.
Qed.


(**
_AUTHOR_

<<
Zhi Zhang
Department of Computer and Information Sciences
Kansas State University
zhangzhi@ksu.edu
>>
*)

Require Export ast_basics.

(** * Run-Time Error *)
Inductive errorType: Type :=
    | DivByZero
    | OverflowError
    | RangeError.

(** * Return Value / State *)
(** Statement and expression evaluation returns one of the following results:
    - normal result;
    - run-time errors, which are required to be detected at run time,
      for example, overflow check and division by zero check;
    - unterminated state caused by infinite loop (only for functional semantics);
    - abnormal state, which includes compile time errors
      (for example, type checks failure and undefined variables),
      bounded errors and erroneous execution.
      In the future, the abnormal state can be refined into these
      more precise categories (1.1.5);
*)

(* return value for exp/statement evaluation defined in inductive type *)
Inductive Ret (A:Type): Type :=
    | OK: A -> Ret A
    | RTE: errorType -> Ret A.

Arguments OK [A] _.
Arguments RTE [A] _.

(** the range of 32-bit (singed/unsigned) integer type:
    - modulus : 2^32 ;
    - half_modulus : 2^31 ;
    - max_unsigned : 2^32 -1 ;
    - max_signed : 2^31 - 1 ;
    - min_signed : -2^31 ;
*)
Definition wordsize: nat := 32.
Definition modulus : Z := two_power_nat wordsize.
Definition half_modulus : Z := Z.div modulus 2.
Definition max_unsigned : Z := Z.sub modulus 1.
Definition max_signed : Z := Z.sub half_modulus 1.
Definition min_signed : Z := Z.opp half_modulus.

(** * Value *)

(** Type of basic values*)

(** Type of stored values in the store *)
Inductive value: Type :=
    | Undefined
    | Int (n : Z)
    | Bool (n : bool)
    | ArrayV (a : list (arrindex * value)) (* in SPARK, array index may start from negative number *)
    | RecordV (r : list (idnum * value)).

Definition Division_Error: Ret value := RTE DivByZero.
Definition Overflow_Error: Ret value := RTE OverflowError.
Definition Range_Error: Ret value := RTE RangeError.

(** * Bound of Value *)

(** value is represented by a range, for a variable, if its initial value is undefined
    or it's a parameter or its value is dynamically determined, then we use the range
    of its type as its value, e.g. x: Integer; it's value is: (Interval Integer'First Integer'Last),
    x: Integer := 1; it's value is: (Interval 1 1);
    for boolean value, it doesn't matter whether it's true or false, so we just use Bool to
    represent boolean value;
*)

Inductive bound : Type :=
  | Interval (l : Z) (u: Z)
  | Boolval
  | Aggregate.

Definition int32_bound : bound := (Interval min_signed max_signed).

(** check whether a value falls in a bound *)
Inductive in_bound: Z -> bound -> bool -> Prop :=
  | IB_True: forall v l u,
      (Zle_bool l v) && (Zle_bool v u) = true ->
      in_bound v (Interval l u) true
  | IB_False: forall v l u,
      (Zle_bool l v) && (Zle_bool v u) = false ->
      in_bound v (Interval l u) false.

(** * Value Operation *)
Module Math.

(** ** Arithmetic Operation *)

Definition add (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Int (v1' + v2'))
    | _, _ => None
    end.

Definition sub (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Int (v1' - v2'))
    | _, _ => None
    end.

Definition mul (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Int (v1' * v2'))
    | _, _ => None
    end.

(** map Ada operators to corresponding Coq operators:
    - div -> Z.quot
    - rem -> Z.rem
    - mod -> Z.modulo

      (Note: Ada "mod" has the following formula in Why:
       - if y > 0 then EuclideanDivision.mod x y else EuclideanDivision.mod x y + y)
*)

Definition div (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Int (Z.quot v1' v2'))
    | _, _ => None
    end.

Definition rem (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Int (Z.rem v1' v2'))
    | _, _ => None
    end.

(* the keyword "mod" cannot redefined here, so we use "mod'" *)
Definition mod' (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Int (Z.modulo v1' v2'))
    | _, _ => None
    end.

(** ** Logic Operation  *)
Definition and (v1 v2: value): option value :=
    match v1, v2 with
    | Bool v1', Bool v2' => Some (Bool (andb v1' v2'))
    | _, _ => None
    end.

Definition or (v1 v2: value): option value :=
    match v1, v2 with
    | Bool v1', Bool v2' => Some (Bool (orb v1' v2'))
    | _, _ => None
    end.

(** ** Relational Operation *)
Definition eq (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Bool (Zeq_bool v1' v2'))
    | _, _ => None
    end.

Definition ne (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Bool (Zneq_bool v1' v2'))
    | _, _ => None
    end.

Definition gt (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Bool (Zgt_bool v1' v2'))
    | _, _ => None
    end.

Definition ge (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Bool (Zge_bool v1' v2'))
    | _, _ => None
    end.

Definition lt (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Bool (Zlt_bool v1' v2'))
    | _, _ => None
    end.

Definition le (v1 v2: value): option value :=
    match v1, v2 with
    | Int v1', Int v2' => Some (Bool (Zle_bool v1' v2'))
    | _, _ => None
    end.

(** Unary Operations *)
Definition unary_not (v: value): option value :=
    match v with
    | Bool v' => Some (Bool (negb v'))
    | _ => None
    end.

Definition unary_plus (v: value): option value :=
    match v with
    | Int v' => Some v
    | _ => None
    end.

Definition unary_minus (v: value): option value :=
    match v with
    | Int v' => Some (Int (Z.opp v'))
    | _ => None
    end.

(** * Binary Operation *)
Definition binary_operation (op: binary_operator) (v1: value) (v2: value): option value :=
    match op with
    | Equal => eq v1 v2
    | Not_Equal => ne v1 v2
    | Greater_Than => gt v1 v2
    | Greater_Than_Or_Equal => ge v1 v2
    | Less_Than => lt v1 v2
    | Less_Than_Or_Equal => le v1 v2
    | And => and v1 v2
    | Or => or v1 v2
    | Plus => add v1 v2
    | Minus => sub v1 v2
    | Multiply => mul v1 v2
    | Divide => div v1 v2
    | Modulus => mod' v1 v2
    end.

(** * Unary Operation *)
Definition unary_operation (op: unary_operator) (v: value): option value :=
    match op with
    | Not => unary_not v
(*  | Unary_Plus => unary_plus v *)
    | Unary_Minus => unary_minus v
    end.

End Math.