Theorem Ex020 (A B C : Prop): A \/ (B /\ C) <-> (A \/ B) /\ (A \/ C).
Proof.
  split.
  + intro.
    split.
    - destruct H.
      * left. exact H.
      * destruct H. right. exact H.
    - destruct H.
      * left. exact H.
      * destruct H. right. exact H0.
  + intro.
    destruct H.
    destruct H.
    - destruct H0.
      * left. exact H.
      * left.  exact H.
    - destruct H0.
      * left. exact H0.
      * right. split.
        ++ exact H.
        ++ exact H0.
Qed.


Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Inductive empty : forall n : nat, listn n -> Prop :=
    intro_empty : empty 0 niln.

Parameter
  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y)
   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
   end).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y)
   | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y)
   end).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y)
   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
   end).


Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m.
  intros o.

  intros H.
  intros I.

  rewrite -> H.
  rewrite -> I.
  reflexivity.
Qed.


Require Import Coq.Init.Datatypes.
Require Import Coq.Program.Tactics.
Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Require Import propositionsSets.

Section equivalencesDefinitions.

Inductive Qinv {X Y:Type} (f:X->Y):=
|qinv
  (g:Y->X)
  (n:forall x:X, Id (g(f(x))) x)
  (e:forall y:Y, Id (f(g(y))) y).

Inductive HalfAdjointEquiv {X Y:Type} (f:X->Y):=
|halfAdjointEquiv
  (g:Y->X)
  (n:forall x:X, Id (g(f(x))) x)
  (e:forall y:Y, Id (f(g(y))) y)
  (t:forall x:X, Id (appl f (n x)) (e (f x))).

Inductive Biinv {X Y:Type} (f:X->Y):=
|biinv  (g h:Y->X)
        (n:forall x:X, Id (g(f(x))) x)
        (e:forall y:Y, Id (f(h(y))) y).

Inductive Fibre {X Y:Type} (f:X->Y) (y:Y):=
|fibre
  (x:X)
  (H:Id (f(x)) y).

Inductive IsContractibleMap {X Y:Type} (f:X->Y):=
|isContractibleMap
  (H:forall y:Y, IsContractible(Fibre f y)).

End equivalencesDefinitions.


From ZornsLemma Require Import EnsemblesImplicit InverseImage.

Definition EnsembleProduct {X Y : Type} (SX : Ensemble X) (SY : Ensemble Y) : Ensemble (X * Y) :=
  fun p => In SX (fst p) /\ In SY (snd p).

Lemma EnsembleProduct_Full {X Y : Type} :
  @EnsembleProduct X Y Full_set Full_set = Full_set.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - constructor.
  - destruct x.
    split.
    all: constructor.
Qed.

Lemma EnsembleProduct_Empty_l {X Y : Type} V :
  @EnsembleProduct X Y Empty_set V = Empty_set.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct x. destruct H. destruct H.
  - destruct H.
Qed.

Lemma EnsembleProduct_Empty_r {X Y : Type} U :
  @EnsembleProduct X Y U Empty_set = Empty_set.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct x. destruct H. destruct H0.
  - destruct H.
Qed.

Lemma EnsembleProduct_Union {X Y : Type} (U0 U1 : Ensemble X) (V0 V1 : Ensemble Y) :
  Included (Union (EnsembleProduct U0 V0) (EnsembleProduct U1 V1))
           (EnsembleProduct (Union U0 U1) (Union V0 V1)).
Proof.
  intros x H.
  destruct H as [|]; destruct x; destruct H.
  - split; left; assumption.
  - split; right; assumption.
Qed.

Lemma EnsembleProduct_Intersection {X Y : Type} (U0 U1 : Ensemble X) (V0 V1 : Ensemble Y) :
  Intersection (EnsembleProduct U0 V0) (EnsembleProduct U1 V1) =
  EnsembleProduct (Intersection U0 U1) (Intersection V0 V1).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct H. destruct x. destruct H, H0.
    split; split; assumption.
  - destruct H.
    inversion H; subst; clear H.
    inversion H0; subst; clear H0.
    split; constructor; assumption.
Qed.

Lemma inverse_image_fst {X Y : Type} (U : Ensemble X) :
  inverse_image fst U = EnsembleProduct U (@Full_set Y).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - do 2 red. destruct H. auto with sets.
  - destruct H. constructor. auto.
Qed.

Lemma inverse_image_snd {X Y : Type} (V : Ensemble Y) :
  inverse_image snd V = EnsembleProduct (@Full_set X) V.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - do 2 red. destruct H. auto with sets.
  - destruct H. constructor. auto.
Qed.

Lemma EnsembleProduct_proj {X Y : Type} (U : Ensemble X) (V : Ensemble Y) :
  EnsembleProduct U V = Intersection (inverse_image fst U)
                                     (inverse_image snd V).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct x. destruct H.
    split; constructor; assumption.
  - destruct H. inversion H. inversion H0.
    destruct x. split; assumption.
Qed.

Lemma EnsembleProduct_Included {X Y : Type} (U0 U1 : Ensemble X) (V0 V1 : Ensemble Y) :
  Included U0 U1 -> Included V0 V1 ->
  Included (EnsembleProduct U0 V0) (EnsembleProduct U1 V1).
Proof.
  intros. red; intros.
  destruct x; destruct H1.
  split; auto.
Qed.

Lemma EnsembleProduct_Complement {X Y : Type} (U : Ensemble X) (V : Ensemble Y) :
  Complement (EnsembleProduct U V) =
  Union (EnsembleProduct Full_set (Complement V))
        (EnsembleProduct (Complement U) Full_set).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - red in H. red in H.
    apply not_and_or in H.
    destruct x as [x y].
    destruct H.
    + right. split; [assumption|constructor].
    + left. split; [constructor|assumption].
  - destruct H.
    + destruct x, H.
      cbv. intros. intuition.
    + destruct x, H. cbv. intuition.
Qed.

Lemma EnsembleProduct_Union_dist {X Y : Type} (U : Ensemble X) (V0 V1 : Ensemble Y) :
  Union (EnsembleProduct U V0) (EnsembleProduct U V1) =
  EnsembleProduct U (Union V0 V1).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct H.
    + destruct H. split; try assumption.
      left. assumption.
    + destruct H. split; try assumption.
      right. assumption.
  - destruct H.
    inversion H0; subst; clear H0.
    + left. split; assumption.
    + right. split; assumption.
Qed.

Lemma EnsembleProduct_Intersection_dist {X Y : Type} (U : Ensemble X) (V0 V1 : Ensemble Y) :
  Intersection (EnsembleProduct U V0) (EnsembleProduct U V1) =
  EnsembleProduct U (Intersection V0 V1).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct H. destruct H, H0.
    split; try assumption; split; assumption.
  - destruct H. inversion H0; subst; clear H0.
    split; split; assumption.
Qed.


Require Import Reals.
Require Import Rinterval.
Require Import Lra.

Require Import Rpser_def Rpser_base_facts Rpser_cv_facts.

(** In this library, we define the sum of a power serie with respect to the
3 notions of convergence radius that we used until now.

- weaksum_r sums a power serie on a disk that is smaller than the maximal
convergence disk
- sum_r sums a power serie on its (finite) convergence disk
- sum sums a power serie on its (infinite) convergence disk

In all the cases, the function outputed is proved to be unique and is
exactly the one that equals the sum of the power serie inside the cv disk
and is equal to 0 outside. *)

(** * Definition of weaksum_r *)

Local Open Scope R_scope.

Definition weaksum_r : forall (An : nat -> R) (r : R) (Pr : Cv_radius_weak An r), R -> R.
Proof.
intros An r Rho x.
 case (Rlt_le_dec (Rabs x) r) ; intro x_bd.
 elim (Rpser_abel _ _ Rho _ x_bd) ; intros y Hy ; exact y.
 exact 0.
Defined.

(** Proof that it is really the sum *)

Lemma weaksum_r_sums : forall (An : nat -> R) (r : R) (Pr : Cv_radius_weak An r) (x : R),
      Rabs x < r -> Rpser An x (weaksum_r An r Pr x).
Proof.
intros An r Pr x x_bd.
 unfold weaksum_r ; case (Rlt_le_dec (Rabs x) r) ; intro s.
 destruct (Rpser_abel An r Pr x s) as (l,Hl) ; simpl ; assumption.
 apply False_ind ; lra.
Qed.

(** Proof that the sum is unique *)

Lemma weaksum_r_unique : forall (An : nat -> R) (r : R) (Pr1 Pr2 : Cv_radius_weak An r) (x : R),
     Rabs x < r -> weaksum_r An r Pr1 x = weaksum_r An r Pr2 x.
Proof.
intros An r Pr1 Pr2 x x_bd ;
 assert (T1 := weaksum_r_sums _ _ Pr1 _ x_bd) ;
 assert (T2 := weaksum_r_sums _ _ Pr2 _ x_bd) ;
 eapply Rpser_unique ; eassumption.
Qed.

Lemma weaksum_r_unique_strong : forall (An : nat -> R) (r1 r2 : R) (Pr1 : Cv_radius_weak An r1)
     (Pr2 : Cv_radius_weak An r2) (x : R), Rabs x < r1 -> Rabs x < r2 ->
     weaksum_r An r1 Pr1 x = weaksum_r An r2 Pr2 x.
Proof.
intros An r1 r2 Pr1 Pr2 x x_bd1 x_bd2.
  assert (T1 := weaksum_r_sums _ _ Pr1 _ x_bd1) ;
  assert (T2 := weaksum_r_sums _ _ Pr2 _ x_bd2) ;
 eapply Rpser_unique ; eassumption.
Qed.

(** * Definition of sum_r *)

Definition sum_r : forall (An : nat -> R) (r : R) (Pr : finite_cv_radius An r), R -> R.
Proof.
intros An r Pr x.
 case (Rlt_le_dec (Rabs x) r) ; intro x_bd.
  assert (rho : Cv_radius_weak An (middle (Rabs x) r)).
  apply Pr; split.
  apply Rle_trans with (Rabs x).
   apply Rabs_pos.
   left ; apply (proj1 (middle_is_in_the_middle _ _ x_bd)).
   apply (proj2 (middle_is_in_the_middle _ _ x_bd)).
 apply (weaksum_r An (middle (Rabs x) r) rho x).
 exact 0.
Defined.

(** Proof that it is really the sum *)

Lemma sum_r_sums : forall  (An : nat -> R) (r : R) (Pr : finite_cv_radius An r),
      forall x, Rabs x < r -> Rpser An x (sum_r An r Pr x).
Proof.
intros An r Pr x x_ub.
 unfold sum_r ; destruct (Rlt_le_dec (Rabs x) r) as [x_bd | x_nbd].
 apply weaksum_r_sums.
 apply (proj1 (middle_is_in_the_middle _ _ x_bd)).
  apply False_ind ; lra.
Qed.

(** Proof that the sum is unique *)

Lemma sum_r_unique : forall (An : nat -> R) (r : R) (Pr1 Pr2 : finite_cv_radius An r) (x : R),
     Rabs x < r -> sum_r An r Pr1 x = sum_r An r Pr2 x.
Proof.
intros An r Pr1 Pr2 x x_bd ;
 assert (T1 := sum_r_sums _ _ Pr1 _ x_bd) ;
 assert (T2 := sum_r_sums _ _ Pr2 _ x_bd) ;
 eapply Rpser_unique ; eassumption.
Qed.

Lemma sum_r_unique_strong : forall (An : nat -> R) (r1 r2 : R) (Pr1 : finite_cv_radius An r1)
     (Pr2 : finite_cv_radius An r2) (x : R), Rabs x < r1 -> Rabs x < r2 ->
     sum_r An r1 Pr1 x = sum_r An r2 Pr2 x.
Proof.
intros An r1 r2 Pr1 Pr2 x x_bd1 x_bd2 ;
 assert (T1 := sum_r_sums _ _ Pr1 _ x_bd1) ;
 assert (T2 := sum_r_sums _ _ Pr2 _ x_bd2) ;
 eapply Rpser_unique ; eassumption.
Qed.

(** * Definition of sum *)

Definition sum : forall (An : nat -> R) (Pr : infinite_cv_radius An), R -> R.
Proof.
intros An Pr r.
 apply (weaksum_r An (Rabs r +1) (Pr (Rabs r + 1)) r).
Defined.

(** Proof that it is really the sum *)

Lemma sum_sums : forall  (An : nat -> R) (Pr : infinite_cv_radius An),
      forall x, Rpser An x (sum An Pr x).
Proof.
intros An Pr x.
 apply weaksum_r_sums ; intuition.
Qed.

(** Proof that the sum is unique *)

Lemma sum_unique : forall (An : nat -> R) (Pr1 Pr2 : infinite_cv_radius An) (x : R),
      sum An Pr1 x = sum An Pr2 x.
Proof.
intros An Pr1 Pr2 x ;
 assert (T1 := sum_sums  _ Pr1 x) ;
 assert (T2 := sum_sums  _ Pr2 x) ;
 eapply Rpser_unique ; eassumption.
Qed.


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/02/24.                                             *)
(* Due: 2021/02/28, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment1.v) on CANVAS.         *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment1.vo" file is generated.         *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import PL.Imp.

(** The command [Admitted] can be used as a placeholder for an
    incomplete proof or an in complete definition.  We'll use it in
    exercises, to indicate the parts that we're leaving for you --
    i.e., your job is to replace [Admitted]s with real proofs and/or
    definitions. *)

(* ################################################################# *)
(** * Task 1 *)

(** Equalities are symmetric and transive. Prove it in Coq. You should
fill in your proof scripts and replace "Admitted" with "Qed".  *)

(** **** Exercise: 1 star, standard *)
Theorem eq_sym: forall (A: Type) (x y: A), x = y -> y = x.
Proof.
  intros.
  rewrite <- H.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard *)
Theorem eq_trans: forall (A: Type) (x y z: A), x = y -> y = z -> x = z.
Proof.
  intros.
  rewrite H.
  rewrite H0.
  reflexivity.
Qed.
(** [] *)

(** The following example is an special instance of congruence properties.
That is, equalities between integers are preserved by addition. *)

(** **** Exercise: 1 star, standard *)
Theorem Zplus_add: forall x1 x2 y1 y2: Z,
  x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2.
Proof.
  intros.
  rewrite H.
  rewrite H0.
  reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 2 *)

(** Read the following pairs of English descriptions and Hoare triples.
Determine whether they express equivalent meaning. *)

Module Task2_Example.

(**
Hoare triple: {{ True }} c {{ {[X]} <= 3 AND 3 <= {[X]} }}.
Informal description: the program [c] will turn the value of [X] into [3].
Do they express equivalent meaning? 1: Yes. 2: No.
*)

Definition my_choice: Z := 1.

End Task2_Example.

(** **** Exercise: 1 star, standard *)
Module Task2_1.

(**
Hoare triple: {{ {[X]} <= {[Y]} }} c {{ {[Y]} <= {[X]} }}.
Informal description: the program [c] will swap the values of [X] and [Y].
Do they express equivalent meaning? 1: Yes. 2: No.

Remove "[Admitted.]" and write down your choice.
*)

Definition my_choice: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)

End Task2_1.
(** [] *)

(** **** Exercise: 1 star, standard *)
Module Task2_2.

(**
Hoare triple: {{ EXISTS k. {[X]} = 2 * k }} c {{ {[Y]} = 0 }}.
Informal description: the program [c] will test whether [X] is an even
number (偶数); if yes, [0] will be assigned into [Y].
Do they express equivalent meaning? 1: Yes. 2: No.
*)

Definition my_choice: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(* Note that the program [c] doesn't necessarily test [X]. *)

End Task2_2.
(** [] *)

(** **** Exercise: 1 star, standard *)
Module Task2_3.

(**
Hoare triple: {{ True }} c {{ False }}.
Informal description: the program [c] will never terminate.
Do they express equivalent meaning? 1: Yes. 2: No.
*)

Definition my_choice: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)

End Task2_3.
(** [] *)

(** **** Exercise: 1 star, standard *)
Module Task2_4.

(**
Hoare triple: {{ True }} c {{ True }}.
Informal description: any program [c].
Do they express equivalent meaning? 1: Yes. 2: No.
*)

Definition my_choice: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)

End Task2_4.
(** [] *)

(** **** Exercise: 1 star, standard *)
Module Task2_5.

(**
Hoare triple: for any m, {{ {[X]} + {[Y]} = m }} c {{ {[X]} + {[Y]} = m }}.
Informal description: the program [c] will not change the sum of [X] and [Y].
Do they express equivalent meaning? 1: Yes. 2: No.
*)

Definition my_choice: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)

End Task2_5.
(** [] *)

(* ################################################################# *)
(** * Task 3 *)

(** **** Exercise: 3 stars, standard (swapping_by_arith) *)

Module swapping_by_arith.
Import Concrete_Pretty_Printing.
Import Axiomatic_semantics.

(** Prove the following swapping programs correct. Hoare triples about single
assignment commands are provided as hypothese.

       X ::= X + Y;;
       Y ::= X - Y;;
       X ::= X - Y
*)

Local Instance X: var := new_var().
Local Instance Y: var := new_var().

(** Here are three hypothese. *)

Hypothesis triple1: forall x y: Z,
  {{ {[X]} = x AND {[Y]} = y }}
  X ::= X + Y
  {{ {[X]} = x + y AND {[Y]} = y }}.

Hypothesis triple2: forall x y: Z,
  {{ {[X]} = x + y AND {[Y]} = y }}
  Y ::= X - Y
  {{ {[X]} = x + y AND {[Y]} = x }}.

Hypothesis triple3: forall x y: Z,
  {{ {[X]} = x + y AND {[Y]} = x }}
  X ::= X - Y
  {{ {[X]} = y AND {[Y]} = x }}.

(** Now, prove the following Hoare triple by Hoare logic axioms. *)

Fact swapping_by_arith_correct:
  forall x y: Z,
       {{ {[X]} = x AND {[Y]} = y }}
       X ::= X + Y;;
       Y ::= X - Y;;
       X ::= X - Y
       {{ {[X]} = y AND {[Y]} = x }}.
Proof.
  intros.
  apply hoare_seq with ({[X]} = x + y AND {[Y]} = y)%assert.
  apply triple1.
  apply hoare_seq with ({[X]} = x + y AND {[Y]} = x)%assert.
  apply triple2.
  apply triple3.
Qed.
(** [] *)
End swapping_by_arith.

(* ################################################################# *)
(** * Task 4: Using [apply] in more Coq proofs *)

(** A binary relation [R] is called a pre-order if it is reflexive and
transitive. Here is a very simple property about pre-orders. Try to prove
it in Coq. *)

Section PreOrder.

Variable A: Type.
Variable R: A -> A -> Prop.
Hypothesis R_refl: forall a, R a a.
Hypothesis R_trans: forall a b c, R a b -> R b c -> R a c.

(** **** Exercise: 1 star, standard *)
Fact R_trans5: forall a b c d e, R a b -> R b c -> R c d -> R d e -> R a e.
Proof.
  intros.
  apply R_trans with (b := b).
  apply H.
  apply R_trans with (b := c).
  apply H0.
  apply R_trans with (b := d).
  apply H1.
  apply H2.
Qed.
(** [] *)

End PreOrder.

(* 2021-02-23 23:55 *)


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose     : Block is a fixed length array
  author      : Zhengpu Shi
  date        : 2022.05

  remark      :
  1. it is a simple but more general implementation inspired from our team.
  2. main idea of the work
  (1). block
    Record Block A n := {data : list A; Bcond : |data| = n}
  (2). downgrade the block problem to list problem by remove the Bcond
    condition with UIP (Uniqueness of Indentity Proofs).
  (3). construct any-dim-array by repeat use block structure.
*)

Require Import Coq.Logic.Eqdep.
        Import EqdepTheory.   (* UIP *)

From MyStdLibExt
Require Export ListExt.General.   (* List extension *)

(* ######################################################################### *)
(** * Definition and basic properties of block *)
Section Def.

  (* ======================================================================= *)
  (** ** Definitions and properties *)
  Section Defs.

    Variable A : Type.
    Variable n : nat.

    (** A block is consists of a list and a limit on the length of that list. *)
    Record Block := mkBlock {
      Bdata : list A;
      Bcond : length Bdata = n
    }.

    (** Length of Bdata is stable *)
    Lemma Bdata_length : forall (b : Block), length (Bdata b) = n.
    Proof. intros [l H]. auto. Qed.

    (** Block equal iff its data equal *)
    Lemma beq_iff : forall (b1 b2 : Block),
      Bdata b1 = Bdata b2 <-> b1 = b2.
    Proof.
      intros [l1 H1] [l2 H2]; simpl. split; intros.
      - subst. f_equal. apply UIP.
      - injection H; auto.
    Qed.

    (** Block not equal iff its data not equal *)
    Lemma beq_iff_not : forall (b1 b2 : Block),
      Bdata b1 <> Bdata b2 <-> b1 <> b2.
    Proof.
      intros. split; intros; intro H1; apply beq_iff in H1; auto.
    Qed.

  End Defs.

  Global Arguments Block {A n}.
  Global Arguments mkBlock {A n}.
  Global Arguments Bdata {A n}.
  Global Arguments Bcond {A n}.

End Def.

(* ######################################################################### *)
(* * Conversion between block and other data type *)
Section Conversion.

  (* ======================================================================= *)
  (** ** Create a empty block *)
  Section CreateEmpty.

    Definition bzero {A} (A0 : A) (n : nat) : @Block A n :=
      mkBlock (repeat A0 n) (repeat_length A0 n).

  End CreateEmpty.

  Global Arguments bzero {A}.

  (* ======================================================================= *)
  (** ** Create block with a list *)
  Section CreateWithList.

    (** Create a block by a list and the length of the list. *)
    Definition l2b {A} (l : list A) : @Block A (length l) :=
      mkBlock l (eq_refl).

    (** Coercion from list to Block is convenient *)
    Coercion l2b : list >-> Block.

  End CreateWithList.

  Global Arguments l2b {A}.

  Section test.

    Let b1 : Block := [1;2].
    Let b21 : Block := [l2b [1;2]; l2b [3;4]].
    Let b22 : Block := [l2b [5;6]; l2b [7;8]].
    Let b3 : Block := l2b [b21;b22].

    Compute b1.
    Compute Bdata b1.

    Compute b21.
    Compute Bdata b21.
    Compute Bdata (hd _ (Bdata b21)).

    Compute b3.
    Compute Bdata b3.
    Compute Bdata (hd _ (Bdata b3)).
    Compute hd _ (Bdata (hd _ (Bdata b3))).
    Compute Bdata (hd _ (Bdata (hd _ (Bdata b3)))).

  End test.

  (* ======================================================================= *)
  (** ** Create block with Coq.Vectors.VectorDef.t *)
  Section CreateWithCoqVector.

    Import VectorDef.

    (** Create a block by Vector.t *)
    Fixpoint coqvec2b {A} {n} (v : Vector.t A n) : @Block A n.
      refine (mkBlock (VectorDef.to_list v) _).
      induction v; auto.
      assert (to_list (Vector.cons A h n v) = h :: to_list v); auto.
      rewrite H. simpl. rewrite IHv. auto.
    Defined.

  End CreateWithCoqVector.

  Global Arguments coqvec2b {A n}.

  Section test.
    Import VectorDef.
    Import VectorNotations.

    Compute coqvec2b [1;2;3].

  End test.

End Conversion.

(* ######################################################################### *)
(* * Get element of block *)
Section GetElement.

  (* ======================================================================= *)
  (** ** Get element with index *)
  Section ByIndex.

    Variable A : Type.
    Variable A0 : A.
    Variable n : nat.

    (** Get element with index, if the index out-of-bounds then return A0 *)
    Definition bget (b : @Block A n) (i : nat) : A :=
      nth i (Bdata b) A0.

    (** Block equal iff every visit with valid index get same result *)
    Lemma beq_iff_bget : forall (b1 b2 : @Block A n),
      b1 = b2 <-> (forall (i : nat) (Hi : i < n), bget b1 i = bget b2 i).
    Proof.
      intros [l1 H1] [l2 H2]. split; intros.
      - f_equal. auto.
      - apply beq_iff; simpl.
        rewrite (list_eq_iff_nth A0 n); auto.
    Qed.

  End ByIndex.

  Global Arguments bget {A} _ {n}.

  (* ======================================================================= *)
  (* test *)
  Section test.

    Compute bget 0 [1;2;3] 0.
    Compute bget 0 [1;2;3] 1.

  End test.

End GetElement.

(* ######################################################################### *)
(* * Set element of block *)
Section SetElement.

  (* ======================================================================= *)
  (** ** Set element by index *)
  Section ByIndex.

    Variable A : Type.
    Variable n : nat.

    (** Set element by index with a constant value. *)
    Definition bset (b : @Block A n) (i : nat) (x : A) : @Block A n :=
      let 'mkBlock l H := b in
        mkBlock (lst_chg l i x) (lst_chg_height l i n x H).

    (** Set element by index with a function. *)
    Definition bsetf (b : @Block A n) (i : nat) (f : nat -> A) : @Block A n :=
      let 'mkBlock l H := b in
        mkBlock (lst_chgf l i f) (lst_chgf_height l n i f H).

  End ByIndex.

  Global Arguments bset {A n}.
  Global Arguments bsetf {A n}.

  (* ======================================================================= *)
  (* test *)
  Section test.

    Compute bset [1;2;3] 1 9.
    Compute bsetf [1;2;3] 1 (fun i => i + 10).

  End test.

End SetElement.

(* ######################################################################### *)
(* * Mapping of block *)
Section Mapping.

  (* ======================================================================= *)
  (** ** Mapping of one block *)
  Section Map1.

    Variable A B : Type.
    Variable n : nat.
    Variable f : A -> B.

    Definition bmap (b : @Block A n) : @Block B n.
      refine (mkBlock (map f (Bdata b)) _).
      rewrite map_length. apply Bdata_length.
    Defined.

  End Map1.

  Global Arguments bmap {A B n}.

  (* ======================================================================= *)
  (* test *)
  Section test.

    Compute bmap (fun i => Nat.even i) [1;2;3].

  End test.

  (* ======================================================================= *)
  (** ** Mapping of two blocks *)
  Section Map2.

    Variable A B C : Type.
    Variable n : nat.
    Variable f : A -> B -> C.

    Definition bmap2 (b1 : @Block A n) (b2 : @Block B n) : @Block C n.
      refine (mkBlock (map2 f (Bdata b1) (Bdata b2)) _).
      rewrite (map2_length) with (n:=n); auto. all: apply Bdata_length.
    Defined.

  End Map2.

  Global Arguments bmap2 {A B C n}.

  (* ======================================================================= *)
  (* test *)
  Section test.

    Compute bmap2 (fun i j => i + j) [1;2;3] [4;5;6].

  End test.

  (* ======================================================================= *)
  (** ** Properties when mapping of two blocks with same base type *)
  Section Map2_sametype.

    Variable A : Type.
    Variable n : nat.
    Variable f : A -> A -> A.
    Variable f_comm : forall a b, f a b = f b a.
    Variable f_assoc : forall a b c, f a (f b c) = f (f a b) c.

    Lemma bmap2_comm : forall (b1 b2 : @Block A n),
      bmap2 f b1 b2 = bmap2 f b2 b1.
    Proof.
      intros [l1 H1] [l2 H2]. apply beq_iff; simpl.
      apply map2_comm; auto.
    Qed.

    Lemma bmap2_assoc : forall (b1 b2 b3 : @Block A n),
      bmap2 f (bmap2 f b1 b2) b3 = bmap2 f b1 (bmap2 f b2 b3).
    Proof.
      intros [l1 H1] [l2 H2] [l3 H3]. apply beq_iff; simpl.
      apply map2_assoc; auto.
    Qed.

  End Map2_sametype.

End Mapping.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.

Axiom admit: forall {X},  X.

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

(** Dans cet exercice, nous étendons la sémantique du langage Imp
    étudié en cours, étendons sa logique de programme et vérifions la
    correction d'un programme écrit dans ce système. *)

(** * Variables *)

(** Comme en cours, nous modélisons les variables du langage par un
    type [id] dont nous nommons (arbitrairement) 3 éléments [X], [Y]
    et [Z]. *)

Inductive id : Type :=
  | Id : nat -> id.

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Definition beq_id x1 x2 :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall x, beq_id x x = true.
Proof. now intros; destruct x; simpl; rewrite <- beq_nat_refl. Qed.

(** QUESTION [difficulté [*] / longueur [*]]

    [X] et [Y] étant définis, les lemmes suivants sont prouvables par
    simple _calcul_.  *)

Remark rq1: beq_id X X = true.
Proof.
  apply beq_id_refl.
Qed.

Remark rq2: beq_id X Y = false.
Proof.
  simpl.
  auto.
Qed.

(** * Mémoire *)

(** Comme en cours, nous modélisons la mémoire par une fonction des
    identifiants vers les entiers. On accède donc au contenu de la
    mémoire [s] à l'adresse [x] par application [s x]. *)

Definition state := id -> nat.

Definition empty_state: state := fun _ => 0.

Definition update (s: state)(x: id)(n: nat) :=
  fun y => if beq_id x y then n else s y.

(** QUESTION [difficulté [**] / longueur [*]]

    Prouver les identités suivantes reliant l'extension de la mémoire
    et l'accès à la mémoire: *)

Lemma update_eq : forall s x v,
    update s x v x = v.
Proof.
  intros. induction v;
  unfold update; rewrite beq_id_refl; reflexivity.
Qed.

Lemma update_shadow : forall s v1 v2 x,
    update (update s x v1) x v2
  = update s x v2.
Proof.
  intros. unfold update; simpl.
  apply functional_extensionality.
  intro x0.
  case (beq_id x x0); auto.
Qed.

(** * Expressions booléennes *)

(** Les expressions booléennes permettent d'écrire des formules
    booléennes (avec [BTrue], [BFalse], [BNot] et [BAnd]) ainsi que
    des tests sur le contenu des variables ([BEq] et [BLe]). *)

Inductive bexp : Type :=
  | BTrue  : bexp
  | BFalse : bexp
  | BNot   : bexp -> bexp
  | BAnd   : bexp -> bexp -> bexp
  | BEq    : id -> nat -> bexp
  | BLe    : id -> nat -> bexp.

Fixpoint beval (st: state)(b : bexp) : bool :=
  match b with
  | BTrue      => true
  | BFalse     => false
  | BNot b1    => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  | BEq x n    => beq_nat (st x) n
  | BLe x n    => leb (st x) n
  end.

(** QUESTION [difficulté [*] / longueur [*]]

    Dériver le "ou logique" [BOr] à partir de [BNot] et [BAnd]
    (suivant la loi de De Morgan) puis prouver que sa sémantique est
    conforme à [orb], l'implémentation du "ou logique" en Coq.  *)

Definition BOr (b1 b2: bexp): bexp :=
  BNot (BAnd (BNot b1) (BNot b2)).

Lemma bor_correct: forall st b1 b2,
    beval st (BOr b1 b2) = orb (beval st b1) (beval st b2).
Proof.
  intros. simpl.
  SearchAbout "negb".
  rewrite negb_andb.
  rewrite negb_involutive.
  rewrite negb_involutive.
  reflexivity.
Qed.

(** QUESTION [difficulté [**] / longueur [***]]

    Prouver que la sémantique de [BLe'] défini ci-dessous est conforme
    à [leb], l'implémentation de la comparaison d'entiers dans Coq. *)

Definition BLe' (m: nat)(x: id): bexp :=
  BOr (BNot (BLe x m)) (BEq x m).

Lemma ble'_correct: forall st m x, beval st (BLe' m x) = leb m (st x).
Proof.
  intros.
  unfold BLe'.
  rewrite bor_correct.
  simpl.
  remember (leb m (st x)).
  destruct b.
  - apply orb_true_iff.
    symmetry in Heqb.
    apply leb_iff, le_lt_or_eq in Heqb.
    destruct Heqb.
    + left.
      now apply negb_true_iff, leb_correct_conv.
    + right.
      now apply beq_nat_true_iff.
  - apply orb_false_iff.
    symmetry in Heqb.
    apply leb_complete_conv in Heqb.
    split.
    + apply negb_false_iff. apply leb_correct.
      omega.
    + SearchAbout "beq_nat_fa".
      apply beq_nat_false_iff.
      omega.
Qed.

(** * Commandes *)

(** Nous considérons le langage des commandes habituelles ([CSkip],
    [CSeq], [CWhile]) étendu avec une commande décrémentant une
    variable ([CDecr]). *)

Inductive com : Type :=
  | CSkip : com
  | CSeq : com -> com -> com
  | CWhile : bexp -> com -> com
  | CDecr : id -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '--'" :=
  (CDecr x) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).

(** QUESTION [difficulté [***] / longueur [*]]

    Compléter la sémantique du langage de commandes ci-dessous avec la
    sémantique de [CDecr]. *)

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,

  (*--------------------------------------*)
      SKIP / st \\ st

  | E_Seq : forall c1 c2 st st' st'',

      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
  (*--------------------------------------*)
      (c1 ;; c2) / st \\ st''
  | E_WhileEnd : forall b st c,

      beval st b = false ->
  (*--------------------------------------*)
      (WHILE b DO c END) / st \\ st
  | E_WhileLoop : forall st st' st'' b c,

      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
  (*--------------------------------------*)
      (WHILE b DO c END) / st \\ st''

  | E_DECR : forall st st' x,
      update st x (st x - 1) = st' ->
      (x--) / st \\ update st x (st x - 1)

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

(** Dans ce langage, on peut ainsi écrire le programme suivant, qui
    teste la parité du contenu de la variable [X]: *)

Definition PARITY :=
 WHILE (BLe' 2 X) DO
       X-- ;; X--
 END.

(** QUESTION [difficulté [*] / longueur [*]]

    Prouver que, à partir d'un état mémoire où [X = 4], le résultat de la commande [X--]
    retourne un état où [X = 3]. *)

Example Decr_test:
  X-- / update empty_state X 4 \\ update empty_state X 3.
Proof.
  set (m := update empty_state X 4).
  replace (update empty_state X 3) with (update m X (m X - 1)).
  - apply E_DECR with (update m X (m X - 1)). reflexivity.
  -
    subst m. simpl.
    apply update_shadow.
Qed.

(** QUESTION [difficulté [**] / longueur [***]]

    Prouver que, à partir d'un état mémoire où [X = 4], le test de
    parité retourne [X = 0]. *)

Example PARITY_test:
  PARITY / update empty_state X 4 \\ update empty_state X 0.
Proof.
  unfold PARITY.
  apply E_WhileLoop with (update (update (update empty_state X 4) X 3) X 2).
  - easy.
  - apply E_Seq with (update (update empty_state X 4) X 3).
    + apply E_DECR with (update (update empty_state X 4) X 3).
      easy.
    + apply E_DECR with (update (update (update empty_state X 4) X 3) X 2).
      easy.
  - replace (update (update (update empty_state X 4) X 3) X 2) with
      (update empty_state X 2).
    apply E_WhileLoop with (update (update (update empty_state X 2) X 1)  X 0).
    + easy.
    + apply E_Seq with (update (update empty_state X 2) X 1).
      * apply E_DECR with (update (update empty_state X 2) X 1).
        easy.
      * apply E_DECR with (update (update (update empty_state X 2) X 1) X 0).
        easy.
    + replace (update (update (update empty_state X 2) X 1) X 0) with
      (update empty_state X 0).
      apply E_WhileEnd.
      easy.
      replace (update empty_state X 0) with
      (update (update empty_state X 1) X 0).
      apply eq_sym. f_equal. apply update_shadow. apply update_shadow.
    + replace (update empty_state X 2) with
      (update (update empty_state X 3) X 2).
      apply eq_sym. f_equal. apply update_shadow. apply update_shadow.
Qed.

(** * Logique de Hoare *)

(** Nous obtenons une logique de programme par la construction
    usuelle. *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80).

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
     c / st \\ st'  ->
     P st  -> Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
    (at level 90, c at next level).

(** À partir de ces définitions, nous pouvons spécifier le
    comportement des commandes grâce à la logique de programme. Pour
    [SKIP], [;;] et [WHILE], cela se traduit par les spécifications
    suivantes: *)

Axiom hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} -> P ->> P' ->
  {{P}} c {{Q}}.

Axiom hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} -> Q' ->> Q ->
  {{P}} c {{Q}}.

Axiom hoare_skip : forall P,
     {{P}} SKIP {{P}}.

Axiom hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} -> {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Axiom hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.

(** QUESTION [difficulté [***] / longueur [*]]

    Sur le modèle de l'assignation (vu en cours), donner et prouver la
    spécification la plus précise possible pour l'opération de
    décrémentation. *)

Definition assn_sub X P : Assertion :=
  fun (st : state) => P (update st X (st X - 1)).

Notation "P '[' X '--]'" := (assn_sub X P) (at level 10).

Theorem hoare_decr : forall Q X,
    {{Q [X --]}}  X--  {{Q}}.

Proof.
  unfold hoare_triple.
  intros Q X st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ.
  assumption.
Qed.

(** * Preuve de correction *)

(** Nous souhaitons désormais prouver la correction du programme
    [PARITY] introduit précédemment. Pour cela, il nous faut traduire
    la spécification informelle de [PARITY] par une définition
    formelle dans Coq. *)

(** QUESTION {BONUS} [difficulté [*] / longueur [*]]

    Implémenter la fonction [parity] ci-dessous qui doit retourner [0]
    si son argument est pair et [1] si son argument est impaire. *)

SearchAbout "mod".

Fixpoint parity (x: nat): nat :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S n) => parity n
  end.

Eval compute in parity 3.
Eval compute in parity 8.

(** QUESTION {BONUS} [difficulté [**] / longueur [**]]

    Afin de prouver la correction de [PARITY] vis-à-vis de [parity],
    nous aurons besoin des deux lemmes techniques suivants. *)

Lemma parity_ge_2 : forall x,
  2 <= x ->
  parity (x - 2) = parity x.
Proof.
  intros.
  induction x.
  - easy.
  - SearchPattern (_ <= _ -> _).
    admit.
Qed.

Lemma parity_lt_2 : forall x,
  not (2 <= x) ->
  parity x = x.
Proof.
  intros.
  induction x.
  + easy.
  + admit.
Qed.

(** QUESTION {BONUS} [difficulté [***] / longueur [***]]

    À l'aide de ces résultats et des opérations de la logique de
    programme, prouver la correction de [PARITY]. *)

Theorem parity_correct : forall m,
    {{ fun st => st X = m }}
      PARITY
    {{ fun st => st X = parity m }}.
Proof.
  intros.
  apply hoare_consequence_pre
      with (P' := fun st => parity (st X) = parity m).
  apply hoare_consequence_post
      with (Q' := fun st => parity (st X) = parity m /\ st X < 2).
  - (* Prove: {{ parity X = parity m }} PARITY {{ parity X = parity m /\ X < 2 }} *)
    unfold PARITY.
    admit.
  - (* Prove: parity X = parity m /\ X < 2 -> st X = parity m *)
    unfold assert_implies.
    intros.
    destruct H as [H1 H2].
    rewrite <- H1.
    apply eq_sym.
    apply parity_lt_2.
    SearchPattern (~ _ <= _).
    apply lt_not_le. assumption.
  - (* Prove: X = m -> parity X = parity m *)
    unfold assert_implies.
    intros.
    rewrite <- H.
    reflexivity.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.
Import GRing.
Import FracField.

Section q_tools.
Local Open Scope ring_scope.

Variable (R : rcfType) (q : R).
Hypothesis Hq : q - 1 != 0.

Notation "f ** g" := (fun x => f x * g x) (at level 40).
Notation "f // g" := (fun x => f x / g x) (at level 40).
Notation "a */ f" := (fun x => a * (f x)) (at level 40).

(* tools *)
(* -の分配則*)
Lemma negdistr {V : zmodType} (a b : V) : - (a + b) = - a - b.
Proof.
  have -> : - (a + b) = - a + a - (a + b).
    rewrite [- a + a] addrC.
    rewrite -{2}(add0r a) addrK.
    by rewrite sub0r.
  by rewrite addrKA.
Qed.

Lemma halfdistr m n : ~ odd m ->
  ((m + n)./2 = m./2 + n./2)%N.
Proof.
  move=> em.
  rewrite halfD.
  by case Hm : (odd m).
Qed.

Lemma half_add n : (n.+1 + (n.+1 * n)./2 = (n.+2 * (n.+1))./2)%N.
Proof.
  rewrite -{1}(doubleK n.+1) -halfdistr.
    by rewrite -muln2 -mulnDr addnC addn2 mulnC.
  by rewrite odd_double.
Qed.

Lemma Negz_add m n : Negz (m.+1 + n) = Negz m + Negz n.
Proof. by rewrite !NegzE -addnS (negdistr (Posz m.+1) n.+1)%N. Qed.

Lemma Negz_addK m n : Negz (m + n) + n = Negz m.
Proof.
  rewrite !NegzE addrC -addn1.
  rewrite (_ : Posz (m + n + 1)%N = Posz m + n + 1) //.
  rewrite -[Posz m + n + 1] addrA.
  rewrite [Posz m + (Posz n + 1)] addrC.
  rewrite -[Posz n + 1 + m] addrA.
  rewrite -{1}(add0r (Posz n)).
  by rewrite addrKA -addn1 sub0r addnC.
Qed.

Lemma NegzK n : Posz n.+1 + Negz n = 0.
Proof. by rewrite NegzE addrN. Qed.

Lemma NegzS n : Negz n.+1 + 1 = Negz n.
Proof. by rewrite -addn1 Negz_addK. Qed.

Lemma opp_oppE (x : R) : - - x = x.
Proof. by rewrite -(sub0r x) (opprB 0) subr0. Qed.

Lemma opp_oppE' (x y : R) : - x * - y = x * y.
Proof. by rewrite mulrN mulNr opp_oppE. Qed.

Lemma eq_int_to_nat (m n : nat): m = n:> int -> m = n.
Proof.
  move /eqP.
  rewrite -(eqr_int R) Num.Theory.eqr_nat.
  by move/eqP.
Qed.

Lemma eq_nat_to_int (m n : nat): m = n -> m = n:> int.
Proof. by move=> ->. Qed.

Lemma eq_nat_to_R (m n : nat) : m = n -> (m = n)%R.
Proof. by move=> ->. Qed.

Lemma mulnon0 (a b : R) : a * b != 0 -> a != 0.
Proof.
  move/eqP.
  case_eq (a == 0) => //.
  move/eqP ->.
  by rewrite mul0r.
Qed.

Lemma mulrC23 {V : comRingType} (a b c d : V) :
  a * b * c * d = a * c * b * d.
Proof.
  f_equal.
  by rewrite -!mulrA [b * c]mulrC.
Qed.

Lemma exp0rz' n : (GRing.zero R) ^ (Posz n.+1) = 0.
Proof. by rewrite exprSz mul0r. Qed.

Lemma expnon0 (x : R) (n : nat) : x != 0 -> x ^ n != 0.
Proof.
  move=> Hx.
  elim: n => [|n IH].
  - by rewrite expr0z oner_neq0.
  - by rewrite exprSz mulf_neq0.
Qed.

Lemma exp_gt1 (x : R) (n : nat) : x > 1 -> x ^ n.+1 > 1.
Proof.
  elim: n => [|n IH] Ix //=.
  rewrite exprSz.
  by apply /Num.Theory.mulr_egt1 /IH.
Qed.

(* R上の　add cancel *)
Lemma addrK' {V : zmodType} (a : V) : a - a = 0.
Proof. by rewrite -{1}(add0r a) addrK. Qed.

(* Rの移項 *)
Lemma rtransposition (a b c : R) : a + b = c -> a = c - b.
Proof. by move=> <-; rewrite addrK. Qed.

(* intの移項 *)
Lemma itransposition (l m n : int) : l + m = n -> l = n - m.
Proof. by move=> <-; rewrite addrK. Qed.

Lemma Negz_transp m n l : m + Negz n = l -> m = l + n.+1.
Proof. rewrite NegzE; apply itransposition. Qed.

Lemma same_addl {V : zmodType} {a b} (c : V) : c + a = c + b -> a = b.
Proof.
  move=> H.
  rewrite -(addr0 a) -(addrK' c) addrA [a + c] addrC H.
  by rewrite [c + b] addrC -addrA addrK' addr0.
Qed.

(* 両辺にかける *)
Lemma same_prod {a b} (c : R) : c != 0 -> a * c = b * c -> a = b.
Proof.
  move=> Hc.
  by rewrite -{2}(mulr1 a) -{2}(mulr1 b)
     -(@divff _ c) // !mulrA => ->.
Qed.

Lemma denomK (x y : R) : y != 0 ->
  (x / y) * y = x.
Proof.
  move=> Hy.
  by rewrite -mulrA mulVf // mulr1.
Qed.

(* 右側約分 *)
Lemma red_frac_r (x y z : R) : z != 0 ->
  x * z / (y * z) = x / y.
Proof.
  move=> Hz.
  by rewrite -mulf_div divff // mulr1.
Qed.

(* 左側約分 *)
Lemma red_frac_l (x y z : R) : z != 0 ->
  z * x / (z * y) = x / y.
Proof.
  move=> Hz.
  by rewrite [z * x] mulrC [z * y] mulrC red_frac_r.
Qed.

Lemma opp_frac (x y : R) : - x / - y = x / y.
Proof. by rewrite -mulrN1 -(mulrN1 y) red_frac_r ?oppr_eq0 ?oner_neq0. Qed.

Lemma inv_invE (x : R) : 1 / (1 / x) = x.
Proof. by rewrite divKf // oner_neq0. Qed.

(* 分母共通の和 *)
Lemma add_div (x y z : R) : z != 0 ->
  x / z + y / z = (x + y) / z.
Proof.
  move=> nz0.
  by rewrite addf_div // -mulrDl red_frac_r.
Qed.

(* 頻出分母が0でない *)
Lemma denom_is_nonzero x : x != 0 -> q * x - x != 0.
Proof.
  move=> Hx.
  rewrite -{2}(mul1r x) -mulrBl.
  by apply mulf_neq0.
Qed.

Lemma denom_comm (x y z : R) : x / y / z = x / z / y.
Proof. by rewrite -mulrA [y^-1 / z] mulrC mulrA. Qed.

Lemma sumW {V : zmodType} n (F : nat -> V) :
  \sum_(i < n) F i = \sum_(0 <= i < n) F i.
Proof. by rewrite big_mkord. Qed.

Lemma sum_add {V : zmodType} n (F G : nat -> V) :
  \sum_(0 <= i < n) (F i) + \sum_(0 <= i < n) (G i) =
  \sum_(0 <= i < n) (F i + G i).
Proof.
  elim: n => [|n IH].
  - by rewrite !big_nil addr0.
  - rewrite !(@big_cat_nat _ _ _ n 0 n.+1) //= !big_nat1.
    rewrite -IH -!addrA.
    congr (_ + _).
    by rewrite addrC -addrA [G n + F n]addrC.
Qed.

Lemma sum_sub {V : zmodType} n (F G : nat -> V) :
  \sum_(0 <= i < n) (F i) - \sum_(0 <= i < n) (G i) =
  \sum_(0 <= i < n) (F i - G i).
Proof.
  elim: n => [|n IH].
  - by rewrite !big_nil subr0.
  - rewrite !(@big_cat_nat _ _ _ n 0 n.+1) //= !big_nat1.
    rewrite -IH -!addrA.
    congr (_ + _).
    by rewrite addrC addrA negdistr -addrA [- G n + F n]addrC addrA.
Qed.

Lemma sum_distr {V : comRingType} n (F : nat -> V) (a : V) :
  \sum_(0 <= i < n) (F i * a) = a * \sum_(0 <= i < n) F i.
Proof.
  elim: n => [|n IH].
  - by rewrite !big_nil mulr0.
  - rewrite !(@big_cat_nat _ _ _ n 0 n.+1) //=.
    by rewrite !big_nat1 mulrDr IH [F n * a]mulrC.
Qed.

Lemma hornersumD m n P (a : R) :
  (\sum_(m <= j < n.+1) P j).[a] = (\sum_(m <= j < n.+1) (P j).[a]).
Proof.
  have -> : (m = 0 + m)%N by [].
  rewrite !big_addn.
  elim: (n.+1 - m)%N => {n} [|n IH] //=.
  - by rewrite !big_nil horner0.
  - rewrite (@big_cat_nat _ _ _ n) //= big_nat1.
    rewrite hornerD IH.
    by rewrite [RHS] (@big_cat_nat _ _ _ n) //= big_nat1.
Qed.

Lemma sum_poly_div n F (P : nat -> {poly R}) C x :
  \sum_(0 <= i < n.+1) (F i * (P i).[x] / C i) =
  \sum_(0 <= i < n.+1) (F i * (P i / (C i)%:P).[x]) .
Proof.
  elim: n => [|n IH].
  - by rewrite !big_nat1 hornerM polyCV hornerC mulrA.
  - rewrite !(@big_cat_nat _ _ _ n.+1 0 n.+2) //= IH.
    by rewrite !big_nat1 hornerM polyCV hornerC mulrA.
Qed.

Lemma divpsum n P (d : {poly R}) :
  (\sum_(0 <= i < n) P i) %/ d = \sum_(0 <= i < n) (P i %/ d).
Proof.
elim: n => [|n IH].
- by rewrite !big_nil div0p.
- by rewrite !(@big_cat_nat _ _ _ n 0 n.+1) //= !big_nat1 divpD IH.
Qed.

Lemma polyW (p : {poly R}) n (a : nat -> R) : ((size p) <= n)%N ->
  \poly_(i < size p) (a i * p`_i.+1) =
  \sum_(0 <= i < n) (a i * p`_i.+1) *: 'X^i.
Proof.
  move=> H.
  rewrite poly_def.
  rewrite (@big_cat_nat _ _ _ (size p)) //= big_mkord big_nat -[LHS]addr0.
  f_equal.
  rewrite big1 // => i /andP [Hi _].
  move/leq_sizeP : Hi -> => //.
  by rewrite mulr0 scale0r.
Qed.

Lemma polyW' (p : {poly R}) n (a : nat -> R) : ((size p) <= n)%N ->
  \poly_(i < size p) (a i * p`_i) =
  \sum_(0 <= i < n) (a i * p`_i) *: 'X^i.
Proof.
  move=> H.
  rewrite poly_def.
  rewrite (@big_cat_nat _ _ _ (size p)) //= big_mkord big_nat -[LHS]addr0.
  congr (_ + _).
  rewrite big1 // => i /andP [Hi _].
  move/leq_sizeP : Hi -> => //.
  by rewrite mulr0 scale0r.
Qed.

Lemma size_N0_lt (p : {poly R}) : (size p == 0%N) = false -> (0 < size p)%N.
Proof.
  move=> Hsize.
  rewrite ltn_neqAle.
  apply /andP; split => //.
  move: Hsize.
  by rewrite eq_sym => ->.
Qed.

Lemma scale_constpoly (a c : R) : a *: c%:P = (a * c)%:P.
Proof.
  apply polyP => i.
  rewrite coefZ !coefC.
  case : (i == 0%N) => //.
  by rewrite mulr0.
Qed.

Lemma polyX_div n : (polyX R) ^ n.+1 %/ (polyX R) = (polyX R) ^ n.
Proof.
  by rewrite exprSzr mulpK ?polyX_eq0.
Qed.

Lemma scalerAr' c d (p : {poly R}) j : c * (d *: p)`_j = d * (c * p`_j).
Proof.
  rewrite mulrA (mulrC d) -mulrA.
  f_equal.
  by rewrite coefZ.
Qed.

Lemma scale_div c d (p p' : {poly R}) : d != 0 ->
  (c *: p) %/ (d *: p') = (c / d) *: (p %/ p').
Proof.
  move=> Hd.
  by rewrite divpZl divpZr // scalerA.
Qed.

Local Notation tofrac := (@tofrac [idomainType of {poly R}]).
Local Notation "x %:F" := (tofrac x).

Lemma frac_same_prod (a b c : {fraction [idomainType of {poly R}]}) :
  c != 0 -> a * c = b * c -> a = b.
Proof.
  move=> Hc.
  by rewrite -{2}(mulr1 a) -{2}(mulr1 b)
     -(@divff _ c) // !mulrA => ->.
Qed.
End q_tools.


Set Implicit Arguments.
Require Import TLC.LibLN.
Require Import GStlc.

(*

RS is the declarative specification of subtyping, which
includes the built-in Sym rule.

*)

Inductive RS : Mode -> typ -> typ -> Prop :=
| RSInt : forall m, RS m typ_int typ_int
| RSTB1 : forall A m, RS m A (mode_to_sub m)
| RSFun : forall A B C D m, RS (flip m) A C -> RS m B D -> RS m (typ_arrow A B) (typ_arrow C D)
| RSSym : forall m A B, RS (flip m) B A -> RS m A B.

Hint Constructors RS.

Lemma sound : forall m A B, R m A B -> RS m A B.
  intros.
  induction H; eauto.
Defined.

Lemma complete : forall m A B, RS m A B -> R m A B.
  intros.
  induction H; eauto.
  apply sym2.
  auto.
Defined.

(*

R2 an algorithmic version that exploits duality for economy
of code.

*)

Inductive R2 : bool -> Mode -> typ -> typ -> Prop :=
| R2Int : forall b m, R2 b m typ_int typ_int
| R2TB1 : forall b A m, R2 b m A (mode_to_sub m)
| R2Fun : forall b A B C D m,
    R2 true (flip m) A C ->
    R2 true m B D ->
    R2 b m (typ_arrow A B) (typ_arrow C D)
| R2Sym : forall m A B,
    R2 false (flip m) B A -> R2 true m A B.

Hint Constructors R2.

(* Soundness of R2 *)

Lemma completeR : forall m A B, R m A B -> R2 true m A B.
  intros.
  induction H; eauto.
Defined.

Lemma soundR : forall m b A B, R2 b m A B -> R m A B.
  intros.
  induction H; eauto.
  apply sym2. auto.
Defined.


(* リレー回路 *)
(* 全加算器 Zuseの回路 の正しさの証明 *)
(*
   Prologと違って、autoのときにバックトラックが起きないから、
   正しい項を指定する必要がある。
   Coqの不得意とする問題だろうか。
*)

(*
   rly(S, S, C, C, _) :- !.
   rly(_, _, C, _, C).
*)

Inductive Sig : Set :=
| H : Sig
| L : Sig
| O : Sig.

Inductive rly : Sig -> Sig -> Sig -> Sig -> Sig -> Prop :=
| off0 : forall   c no, rly L L c c no
| off1 : forall   c no, rly H H c c no
| off2 : forall s c no, rly O s c c no
| off3 : forall s c no, rly s O c c no
| on0  : forall   c nc, rly H L c nc c
| on1  : forall   c nc, rly L H c nc c.
Hint Resolve off0 off1 off2 off3 on0 on1 : relay.

(* AND回路 *)
Inductive and_c (x y z : Sig) : Prop :=
  and_c0 : forall u v w,
    rly x L H v u -> rly y L u w z -> and_c x y z.

Check and_c H H H.

Goal and_c H H H.
Proof.
  eapply and_c0.
  apply (on0 H H).
  apply (on0 H H).
Qed.

Goal and_c H H H.
Proof.
  eapply and_c0.
  apply (on0 _ H).
  apply (on0 _ H).
Qed.

Goal and_c H L H.                           (* zはopenなので、Hでも可能 *)
Proof.
  eapply and_c0.
  apply (on0 H H).
  apply (off0 H H).
Qed.

Goal (and_c H L H /\ and_c H L L).
Proof.
  split.
  eapply and_c0.
  apply (on0 H H).
  apply (off0 H H).

  eapply and_c0.
  apply (on0 H H).
  apply (off0 H L).
Qed.

(* 出力もOPENだが、Lを加えればLになってしまう。 *)
Goal and_c O O L.
Proof.
  eapply and_c0.
  apply (off2 L H O).
  apply (off2 L O L).
Qed.

(*
%%
%% Zuseの回路 (dual-rail-carry full adder)
%%
fa(InA, InB, InC, InNotC, OutS, OutC, OutNotC) :-
        rly(InA, 0, OutNotC, I, H),
        rly(InA, 0, InNotC,  K, J),
        rly(InA, 0, InC,     J, K),
        rly(InA, 0, OutC,    N, L),
        rly(InB, 0, InNotC,  H, I),
        rly(InB, 0, OutS,    J, K),
        rly(InB, 0, 1,       I, L),
        rly(InB, 0, InC,     L, N).
*)

Inductive fa (InA InB InC InNotC OutS OutC OutNotC : Sig ) : Prop :=
  fa0 : forall i j k l n h,
    rly InA L OutNotC i h ->
    rly InA L InNotC  k j ->
    rly InA L InC     j k ->
    rly InA L OutC    n l ->
    rly InB L InNotC  h i ->
    rly InB L OutS    j k ->
    rly InB L H       i l ->
    rly InB L InC     l n ->
    fa InA InB InC InNotC (**) OutS OutC OutNotC.

Goal fa L H L H (**)  H L H.
Proof.
  eapply fa0.
  intros.
  apply (off0 H H).
  apply (off0 H L).
  apply (off0 L H).
  apply (off0 L H).
  apply (on0  H H).
  apply (on0  H L).
  apply (on0  H H).
  apply (on0  L H).
Qed.

Goal fa L H L H (**)  H L H.
Proof.
  eapply fa0.
  intros.
  apply (off0 _ H).
  apply (off0 _ L).
  apply (off0 _ _).
  apply (off0 _ H).
  apply (on0  _ _).
  apply (on0  _ _).
  apply (on0  _ _).
  apply (on0  _ _).
Qed.

(* テストケースを生成する *)
Inductive gen : Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Prop :=
(*             入力     出力 *)
| gen000 : gen L L L H  L L H
| gen001 : gen L L H L  H L H
| gen010 : gen L H L H  H L H
| gen011 : gen L H H L  L H L
| gen100 : gen H L L H  H L H
| gen101 : gen H L H L  L H L
| gen110 : gen H H L H  L H L
| gen111 : gen H H H L  H H L.

Goal forall (InA InB InC InNotC OutS OutC OutNotC : Sig),
  gen InA InB InC InNotC OutS OutC OutNotC -> fa InA InB InC InNotC OutS OutC OutNotC.
Proof.
  intros.
  inversion H0.
  (* induction H0 でも同じ。*)

  eapply fa0.                               (* L L L *)
  intros.
  apply (off0 _ H).
  apply (off0 _ L).
  apply (off0 _ _).
  apply (off0 _ L).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).

  eapply fa0.                               (* L L H *)
  intros.
  apply (off0 _ L).
  apply (off0 _ H).
  apply (off0 _ _).
  apply (off0 _ H).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).

  eapply fa0.                               (* L H L *)
  intros.
  apply (off0 _ H).
  apply (off0 _ L).
  apply (off0 _ _).
  apply (off0 _ H).
  apply (on0  _ _).
  apply (on0  _ _).
  apply (on0  _ _).
  apply (on0  _ _).

  eapply fa0.                               (* L H H *)
  intros.
  apply (off0 _ L).
  apply (off0 _ H).
  apply (off0 _ _).
  apply (off0 _ H).
  apply (on0  _ _).
  apply (on0  _ _).
  apply (on0  _ _).
  apply (on0  _ _).

  eapply fa0.                               (* H L L *)
  intros.
  apply (on0  _ H).
  apply (on0  _ L).
  apply (on0  _ _).
  apply (on0  _ L).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).

  eapply fa0.                               (* H L H *)
  intros.
  apply (on0  _ H).
  apply (on0  _ H).
  apply (on0  _ _).
  apply (on0  _ L).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).
  apply (off0 _ _).

  eapply fa0.                               (* H H L *)
  intros.
  apply (on0 _ H).
  apply (on0 _ L).
  apply (on0 _ _).
  apply (on0 _ L).
  apply (on0 _ _).
  apply (on0 _ _).
  apply (on0 _ _).
  apply (on0 _ _).

  eapply fa0.                               (* H H H *)
  intros.
  apply (on0 _ L).
  apply (on0 _ H).
  apply (on0 _ _).
  apply (on0 _ H).
  apply (on0 _ _).
  apply (on0 _ _).
  apply (on0 _ _).
  apply (on0 _ _).
Qed.

(* END *)


Require Export LaugwitzSchmieden.

Module LSw <: Num_w.

Include LS.
(* Definitions in LS are available here thanks to the module type declaration for LS - see above - *)

Parameter w: nat->Z.
Axiom ANS3 : ~lim w.
Axiom Aw : 0<A w.

Axiom lim_lt_w : forall a, lim a/\ leA 0 a -> ltA a w.

Lemma div_modw2 : forall a, w*(a/w) =A a + - (a mod% w).
Proof.
intros a; apply div_mod2.
left; apply Aw.
Qed.

Lemma div_modw3 : forall a, |(a mod% w)| <A w.
Proof.
intros a; apply div_mod3.
apply Aw.
Qed.

End LSw.


Require Import Reals.
Require Import Coquelicot.Coquelicot.
Require Import Psatz.
Require Import Bool.
Require Import network_calculus_def.

Local Open Scope R_scope.
Local Open Scope Rbar_scope.

Definition pseudo_inv_inf (f : ndf_Rbar_Rbar) (y : Rbar) :=
  Rbar_glb (fun x => y <= (f x)).

Definition pseudo_inv_sup (f : ndf_Rbar_Rbar) (y : Rbar) :=
  Rbar_lub (fun x => (f x) <= y).

Theorem pseudo_inv_inf_non_decreasing (f : ndf_Rbar_Rbar) (x y : Rbar) :
  x <= y -> pseudo_inv_inf f x <= pseudo_inv_inf f y.
Proof.
intros H_xy.
assert (H_fxy' := ndf_Rbar_Rbar_prop f _ _ H_xy).
unfold pseudo_inv_inf; set (Ex := fun _ => Rbar_le x _); set (Ey := fun _ => _).
assert (Hx := proj2_sig (Rbar_ex_glb Ex)).
assert (Hy := proj2_sig (Rbar_ex_glb Ey)).
now apply (Rbar_is_glb_subset Ex Ey); [intro x'; apply Rbar_le_trans| |].
Qed.

Lemma Non_decr_recipr (f : ndf_Rbar_Rbar) (x y : Rbar) :
  (f x) < (f y) -> x < y.
Proof.
intro H_fx_fy; apply Rbar_not_le_lt; intro H_xy.
now apply (Rbar_lt_not_le _ _ H_fx_fy), (ndf_Rbar_Rbar_prop f).
Qed.

Lemma ex_el_between x y :
  Rbar_lt x y -> {z : Rbar | Rbar_lt x z /\ Rbar_lt z y}.
Proof.
case x; [intro rx|now exists p_infty|];
  (case y; [intro ry| |now exists m_infty]); intro H_xy.
{ exists ((rx + ry) / 2); revert H_xy; simpl; lra. }
{ exists (rx + 1); simpl; lra. }
{ exists (ry - 1); simpl; lra. }
now exists 0.
Qed.

Lemma alt_def_pseudo_inv_inf (f : ndf_Rbar_Rbar) (y : Rbar) :
  pseudo_inv_inf f y = Rbar_lub (fun x => (f x) < y).
Proof.
apply Rbar_is_glb_unique.
set (Ele := fun x => _ y _); set (Elt := fun x => _).
destruct (Rbar_ex_lub Elt) as [l Hl]; rewrite (Rbar_is_lub_unique _ _ Hl).
split.
{ intros x H_x; apply (proj2 Hl); intros z Hz.
  now apply Rbar_lt_le, (Non_decr_recipr f), (Rbar_lt_le_trans _ _ _ Hz). }
intros b Hb; apply Rbar_not_lt_le; intro H_lb.
destruct (ex_el_between _ _ H_lb) as [m [H_ml H_mb]].
case (Rbar_le_lt_dec y (f m)); intro H_m.
{ now apply (Rbar_lt_not_le _ _ H_mb), Hb. }
now apply (Rbar_lt_not_le _ _ H_ml), (proj1 Hl).
Qed.

Lemma alt_def_pseudo_inv_sup (f : ndf_Rbar_Rbar) (y : Rbar) :
  pseudo_inv_sup f y = Rbar_glb (fun x => y < (f x)).
Proof.
apply Rbar_is_lub_unique.
set (Ele := fun x => _ y _); set (Elt := fun x => _).
destruct (Rbar_ex_glb Ele) as [l Hl]; rewrite (Rbar_is_glb_unique _ _ Hl).
split.
{ intros x H_x; apply (proj2 Hl); intros z Hz.
  now apply Rbar_lt_le, (Non_decr_recipr f), (Rbar_le_lt_trans _ _ _ H_x). }
intros b Hb; apply Rbar_not_lt_le; intro H_lb.
destruct (ex_el_between _ _ H_lb) as [m [H_mb H_ml]].
case (Rbar_le_lt_dec (f m) y); intro H_m.
{ now apply (Rbar_lt_not_le _ _ H_mb), Hb. }
now apply (Rbar_lt_not_le _ _ H_ml), (proj1 Hl).
Qed.

Lemma P4 (f : ndf_Rbar_Rbar) (y : Rbar) :
  (pseudo_inv_inf f y) <= (pseudo_inv_sup f y).
Proof.
  rewrite alt_def_pseudo_inv_inf.
  apply Rbar_lub_subset.
  intros x H_x.
  now apply Rbar_lt_le.
Qed.

Lemma P5 (f : ndf_Rbar_Rbar) (y y' : Rbar) :
  y < y' -> (pseudo_inv_sup f y) <= (pseudo_inv_inf f y').
Proof.
  intros H_yy'.
  rewrite alt_def_pseudo_inv_inf.
  apply Rbar_lub_subset.
  intros x H_x.
  now apply (Rbar_le_lt_trans (f x) y y').
Qed.

Lemma P6 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  (f x) <= y -> x <= (pseudo_inv_sup f y).
Proof.
  intros H.
  destruct (proj2_sig (Rbar_ex_lub (fun x => Rbar_le (f x) y)))as [H_ub _].
  now apply H_ub.
Qed.

Lemma P7 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  y <= (f x) -> (pseudo_inv_inf f y) <= x.
Proof.
  intros H.
  destruct (proj2_sig (Rbar_ex_glb (fun x => Rbar_le y (f x))))as [H_ub _].
  now apply H_ub.
Qed.

Lemma P8 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  (f x) < y -> x <= (pseudo_inv_inf f y).
Proof.
  intros H.
  rewrite alt_def_pseudo_inv_inf.
  destruct (proj2_sig (Rbar_ex_lub (fun x => Rbar_lt (f x) y)))as [H_ub _].
  now apply H_ub.
Qed.

Lemma P9 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  y < (f x) -> (pseudo_inv_sup f y) <= x.
Proof.
  intros H.
  rewrite alt_def_pseudo_inv_sup.
  destruct (proj2_sig (Rbar_ex_glb (fun x => Rbar_lt y (f x))))as [H_lb _].
  now apply H_lb.
Qed.

Lemma P10 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  (pseudo_inv_inf f y) < x -> y <= (f x).
Proof.
  rewrite alt_def_pseudo_inv_inf.
  set (Elt := fun _ => _).
  intro H.
  apply Rbar_not_lt_le.
  intro H0.
  destruct (proj2_sig (Rbar_ex_lub Elt)) as [H_ub _].
  exact ((Rbar_lt_not_le _ _ H) (H_ub _ H0)).
Qed.

Lemma P11 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  x < (pseudo_inv_sup f y) -> (f x) <= y.
Proof.
  rewrite alt_def_pseudo_inv_sup.
  set (Elt := fun _ => _).
  intro H.
  apply Rbar_not_lt_le.
  intro H0.
  destruct (proj2_sig (Rbar_ex_glb Elt)) as [H_lb _].
  exact ((Rbar_lt_not_le _ _ H) (H_lb _ H0)).
Qed.

Lemma P12 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  (pseudo_inv_sup f y) < x -> y < (f x).
Proof.
  unfold pseudo_inv_sup; set (Ele := fun _ => _).
  intro H.
  apply Rbar_not_le_lt.
  intro H0.
  destruct (proj2_sig (Rbar_ex_lub Ele)) as [H_ub _].
  exact ((Rbar_lt_not_le _ _ H) (H_ub _ H0)).
Qed.

Lemma P14 (f : ndf_Rbar_Rbar) (x y : Rbar) :
  x < (pseudo_inv_inf f y) -> (f x) < y.
Proof.
  unfold pseudo_inv_inf; set (Ele := fun _ => _).
  intro H.
  apply Rbar_not_le_lt.
  intro H0.
  destruct (proj2_sig (Rbar_ex_glb Ele)) as [H_lb _].
  exact ((Rbar_lt_not_le _ _ H) (H_lb _ H0)).
Qed.


Require Import Coq.Setoids.Setoid.
Require Import New.Ring.
Require Import New.RingTheorems.
Require Import New.Field.

(* Basic complex operations *)
Class ComplexOps A := {
  complex_conj : A -> A
}.

(* Unorthodox notation *)
Notation "~ x" := (complex_conj x).

Class ComplexProps A {cops : ComplexOps A} := {
  complex_conj_inv : forall (x : A), (~ (~ x)) = x;
  complex_conj_ext : forall a b : A, a = b <-> (~ a) = (~ b)
}.

Class ComplexSemiRingProps A {cops : ComplexOps A} {srops : SemiRingOps A} := {
  conj_sum : forall a b : A, (~ (a + b)) = (~ a) + (~ b);
  conj_mul : forall a b : A, (~ (a * b)) = (~ b) * (~ a);
  zero_self_conj : (~ 0) = 0
}.

(* Type which builds complex numbers out of an underlying type *)
Record Complex A := {
  real_part : A;
  imaginary_part : A
}.

Function complex_conj_impl {A} {rops : RingOps A} (x : Complex A) :=
  {| real_part := real_part A x; imaginary_part := - imaginary_part A x |}.

Instance ComplexImplOps A {rops : RingOps A} {ra : Ring A} :
  ComplexOps (Complex A) := {
  complex_conj := complex_conj_impl
}.

Lemma complex_conj_impl_inv {A} {rops : RingOps A} {ra : Ring A} :
  forall a : Complex A, complex_conj_impl (complex_conj_impl a) = a.
Proof.
  intros.
  unfold complex_conj_impl.
  elim a.
  intros.
  f_equal.
  unfold imaginary_part.
  rewrite neg_inv.
  reflexivity.
Qed.

Lemma complex_conj_impl_ext {A} {rops : RingOps A} {ra : Ring A} :
  forall a b : Complex A, a = b <-> (complex_conj_impl a) = (complex_conj_impl b).
Proof.
  intros.
  unfold complex_conj_impl.
  elim a.
  elim b.
  unfold real_part.
  unfold imaginary_part.
  intros.
  unfold iff.
  split.
  intro.
  injection H.
  intros.
  f_equal.
  assumption.
  f_equal.
  assumption.
  intro.
  injection H.
  intros.
  f_equal.
  assumption.
  rewrite <- neg_inv.
  rewrite <- neg_inv at 1.
  f_equal.
  assumption.
Qed.

Instance ComplexImplProps A {rops : RingOps A} {ra : Ring A} :
  ComplexProps (Complex A) := {
  complex_conj_inv := complex_conj_impl_inv;
  complex_conj_ext := complex_conj_impl_ext
}.

Definition complex_zero {A} {rops : RingOps A} : Complex A :=
  {| real_part := 0; imaginary_part := 0 |}.

Definition complex_one {A} {rops : RingOps A} : Complex A :=
  {| real_part := 1; imaginary_part := 0 |}.

Lemma complex_zero_self_conj {A} {rops : RingOps A} {rna : Ring A} :
  (complex_conj_impl complex_zero) = complex_zero.
Proof.
  unfold complex_conj_impl.
  unfold complex_zero.
  unfold imaginary_part.
  f_equal.
  apply zero_self_inv.
Qed.

Function complex_add {A} {rops : SemiRingOps A} (x y : Complex A) :=
  {| real_part := real_part A x + real_part A y;
     imaginary_part := imaginary_part A x + imaginary_part A y |}.

Lemma conj_impl_sum {A} {rops : RingOps A} {rna : Ring A} :
  forall a b : Complex A, complex_conj_impl (complex_add a b) =
                          complex_add (complex_conj_impl a) (complex_conj_impl b).
Proof.
  intros.
  unfold complex_conj_impl.
  unfold complex_add.
  elim a.
  elim b.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  apply neg_add.
Qed.

Function complex_mul {A} {rops : RingOps A} (x y : Complex A) :=
  {| real_part := real_part A x * real_part A y -
                  imaginary_part A x * imaginary_part A y;
     imaginary_part := real_part A x * imaginary_part A y +
                       imaginary_part A x * real_part A y |}.

Lemma conj_impl_mul {A} {rops : RingOps A} {rna : Ring A} :
  forall a b : Complex A, (complex_conj_impl (complex_mul a b)) =
                          complex_mul (complex_conj_impl b) (complex_conj_impl a).
Proof.
  intros.
  unfold complex_conj_impl.
  unfold complex_mul.
  elim a.
  elim b.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite mul_comm.
  rewrite 2! sub_def.
  apply add_extensional.
  reflexivity.
  rewrite <- neg_mul.
  rewrite neg_inv.
  rewrite mul_comm.
  apply neg_mul_left.
  rewrite <- neg_mul.
  rewrite <- neg_mul_left.
  rewrite neg_add.
  rewrite add_comm.
  rewrite mul_comm.
  apply add_extensional.
  reflexivity.
  rewrite mul_comm.
  reflexivity.
Qed.

Instance ComplexSemiRingOps A {rops : RingOps A} : SemiRingOps (Complex A) := {
  zero := complex_zero;
  one := complex_one;
  add := complex_add;
  mul := complex_mul
}.

Instance ComplexImplSemiRingProps {A}
  {rops : RingOps A}
  {rna : Ring A} :
  ComplexSemiRingProps (Complex A) := {
  conj_sum := conj_impl_sum;
  conj_mul := conj_impl_mul;
  zero_self_conj := complex_zero_self_conj
}.

Function complex_sub {A} {rops : RingOps A} (x y : Complex A) :=
  {| real_part := real_part A x - real_part A y;
     imaginary_part := imaginary_part A x - imaginary_part A y |}.

Function complex_neg {A} {rops : RingOps A} (x : Complex A) :=
  {| real_part := - real_part A x; imaginary_part := - imaginary_part A x |}.

Lemma complex_sub_def {A} {rops : RingOps A} :
  forall (x y : Complex A), complex_sub x y = complex_add x (complex_neg y).
Proof.
  intros.
  unfold complex_add.
  unfold complex_neg.
  unfold complex_sub.
  elim x.
  elim y.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  apply sub_def.
  apply sub_def.
Qed.

Lemma complex_sub_zero {A} {rops : RingOps A} :
  forall (x : Complex A), complex_sub x x = zero.
Proof.
  intro.
  unfold complex_sub.
  elim x.
  unfold real_part.
  unfold imaginary_part.
  intros.
  rewrite 2! sub_zero.
  reflexivity.
Qed.

Instance ComplexRingOps A {rops : RingOps A} : RingOps (Complex A) := {
  rops := ComplexSemiRingOps A;
  sub := complex_sub;
  neg := complex_neg;
  sub_def := complex_sub_def;
  sub_zero := complex_sub_zero
}.

Lemma complex_add_extensional {A} {rops : RingOps A} :
  forall x1 x2 y1 y2 : (Complex A),
    x1 = x2 -> y1 = y2 -> complex_add x1 y1 = complex_add x2 y2.
Proof.
  intros.
  unfold complex_add.
  rewrite H.
  rewrite H0.
  reflexivity.
Qed.

Lemma complex_mul_extensional {A} {rops : RingOps A} :
  forall x1 x2 y1 y2 : (Complex A),
    x1 = x2 -> y1 = y2 -> complex_mul x1 y1 = complex_mul x2 y2.
Proof.
  intros.
  unfold complex_mul.
  rewrite H.
  rewrite H0.
  reflexivity.
Qed.

Lemma complex_add_comm {A} {rops : RingOps A} {sring : SemiRingNoAssoc A} :
  forall a b : (Complex A), complex_add a b = complex_add b a.
Proof.
  intros.
  unfold complex_add.
  elim a.
  elim b.
  intros.
  f_equal.
  apply add_comm.
  apply add_comm.
Qed.

Lemma complex_mul_comm {A} {rops : RingOps A} {sring : SemiRingNoAssoc A} :
  forall a b : (Complex A), complex_mul a b = complex_mul b a.
Proof.
  intros.
  unfold complex_mul.
  elim a.
  elim b.
  intros.
  f_equal.
  rewrite 2! sub_def.
  apply add_extensional.
  apply mul_comm.
  rewrite mul_comm.
  reflexivity.
  rewrite add_comm.
  apply add_extensional.
  apply mul_comm.
  apply mul_comm.
Qed.

Lemma complex_add_mul_dist {A} {rops : RingOps A} {ring : Ring A} :
  forall a b c : (Complex A),
    complex_mul a (complex_add b c) =
    complex_add (complex_mul a b) (complex_mul a c).
Proof.
  intros.
  unfold complex_mul.
  unfold complex_add.
  elim a.
  elim b.
  elim c.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite 2! add_mul_dist.
  rewrite 3! sub_def.
  rewrite neg_add.
  rewrite 2! add_assoc.
  apply add_extensional.
  rewrite add_comm.
  rewrite add_assoc.
  apply add_extensional.
  apply add_comm.
  reflexivity.
  reflexivity.
  rewrite 2! add_mul_dist.
  rewrite 2! add_assoc.
  apply add_extensional.
  rewrite add_comm.
  rewrite add_assoc.
  apply add_extensional.
  apply add_comm.
  reflexivity.
  reflexivity.
Qed.

Lemma complex_add_zero {A} {rops : RingOps A} {sring : SemiRingNoAssoc A} :
  forall a : (Complex A), complex_add a complex_zero = a.
Proof.
  intros.
  unfold complex_add.
  unfold complex_zero.
  elim a.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  apply add_zero_right.
  apply add_zero_right.
Qed.

Lemma complex_mul_zero {A} {rops : RingOps A} {sring : SemiRingNoAssoc A} :
  forall a : (Complex A), complex_mul a complex_zero = complex_zero.
Proof.
  intros.
  unfold complex_mul.
  unfold complex_zero.
  elim a.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite 2! mul_zero_right.
  apply sub_zero.
  rewrite 2! mul_zero_right.
  apply add_zero_right.
Qed.

Lemma complex_mul_one {A} {rops : RingOps A} {ring : RingNoAssoc A} :
  forall a : (Complex A), complex_mul a complex_one = a.
Proof.
  intros.
  unfold complex_mul.
  unfold complex_one.
  elim a.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite mul_zero_right.
  rewrite sub_def.
  rewrite zero_self_inv.
  rewrite add_zero_right.
  apply mul_one_right.
  rewrite mul_zero_right.
  rewrite add_comm.
  rewrite add_zero_right.
  apply mul_one_right.
Qed.

Instance ComplexSemiRingNoAssoc A
  {rops : RingOps A}
  {ring : Ring A} :
  SemiRingNoAssoc (Complex A) := {
  add_extensional := complex_add_extensional;
  mul_extensional := complex_mul_extensional;
  add_comm := complex_add_comm;
  mul_comm := complex_mul_comm;
  add_mul_dist := complex_add_mul_dist;
  add_zero_right := complex_add_zero;
  mul_zero_right := complex_mul_zero;
  mul_one_right := complex_mul_one
}.

Lemma complex_neg_add {A}
  {rops : RingOps A}
  {ring : RingNoAssoc A} :
    forall a b : (Complex A),
      complex_neg (complex_add a b) = complex_add (complex_neg a) (complex_neg b).
Proof.
  intros.
  unfold complex_neg.
  unfold complex_add.
  elim a.
  elim b.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  apply neg_add.
  apply neg_add.
Qed.

Lemma complex_neg_mul {A}
  {rops : RingOps A}
  {ring : RingNoAssoc A} :
    forall a b : (Complex A),
      complex_neg (complex_mul a b) = complex_mul a (complex_neg b).
Proof.
  intros.
  unfold complex_neg.
  unfold complex_mul.
  elim a.
  elim b.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite <- 2! neg_mul.
  apply neg_sub.
  rewrite <- 2! neg_mul.
  apply neg_add.
Qed.

Lemma complex_neg_add_inv {A} {rops : RingOps A} {ring : RingNoAssoc A} :
  forall a : (Complex A), complex_add (complex_neg a) a = complex_zero.
Proof.
  intro.
  unfold complex_add.
  unfold complex_neg.
  unfold complex_zero.
  elim a.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite add_comm.
  rewrite <- sub_def.
  apply sub_zero.
  rewrite add_comm.
  rewrite <- sub_def.
  apply sub_zero.
Qed.

Instance ComplexRingNoAssoc A
  {rops : RingOps A}
  {ring : Ring A} :
  RingNoAssoc (Complex A) := {
  semiring_no_assoc_r := ComplexSemiRingNoAssoc A;
  neg_add := complex_neg_add;
  neg_mul := complex_neg_mul;
  neg_add_inv := complex_neg_add_inv
}.

Lemma complex_add_assoc {A} {rops : RingOps A} {sring : SemiRing A} :
  forall a b c : (Complex A),
    complex_add a (complex_add b c) = complex_add (complex_add a b) c.
Proof.
  intros.
  unfold complex_add.
  elim a.
  elim b.
  elim c.
  intros.
  f_equal.
  apply add_assoc.
  apply add_assoc.
Qed.

Lemma complex_mul_assoc {A} {rops : RingOps A} {ring : Ring A} :
  forall a b c : (Complex A),
    complex_mul a (complex_mul b c) = complex_mul (complex_mul a b) c.
Proof.
  intros.
  unfold complex_mul.
  elim a.
  elim b.
  elim c.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite add_mul_dist.
  rewrite sub_mul_dist.
  rewrite 4! mul_assoc at 1.
  rewrite 2! sub_def at 1.
  rewrite neg_add.
  rewrite add_assoc.
  rewrite add_comm.
  rewrite <- add_assoc.
  rewrite <- neg_add.
  rewrite <- add_mul_dist_right.
  rewrite add_assoc.
  rewrite <- sub_def.
  rewrite add_comm.
  rewrite <- sub_def.
  rewrite <- sub_mul_dist_right.
  reflexivity.
  rewrite add_mul_dist.
  rewrite sub_mul_dist.
  rewrite 4! mul_assoc at 1.
  rewrite sub_def at 1.
  rewrite add_assoc.
  rewrite add_comm.
  rewrite <- add_assoc.
  rewrite <- add_mul_dist_right.
  rewrite add_assoc.
  apply add_extensional.
  rewrite add_comm.
  rewrite <- sub_def.
  rewrite <- sub_mul_dist_right.
  reflexivity.
  reflexivity.
Qed.

Instance ComplexSemiRing A
  {rops : RingOps A}
  {ring : Ring A} :
  SemiRing (Complex A) := {
  semiring_no_assoc_s := ComplexSemiRingNoAssoc A;
  add_assoc := complex_add_assoc;
  mul_assoc := complex_mul_assoc
}.

Instance ComplexRing A
  {rops : RingOps A}
  {ring : Ring A} :
  Ring (Complex A) := {
  semiring_r := ComplexSemiRing A;
  ring_noassoc := ComplexRingNoAssoc A
}.

Function complex_recip {A} {rops : FieldOps A} (x : (Complex A)) :=
  {| real_part :=
       real_part A x / (real_part A x * real_part A x +
                        imaginary_part A x *imaginary_part A x);
     imaginary_part :=
       - imaginary_part A x / (real_part A x * real_part A x +
                               imaginary_part A x *imaginary_part A x) |}.

Function complex_div {A} {rops : FieldOps A} (x y : (Complex A)) :=
  {| real_part :=
       (real_part A x * real_part A y +
        imaginary_part A x * imaginary_part A y) /
       (real_part A y * real_part A y +
        imaginary_part A y *imaginary_part A y);
     imaginary_part :=
       (real_part A y * imaginary_part A x -
        real_part A x * imaginary_part A y) /
       (real_part A y * real_part A y +
        imaginary_part A y *imaginary_part A y) |}.

Instance ComplexFieldOps A
  {rops : FieldOps A} :
  FieldOps (Complex A) := {
  rops := ComplexRingOps A;
  div := complex_div;
  recip := complex_recip
}.

Lemma complex_div_def {A} {rops : FieldOps A} {field : Field A} :
  forall (x y : Complex A), complex_div x y = complex_mul x (complex_recip y).
Proof.
  intros.
  unfold complex_div.
  unfold complex_recip.
  unfold complex_mul.
  elim x.
  elim y.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite 3! div_def.
  rewrite 2! mul_assoc.
  rewrite <- sub_mul_dist_right.
  rewrite <- neg_mul.
  rewrite sub_def.
  rewrite neg_inv.
  reflexivity.
  rewrite 3! div_def.
  rewrite 2! mul_assoc.
  rewrite <- add_mul_dist_right.
  f_equal.
  rewrite add_comm.
  rewrite <- neg_mul.
  rewrite mul_comm at 1.
  apply sub_def.
Qed.

Lemma complex_recip_mul_inv {A} {rops : FieldOps A} {field : Field A} :
  forall a : (Complex A), complex_mul (complex_recip a) a = complex_one.
Proof.
  intros.
  rewrite complex_mul_comm.
  rewrite <- complex_div_def.
  unfold complex_div.
  unfold complex_one.
  elim a.
  unfold real_part.
  unfold imaginary_part.
  intros.
  f_equal.
  rewrite div_def.
  rewrite mul_comm.
  apply recip_mul_inv.
  rewrite sub_zero.
  rewrite div_def.
  apply mul_zero_left.
Qed.

Instance ComplexFieldAxioms A
  {rops : FieldOps A}
  {field : Field A} :
  FieldAxioms (Complex A) := {
  div_def := complex_div_def;
  recip_mul_inv := complex_recip_mul_inv
}.

Instance ComplexFieldNoAssoc A
  {fops : FieldOps A}
  {field : Field A} :
  FieldNoAssoc (Complex A) := {
  ring_no_assoc_fna := ComplexRingNoAssoc A;
  axioms_fna := ComplexFieldAxioms A
}.

Instance ComplexField A
  {fops : FieldOps A}
  {field : Field A} :
  Field (Complex A) := {
  ring_f := ComplexRing A;
  axioms_f := ComplexFieldAxioms A
}.


From QuickChick Require Import QuickChick GenLow GenHigh.
Require Import NPeano Omega.

From mathcomp Require Import ssreflect ssrnat ssrbool eqtype.

From QuickChick.RedBlack Require Import redblack.

Require Import List String.
Import ListNotations.

Open Scope string.

Open Scope Checker_scope.

(* Red-Black Tree invariant: executable definition *)

Fixpoint black_height_bool (t: tree) : option nat :=
  match t with
    | Leaf => Some 0
    | Node c tl _ tr =>
      let h1 := black_height_bool tl in
      let h2 := black_height_bool tr in
      match h1, h2 with
        | Some n1, Some n2 =>
          if n1 == n2 then
            match c with
              | Black => Some (S n1)
              | Red => Some n1
            end
          else None
        | _, _ => None
      end
  end.

Definition is_black_balanced (t : tree) : bool :=
  isSome (black_height_bool t).

Fixpoint has_no_red_red (c : color) (t : tree) : bool :=
  match t with
    | Leaf => true
    | Node Red t1 _ t2 =>
      match c with
        | Red => false
        | Black => has_no_red_red Red t1 && has_no_red_red Red t2
      end
    | Node Black t1 _ t2 =>
      has_no_red_red Black t1 && has_no_red_red Black t2
  end.

(* begin is_redblack_bool *)
Definition is_redblack_bool (t : tree) : bool :=
  is_black_balanced t && has_no_red_red Red t.
(* end is_redblack_bool *)

Fixpoint showColor (c : color) :=
  match c with
    | Red => "Red"
    | Black => "Black"
  end.

Fixpoint tree_to_string (t : tree) :=
  match t with
    | Leaf => "Leaf"
    | Node c l x r => "Node " ++ showColor c ++ " "
                            ++ "(" ++ tree_to_string l ++ ") "
                            ++ show x ++ " "
                            ++ "(" ++ tree_to_string r ++ ")"
  end.

Instance showTree {A : Type} `{_ : Show A} : Show tree :=
  {|
    show t := "" (* CH: tree_to_string t causes a 9x increase in runtime *)
  |}.

(* begin insert_preserves_redblack_checker *)
Definition insert_preserves_redblack_checker (genTree : G tree) : Checker :=
  forAll arbitrary (fun n => forAll genTree (fun t =>
    is_redblack_bool t ==> is_redblack_bool (insert n t))).
(* end insert_preserves_redblack_checker *)

Import QcDefaultNotation. Open Scope qc_scope.

(* begin genAnyTree *)
Definition genColor := elems [Red; Black].
Fixpoint genAnyTree_depth (d : nat) : G tree :=
  match d with
    | 0 => returnGen Leaf
    | S d' => freq [(1, returnGen Leaf);
                    (9, liftGen4 Node genColor (genAnyTree_depth d')
                                     arbitrary (genAnyTree_depth d'))]
  end.
Definition genAnyTree : G tree := sized genAnyTree_depth.
(* end genAnyTree *)

Extract Constant defSize => "10".

Definition test_naive :=
  insert_preserves_redblack_checker genAnyTree.
(* begin QC_naive *)
(*! QuickChick test_naive. *)
(* end QC_naive *)

(* gathering some size statistics *)
Fixpoint tree_size (t : tree) : nat :=
  match t with
    | Leaf => 1
    | Node c tl _ tr => 1 + (tree_size tl) + (tree_size tr)
  end.

Definition insert_preserves_redblack_checker_size (genTree : G tree) : Checker :=
  forAll arbitrary (fun n => forAll genTree (fun t =>
    collect (append "size " (show (tree_size t)))
    (is_redblack_bool t ==> is_redblack_bool (insert n t)))).

(*
Extract Constant Test.defNumTests => "100000".
QuickChick (insert_preserves_redblack_checker_size genAnyTree).
*)

Module DoNotation.
Import ssrfun.
Notation "'do!' X <- A ; B" :=
  (bindGen A (fun X => B))
  (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.
Import DoNotation.

Require Import Relations Wellfounded Lexicographic_Product.

Definition ltColor (c1 c2: color) : Prop :=
  match c1, c2 with
    | Red, Black => True
    | _, _ => False
  end.

Lemma well_foulded_ltColor : well_founded ltColor.
Proof.
  unfold well_founded.
  intros c; destruct c;
  repeat (constructor; intros c ?; destruct c; try now (exfalso; auto)).
Qed.

Definition sigT_of_prod {A B : Type} (p : A * B) : {_ : A & B} :=
  let (a, b) := p in existT (fun _ : A => B) a b.

Definition prod_of_sigT {A B : Type} (p : {_ : A & B}) : A * B :=
  let (a, b) := p in (a, b).

Definition wf_hc (c1 c2 : (nat * color)) : Prop :=
  lexprod nat (fun _ => color) lt (fun _ => ltColor) (sigT_of_prod c1) (sigT_of_prod c2).

Lemma well_founded_hc : well_founded wf_hc.
Proof.
  unfold wf_hc. apply wf_inverse_image.
  apply wf_lexprod. now apply Wf_nat.lt_wf. intros _; now apply well_foulded_ltColor.
Qed.

Require Import Program.Wf. Import WfExtensionality.
Require Import FunctionalExtensionality.

(* begin genRBTree_height *)
Program Fixpoint genRBTree_height (hc : nat*color) {wf wf_hc hc} : G tree :=
  match hc with
  | (0, Red) => returnGen Leaf
  | (0, Black) => oneOf [returnGen Leaf;
                    (do! n <- arbitrary; returnGen (Node Red Leaf n Leaf))]
  | (S h, Red) => liftGen4 Node (returnGen Black) (genRBTree_height (h, Black))
                                        arbitrary (genRBTree_height (h, Black))
  | (S h, Black) => do! c' <- genColor;
                    let h' := match c' with Red => S h | Black => h end in
                    liftGen4 Node (returnGen c') (genRBTree_height (h', c'))
                                       arbitrary (genRBTree_height (h', c')) end.
(* end genRBTree_height *)
Next Obligation.
  unfold wf_hc; simpl; left; omega.
Qed.
Next Obligation.
  unfold wf_hc; simpl; left; omega.
Qed.
Next Obligation.
  unfold wf_hc; simpl; destruct c'; [right; apply I | left; omega].
Qed.
Next Obligation.
  unfold wf_hc; simpl; destruct c'; [right; apply I | left; omega].
Qed.
Next Obligation.
  abstract (apply well_founded_hc).
Defined.

Lemma genRBTree_height_eq (hc : nat*color) :
  genRBTree_height hc =
  match hc with
  | (0, Red) => returnGen Leaf
  | (0, Black) => oneOf [returnGen Leaf;
                    (do! n <- arbitrary; returnGen (Node Red Leaf n Leaf))]
  | (S h, Red) => liftGen4 Node (returnGen Black) (genRBTree_height (h, Black))
                                        arbitrary (genRBTree_height (h, Black))
  | (S h, Black) => do! c' <- genColor;
                    let h' := match c' with Red => S h | Black => h end in
                    liftGen4 Node (returnGen c') (genRBTree_height (h', c'))
                                       arbitrary (genRBTree_height (h', c')) end.
Proof.
  unfold_sub genRBTree_height (genRBTree_height hc).
  f_equal. destruct hc as [[|h] [|]]; try reflexivity.
  f_equal. apply functional_extensionality => [[|]]; reflexivity.
Qed.

(* Hope that this is enough for preventing unfolding genRBTree_height *)
Global Opaque genRBTree_height.

(* begin genRBTree *)
Definition genRBTree := bindGen arbitrary (fun h => genRBTree_height (h, Red)).
(* end genRBTree *)

Definition showDiscards (r : Result) :=
  match r with
  | Success ns nd _ _ => "Success: number of successes " ++ show (ns-1) ++ newline ++
                         "         number of discards "  ++ show nd ++ newline
  | _ => show r
  end.

Definition testInsert :=
  showDiscards (quickCheck (insert_preserves_redblack_checker genRBTree)).

Extract Constant defSize => "10".
Definition test_smart :=
  (insert_preserves_redblack_checker genRBTree).
(* begin QC_good *)
(*! QuickChick test_smart. *)
(* end QC_good *)

(* gathering some size statistics
Extract Constant Test.defNumTests => "100000".
QuickChick (insert_preserves_redblack_checker_size genRBTree).
*)