(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: NZAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import NZAxioms NZBase NZMul NZOrder.

Module Type NZAddOrderPropSig (Import NZ : NZOrdAxiomsSig').
Include NZBasePropSig NZ <+ NZMulPropSig NZ <+ NZOrderPropSig NZ.

Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m.
Proof.
intros n m p; nzinduct p. now nzsimpl.
intro p. nzsimpl. now rewrite <- succ_lt_mono.
Qed.

Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p.
Proof.
intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l.
Qed.

Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q.
Proof.
intros n m p q H1 H2.
apply lt_trans with (m + p);
[now apply -> add_lt_mono_r | now apply -> add_lt_mono_l].
Qed.

Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m.
Proof.
intros n m p; nzinduct p. now nzsimpl.
intro p. nzsimpl. now rewrite <- succ_le_mono.
Qed.

Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p.
Proof.
intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l.
Qed.

Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
Proof.
intros n m p q H1 H2.
apply le_trans with (m + p);
[now apply -> add_le_mono_r | now apply -> add_le_mono_l].
Qed.

Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q.
Proof.
intros n m p q H1 H2.
apply lt_le_trans with (m + p);
[now apply -> add_lt_mono_r | now apply -> add_le_mono_l].
Qed.

Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q.
Proof.
intros n m p q H1 H2.
apply le_lt_trans with (m + p);
[now apply -> add_le_mono_r | now apply -> add_lt_mono_l].
Qed.

Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono.
Qed.

Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
Qed.

Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
Qed.

Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono.
Qed.

Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m.
Proof.
intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl.
Qed.

Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n.
Proof.
intros; rewrite add_comm; now apply lt_add_pos_l.
Qed.

Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q.
Proof.
intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption].
contradict H2. rewrite nlt_ge. now apply add_le_mono.
Qed.

Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q.
Proof.
intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption].
contradict H2. rewrite nle_gt. now apply add_le_lt_mono.
Qed.

Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q.
Proof.
intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |].
contradict H2. rewrite nle_gt. now apply add_lt_le_mono.
Qed.

Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q.
Proof.
intros n m p q H;
destruct (le_gt_cases p n) as [H1 | H1]; [| now left].
destruct (le_gt_cases q m) as [H2 | H2]; [| now right].
contradict H; rewrite nlt_ge. now apply add_le_mono.
Qed.

Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q.
Proof.
intros n m p q H.
destruct (le_gt_cases n p) as [H1 | H1]. now left.
destruct (le_gt_cases m q) as [H2 | H2]. now right.
contradict H; rewrite nle_gt. now apply add_lt_mono.
Qed.

Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0.
Proof.
intros n m H; apply add_lt_cases; now nzsimpl.
Qed.

Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m.
Proof.
intros n m H; apply add_lt_cases; now nzsimpl.
Qed.

Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0.
Proof.
intros n m H; apply add_le_cases; now nzsimpl.
Qed.

Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m.
Proof.
intros n m H; apply add_le_cases; now nzsimpl.
Qed.

End NZAddOrderPropSig.


From Coq Require Import Lia.
From mathcomp Require Import ssreflect ssrnat eqtype ssrbool ssrfun seq.
From mathcomp Require Import finmap fintype choice.

Open Scope fmap_scope.
Open Scope fset_scope.

Ltac ssrnatify_rel :=
 match goal with
  (* less or equal (also codes for strict comparison in ssrnat) *)
  | H : is_true (leq _ _) |- _ => move/leP: H => H
  | H : context [ is_true (leq ?a ?b)] |- _ =>
     rewrite <- (rwP (@leP a b)) in H
  | |- is_true (leq _ _) => apply/leP
  | |- context [ is_true (leq ?a ?b)] => rewrite <- (rwP (@leP a b))
  (* Boolean equality *)
  | H : is_true (@eq_op _ _ _) |- _ => move/eqP: H => H
  | |- is_true (@eq_op _ _ _) => apply/eqP
  | H : context [ is_true (@eq_op _ _ _)] |- _ =>
     rewrite <-  (rwP (@eqP _ _ _)) in H
  | |- context [ is_true (@eq_op _ ?x ?y)] => rewrite <- (rwP (@eqP _ x y))
  (* Negated boolean equality *)
  | H : is_true (negb (@eq_op _  _ _)) |- _ => move/eqP: H => H
  | |- is_true (negb (@eq_op _  _ _)) => apply/eqP
  | H : context [ is_true (negb (@eq_op _ _ _))] |- _ =>
     rewrite <-  (rwP (@eqP _ _ _)) in H
  | |- context [ is_true (negb (@eq_op _ ?x ?y))] =>
     rewrite <- (rwP (@eqP _ x y))
  | H : (negb (@eq_op _  _ _)) = true |- _ => move/eqP: H => H
  | |- (negb (@eq_op _  _ _)) = true => apply/eqP
  | H : context [ (negb (@eq_op _ _ _)) = true ] |- _ =>
     rewrite <-  (rwP (@eqP _ _ _)) in H
  | |- context [ (negb (@eq_op _ ?x ?y)) = true ] =>
     rewrite <- (rwP (@eqP _ x y))

  | H : (leq _ _) = true |- _ => move/leP: H => H
  | H : context [ (leq ?a ?b) = true] |- _ =>
     rewrite <- (rwP (@leP a b)) in H
  | |- (leq _ _) = true => apply/leP
  | |- context [(leq ?a ?b) = true] => rewrite <- (rwP (@leP a b))
  (* Boolean equality *)
  | H : (@eq_op _ _ _) = true |- _ => move/eqP: H => H
  | |- (@eq_op _ _ _) = true => apply/eqP
  | H : context [(@eq_op _ _ _) = true] |- _ =>
     rewrite <-  (rwP (@eqP _ _ _)) in H
  | |- context [(@eq_op _ ?x ?y) = true] => rewrite <- (rwP (@eqP _ x y))

  (* Negated lt *)
  | H : is_true (negb (leq (S _) _)) |- _ => move: H; rewrite -leqNgt=> H
  | H : context [ is_true (negb (leq (S _) _))] |- _ =>
     rewrite -leqNgt in H
  | |- is_true (negb (leq (S _) _)) => rewrite -leqNgt
  | |- context [ is_true (negb (leq (S _) _))] => rewrite -leqNgt

  (* Negated leq *)
  | H : is_true (negb (leq _ _)) |- _ => move: H; rewrite -ltnNge=> H
  | H : context [ is_true (negb (leq _ _))] |- _ =>
     rewrite -ltnNge in H
  | |- is_true (negb (leq _ _)) => rewrite -ltnNge
  | |- context [ is_true (negb (leq _ _))] => rewrite -ltnNge

   (* = flase *)
  | H : (_ = false) |- _ => move/negbT: H => H
  | |- (_ = false) => apply/negP
  | H : context [ (?a = false)] |- _ =>
     rewrite <-  (rwP (@negP a)) in H
  | |- context [ ?a = false] =>
     rewrite <- (rwP (@negP a))

 end.

(* Converting ssrnat operation to their std lib analogues *)
Ltac ssrnatify_op :=
 match goal with
  (* subn -> minus *)
  | H : context [subn _ _] |- _ => rewrite -!minusE in H
  | |- context [subn _ _] => rewrite -!minusE
  (* addn -> plus *)
  | H : context [addn _ _] |- _ => rewrite -!plusE in H
  | |- context [addn _ _] => rewrite -!plusE
  (* muln -> mult *)
  | H : context [muln _ _] |- _ => rewrite -!multE in H
  | |- context [muln _ _] => rewrite -!multE
 end.

(* Preparing a goal to be solved by lia by translating every formula *)
(* in the context or the conclusion which expresses a constraint on *)
(* some nat into the std lib, Prop, analogues *)
Ltac ssrnatify :=
  repeat progress ssrnatify_rel;
  repeat progress ssrnatify_op.

(* Preprocessing + lia *)
Ltac slia := try (move=> * //=); do [ ssrnatify; lia | exfalso; ssrnatify; lia].

Lemma foldr_monoid {T : Type} {f : T -> T -> T} {n s1 s2}:
associative f ->
(forall x, f n x = x) ->
(forall x, f x n = x) ->
f (foldr f n s1) (foldr f n s2) =
foldr f n (s1 ++ s2).
Proof. by move=> A L R; elim: s1=> //= ??; rewrite -A=>->. Qed.

Definition max_set (f : seq nat) : nat :=
  foldr maxn 0 f.

Lemma max_set0 : max_set fset0 = 0.
Proof. by []. Qed.

Lemma max_set1 x: max_set [fset x] = x.
Proof.
by rewrite /max_set enum_fsetE enum_fset1.
Qed.

Lemma max_setin g x:
  x \in g -> x <= max_set g.
Proof.
elim: g=> //= a l IH; rewrite ?inE leq_max=> /orP[/eqP->|/IH->];
by rewrite (leqnn, orbT).
Qed.

Lemma max_subset f g: {subset f <= g} -> max_set f <= max_set g.
Proof.
elim: f g=> //= a f IH g s; rewrite geq_max; apply/andP; split.
- exact/max_setin/(s a)/mem_head.
by apply/IH=> ? I; apply/s; rewrite inE I orbT.
Qed.

Lemma max_set_le {f h: {fset nat}} {k : nat}:
  max_set f <= k -> h `<=` f ->
  max_set h <= k.
Proof. move=> ? /fsubsetP /max_subset; slia.  Qed.

Lemma max_add {f :{fset nat}} {k}:
  max_set f <= k -> max_set ([fset k.+1; k.+2] `|` f) <= k.+3.
Proof.
move=> ?. apply/(@leq_trans (max_set (k.+1 :: k.+2 :: f))).
- apply/max_subset=> ?; by rewrite ?inE orbA.
rewrite /= ?geq_max; apply/and3P; split; slia.
Qed.

Lemma max_setU f g:
  max_set (f `|` g) = maxn (max_set f) (max_set g).
Proof.
have->: maxn (max_set f) (max_set g) = max_set (f ++ g).
exact/(foldr_monoid maxnA max0n maxn0).
have /andP/anti_leq //: ((max_set (f `|` g) <= max_set (f ++ g)) /\
      (max_set (f ++ g) <= max_set (f `|` g)))%type.
split; apply/max_subset=> ?; by rewrite ?inE mem_cat.
Qed.

Lemma max_set_le2 {f g h : {fset nat}} {k}:
  max_set f <= k -> max_set g <= k -> h `<=` f `|` g ->
  max_set h <= k.
Proof.
move=> s1 s2 ?.
by apply/(@max_set_le (f `|` g))=> //; rewrite max_setU geq_max s1 s2.
Qed.

Lemma mem_max_set f k:
  max_set f <= k -> {in f, forall x, x <= k}.
Proof. move=> ?? /max_setin; slia. Qed.

Lemma mem_max_set' f k:
  max_set f < k -> {in f, forall x, x < k}.
Proof. move=> ?? /max_setin; slia. Qed.

Lemma fsfunE {K : choiceType} {V : eqType} S f y dflt:
  ([fsfun x in S => f x] : {fsfun K -> V for dflt}) y =
  if y \in S then f y else dflt y.
Proof.
rewrite /fsfun_of_fun /fsfun_of_ffun Fsfun.of_ffunE.
by case: insubP=> [[/=??->->]|/negbTE->].
Qed.

Lemma finsupp_fsfun {K : eqType} {V: choiceType} {f g : V -> K} {s : {fset V}}:
  finsupp ([fsfun x in s => f x] : {fsfun V -> K for g}) `<=` s.
Proof.
apply/fsubsetP=> ?; rewrite mem_finsupp fsfunE; case: ifP=> //.
by rewrite eq_refl.
Qed.


(** * A type of Points *)
Require Export CommonDefinitions.
(** We parameterize over a type of points. *)
(** A [Point] is a [Type] together with a type of distances between points. *)
Module Type Point.
  Axiom t : Type.
  Axiom distT : Type.
  Axiom dist_le : distT -> distT -> Prop.
  Axiom get_dist : t -> t -> distT.
  Axiom x_le : t -> t -> Prop.
  Context `{x_le_dec : forall x y, Decidable (x_le x y),
              dist_le_dec : forall x y, Decidable (dist_le x y)}.

  Axiom point_in_strip_close_enough : t -> distT -> t -> bool.

  Definition min_dist (x y : distT) : distT
    := if dist_le_dec x y then x else y.

  Context `{x_le_preo : PreOrder _ x_le, dist_le_preo : PreOrder _ dist_le}.
  Context `{x_le_paro : @PartialOrder _ eq _ x_le _, dist_le_paro : @PartialOrder _ eq _ dist_le _}.
  Context `{x_le_total : Total _ x_le, dist_le_total : Total _ dist_le}.

  Module Import Notations.
    Delimit Scope dist_scope with dist.
    Delimit Scope dec_dist_scope with dec_dist.

    Infix "<=" := x_le : type_scope.
    Infix "<=" := x_le_dec : dec_scope.
    Infix "<=" := dist_le : dist_scope.
    Infix "<=" := dist_le_dec : dec_dist_scope.

    Infix "≤" := x_le : type_scope.
    Infix "≤" := x_le_dec : dec_scope.
    Infix "≤" := dist_le : dist_scope.
    Infix "≤" := dist_le_dec : dec_dist_scope.

    Notation "∥' x -- y '∥" := (get_dist x y).
  End Notations.
End Point.


(* The type 'v' represents the set of variables symbols.        *)
(* The type P v is the set of set theoretic first order         *)
(* propositions with variables in v.                            *)

Inductive P (v:Type) : Type :=
| Bot  : P v                        (* bottom                   *)
| Elem : v -> v -> P v              (* x `Elem` y               *)
| Imp  : P v -> P v -> P v          (* implication              *)
| All  : v -> P v -> P v            (* quantification           *)
.

Arguments Bot  {v}.
Arguments Elem {v} _ _.
Arguments Imp  {v} _ _.
Arguments All  {v} _ _.


(****************************************************************************

          IEEE754  :  ClosestMult

          Laurent Thery, Sylvie Boldo

  ******************************************************************************)
Require Export FroundMult.
Require Export ClosestProp.
Section FRoundP.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Hypothesis radixMoreThanOne : (1 < radix)%Z.
Hypothesis precisionGreaterThanOne : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Theorem closestLessMultPos :
 forall (p : float) (r : R),
 Closest b radix r p -> (0 <= r)%R -> (p <= 2%nat * r)%R.
intros p r H' H'0.
case ClosestMinOrMax with (1 := H'); intros H'3.
apply Rle_trans with r; auto with real.
apply isMin_inv1 with (1 := H'3).
case (MinEx b radix precision) with (r := r); auto with arith.
intros min Hmin.
apply Rle_trans with (min + p)%R; auto with real.
apply Rplus_le_reg_l with (r := (- p)%R).
replace (- p + p)%R with 0%R; [ idtac | ring ].
replace (- p + (min + p))%R with (FtoRradix min);
 [ apply (RleMinR0 b radix precision) with (r := r); auto | ring ].
apply Rplus_le_reg_l with (r := (- r)%R).
apply Rplus_le_reg_l with (r := (- min)%R).
replace (- min + (- r + (min + p)))%R with (Rabs (p - r)).
replace (- min + (- r + 2%nat * r))%R with (Rabs (min - r)).
case H'.
intros H'1 H'2; apply H'2; auto.
case Hmin; auto.
rewrite Faux.Rabsolu_left1; simpl in |- *.
ring; auto.
apply Rle_minus; apply isMin_inv1 with (1 := Hmin).
rewrite Rabs_right; simpl in |- *.
ring; auto.
apply Rle_ge; apply Rplus_le_reg_l with (r := r).
replace (r + 0)%R with r; [ idtac | ring ].
replace (r + (p - r))%R with (FtoRradix p);
 [ apply isMax_inv1 with (1 := H'3) | ring ].
Qed.

Theorem closestLessMultNeg :
 forall (p : float) (r : R),
 Closest b radix r p -> (r <= 0)%R -> (2%nat * r <= p)%R.
intros p r H' H'0.
replace (2%nat * r)%R with (- (2%nat * - r))%R; [ idtac | ring ].
replace (FtoRradix p) with (- - p)%R;
 [ unfold FtoRradix in |- *; rewrite <- Fopp_correct | ring ].
apply Ropp_le_contravar.
apply closestLessMultPos; auto.
apply ClosestOpp; auto.
replace 0%R with (-0)%R; [ auto with real | ring ].
Qed.

Theorem closestLessMultAbs :
 forall (p : float) (r : R),
 Closest b radix r p -> (Rabs p <= 2%nat * Rabs r)%R.
intros p r H'; case (Rle_or_lt 0 r); intros H'1.
repeat rewrite Rabs_right; auto with real.
apply closestLessMultPos; auto.
apply Rle_ge;
 apply (RleRoundedR0 b radix precision) with (P := Closest b radix) (r := r);
 auto.
apply ClosestRoundedModeP with (precision := precision); auto.
repeat rewrite Faux.Rabsolu_left1; auto.
replace (2%nat * - r)%R with (- (2%nat * r))%R;
 [ apply Ropp_le_contravar | ring ].
apply closestLessMultNeg; auto.
apply Rlt_le; auto.
apply Rlt_le; auto.
apply
 (RleRoundedLessR0 b radix precision) with (P := Closest b radix) (r := r);
 auto.
apply ClosestRoundedModeP with (precision := precision); auto.
apply Rlt_le; auto.
Qed.

Theorem errorBoundedMultClosest_aux :
 forall p q pq : float,
 Fbounded b p ->
 Fbounded b q ->
 Closest b radix (p * q) pq ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 (p * q - pq)%R <> 0%R :>R ->
 ex
   (fun r : float =>
    ex
      (fun s : float =>
       Fcanonic radix b r /\
       Fbounded b r /\
       Fbounded b s /\
       r = pq :>R /\
       s = (p * q - r)%R :>R /\
       Fexp s = (Fexp p + Fexp q)%Z :>Z /\
       (Fexp s <= Fexp r)%Z /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z)).
intros p q pq Hp Hq H1 H2 H3.
cut (RoundedModeP b radix (Closest b radix));
 [ intros H4 | apply ClosestRoundedModeP with precision; auto ].
lapply (errorBoundedMultExp b radix precision);
 [ intros H'2; lapply H'2;
    [ intros H'3; lapply H'3;
       [ intros H'4; lapply (H'4 (Closest b radix));
             [ intros H'7; elim (H'7 p q pq);
                [ intros r E; elim E; intros s E0; elim E0; intros H'15 H'16;
                   elim H'16; intros H'17 H'18; elim H'18;
                   intros H'19 H'20; elim H'20; intros H'21 H'22;
                   elim H'22; intros H'23 H'24; elim H'24;
                   intros H'25 H'26;
                   clear H'24 H'22 H'20 H'18 H'16 E0 E H'3 H'2
                | clear  H'3 H'2
                | clear  H'3 H'2
                | clear  H'3 H'2
                | clear  H'3 H'2 ]
             | clear H'3 H'2 ]
          | clear H'3 H'2 ]
    | clear H'2 ]
  | idtac]; auto.
exists (Fnormalize radix b precision r); exists s.
cut (Fbounded b (Fnormalize radix b precision r));
 [ intros H5 | apply FnormalizeBounded; auto with arith ].
split; [ apply FnormalizeCanonic; auto with arith | idtac ].
repeat (split; auto).
unfold FtoRradix in |- *; rewrite <- H'19; unfold FtoRradix in |- *;
 apply FnormalizeCorrect; auto.
unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with arith.
apply Zlt_le_weak.
apply
 RoundedModeErrorExpStrict with b radix precision (Closest b radix) (p * q)%R;
 auto with arith.
generalize ClosestCompatible; unfold CompatibleP in |- *; intros H6.
generalize
 (H6 b radix (FtoRradix p * FtoRradix q)%R (FtoRradix p * FtoRradix q)%R pq);
 intros H9; apply H9; auto.
rewrite FnormalizeCorrect; auto with real arith.
rewrite FnormalizeCorrect; auto with real arith.
rewrite H'21; rewrite H'19; auto.
apply Zle_trans with (Fexp r); auto.
apply FcanonicLeastExp with radix b precision; auto with arith.
rewrite FnormalizeCorrect; auto with real arith.
apply FnormalizeCanonic; auto with arith.
Qed.

Theorem errorBoundedMultClosest :
 forall p q pq : float,
 Fbounded b p ->
 Fbounded b q ->
 Closest b radix (p * q) pq ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 (- dExp b <= Fexp (Fnormalize radix b precision pq) - precision)%Z ->
 ex
   (fun r : float =>
    ex
      (fun s : float =>
       Fcanonic radix b r /\
       Fbounded b r /\
       Fbounded b s /\
       r = pq :>R /\
       s = (p * q - r)%R :>R /\ Fexp s = (Fexp r - precision)%Z :>Z)).
intros.
cut (RoundedModeP b radix (Closest b radix));
 [ intros G1 | apply ClosestRoundedModeP with precision; auto ].
case (Req_dec (p * q - pq) 0); intros U.
exists (Fnormalize radix b precision pq);
 exists (Fzero (Fexp (Fnormalize radix b precision pq) - precision)).
cut (Fbounded b pq);
 [ intros G2
 | apply RoundedModeBounded with radix (Closest b radix) (p * q)%R; auto ].
cut (Fcanonic radix b (Fnormalize radix b precision pq));
 [ intros G3 | apply FnormalizeCanonic; auto with arith ].
cut (Fbounded b (Fnormalize radix b precision pq));
 [ intros G4 | apply FnormalizeBounded; auto with arith ].
cut (Fnormalize radix b precision pq = pq :>R);
 [ intros G5
 | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto with arith ].
repeat (split; auto).
rewrite G5; unfold FtoRradix in |- *; rewrite FzeroisReallyZero;
 auto with real.
lapply (errorBoundedMultClosest_aux p q pq); auto; intros H5.
lapply H5; auto; intros H6; clear H5.
lapply H6; auto; intros H5; clear H6.
lapply H5; auto; intros H6; clear H5.
lapply H6; auto; intros H5; clear H6.
elim H5; intros r H6; clear H5.
elim H6; intros s H5; clear H6.
elim H5; intros H7 H6; clear H5.
elim H6; intros H8 H9; clear H6.
elim H9; intros H6 H10; clear H9.
elim H10; intros H9 H11; clear H10.
elim H11; intros H10 H12; clear H11.
elim H12; intros H11 H13; clear H12.
elim H13; intros H12 H14; clear H13.
cut
 (ex
    (fun m : Z =>
     s = Float m (Fexp r - precision) :>R /\ (Zabs m <= pPred (vNum b))%Z)).
intros H13; elim H13; intros m H15; elim H15; intros H16 H17; clear H15 H13.
exists r; exists (Float m (Fexp r - precision)).
split; auto.
split; auto.
split.
2: repeat (split; auto).
2: rewrite <- H16; auto.
split; simpl in |- *.
generalize H17; unfold pPred in |- *; apply Zle_Zpred_inv.
replace r with (Fnormalize radix b precision pq); auto with zarith.
apply FcanonicUnique with radix b precision; auto with zarith.
apply FnormalizeCanonic; auto with zarith; elim H1; auto.
rewrite FnormalizeCorrect; auto with real zarith.
cut (radix <> 0%Z :>Z); [ intros V | auto with arith real zarith ].
cut (0 < radix)%Z; [ intros V2 | auto with arith real zarith ].
rewrite H10; unfold FtoRradix in |- *; rewrite <- Fmult_correct; auto.
rewrite <- Fminus_correct; fold FtoRradix in |- *; auto.
unfold Fmult in |- *; unfold Fminus in |- *; unfold Fopp in |- *;
 unfold Fplus in |- *; simpl in |- *.
unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *.
rewrite Zmin_le1; auto with zarith.
replace
 (Fnum p * Fnum q *
  Zpower_nat radix (Zabs_nat (Fexp p + Fexp q - (Fexp p + Fexp q))))%Z with
 (Fnum p * Fnum q)%Z.
2: replace (Fexp p + Fexp q - (Fexp p + Fexp q))%Z with 0%Z;
    auto with zarith arith; simpl in |- *.
2: auto with zarith.
exists
 ((Fnum p * Fnum q +
   - Fnum r * Zpower_nat radix (Zabs_nat (Fexp r - (Fexp p + Fexp q)))) *
  Zpower_nat radix (Zabs_nat (Fexp p + Fexp q + (precision - Fexp r))))%Z;
 split.
rewrite plus_IZR.
repeat rewrite Rmult_IZR.
rewrite plus_IZR.
repeat rewrite Rmult_IZR.
rewrite (Zpower_nat_powerRZ_absolu radix (Fexp r - (Fexp p + Fexp q))).
2: auto with zarith arith.
rewrite
 (Zpower_nat_powerRZ_absolu radix (Fexp p + Fexp q + (precision - Fexp r)))
 .
2: auto with zarith arith.
cut (radix <> 0%R :>R); [ intros W | auto with real arith zarith ].
unfold Zminus in |- *.
repeat rewrite powerRZ_add; try rewrite <- INR_IZR_INZ; auto.
apply
 trans_eq
  with
    ((Fnum p * Fnum q +
      (- Fnum r)%Z *
      (powerRZ radix (Fexp r) * powerRZ radix (- (Fexp p + Fexp q)))) *
     (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)))%R.
ring; ring.
apply
 trans_eq
  with
    ((Fnum p * Fnum q +
      (- Fnum r)%Z *
      (powerRZ radix (Fexp r) * powerRZ radix (- (Fexp p + Fexp q)))) *
     (powerRZ radix (Fexp p) * powerRZ radix (Fexp q) *
      (powerRZ radix precision * powerRZ radix (- precision))) *
     (powerRZ radix (Fexp r) * powerRZ radix (- Fexp r)))%R.
2: ring; ring.
replace (powerRZ radix precision * powerRZ radix (- precision))%R with 1%R.
replace (powerRZ radix (Fexp r) * powerRZ radix (- Fexp r))%R with 1%R;
 try ring.
rewrite <- powerRZ_add; try rewrite <- INR_IZR_INZ; auto.
rewrite Zplus_opp_r; simpl in |- *; auto.
rewrite <- powerRZ_add; try rewrite <- INR_IZR_INZ; auto.
rewrite Zplus_opp_r; simpl in |- *; auto.
apply le_IZR; rewrite <- Faux.Rabsolu_Zabs.
rewrite Rmult_IZR; rewrite plus_IZR.
repeat rewrite Rmult_IZR.
rewrite
 (Zpower_nat_powerRZ_absolu radix (Fexp p + Fexp q + (precision - Fexp r)))
 .
2: auto with zarith arith.
rewrite (Zpower_nat_powerRZ_absolu radix (Fexp r - (Fexp p + Fexp q))).
2: auto with zarith arith.
rewrite powerRZ_add; try rewrite <- INR_IZR_INZ; auto with real arith.
replace
 ((Fnum p * Fnum q +
   (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) *
  (powerRZ radix (Fexp p + Fexp q) * powerRZ radix (precision - Fexp r)))%R
 with
 ((Fnum p * Fnum q +
   (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) *
  powerRZ radix (Fexp p + Fexp q) * powerRZ radix (precision - Fexp r))%R;
 [ idtac | ring; ring ].
rewrite Rabs_mult.
rewrite (Rabs_right (powerRZ radix (precision - Fexp r))).
2: apply Rle_ge; apply powerRZ_le; auto with real zarith.
apply Rmult_le_reg_l with (powerRZ radix (Fexp r - precision)).
apply powerRZ_lt; auto with real arith.
rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- powerRZ_add.
2: auto with zarith arith real.
replace (precision - Fexp r + (Fexp r - precision))%Z with 0%Z;
 [ simpl in |- * | ring ].
apply
 Rle_trans
  with
    (Rabs
       ((Fnum p * Fnum q +
         (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) *
        powerRZ radix (Fexp p + Fexp q))); [ right; ring | idtac ].
replace
 ((Fnum p * Fnum q +
   (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) *
  powerRZ radix (Fexp p + Fexp q))%R with (p * q - r)%R.
2: unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *;
    unfold Rminus in |- *.
2: unfold Zminus in |- *; repeat rewrite Ropp_Ropp_IZR.
2: repeat rewrite powerRZ_add; auto with real arith.
2: apply
    trans_eq
     with
       (Fnum p * Fnum q * (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)) +
        - Fnum r *
        (powerRZ radix (Fexp r) *
         (powerRZ radix (- (Fexp p + Fexp q)) *
          (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)))))%R;
    [ idtac | ring ].
2: replace
    (powerRZ radix (- (Fexp p + Fexp q)) *
     (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)))%R with 1%R;
    try ring.
2: repeat rewrite <- powerRZ_add; auto with real arith.
2: replace (- (Fexp p + Fexp q) + (Fexp p + Fexp q))%Z with 0%Z;
    simpl in |- *; simpl; ring.
apply Rle_trans with (powerRZ radix (Fexp r) * / 2%nat)%R.
rewrite <- H10;
 replace (powerRZ radix (Fexp r)) with (FtoRradix (Float 1%nat (Fexp r)));
 unfold FtoRradix in |- *;
 [ idtac | unfold FtoR in |- *; simpl in |- *; ring ].
apply ClosestErrorBound with b precision (p * q)%R; auto.
apply (ClosestCompatible b radix (p * q)%R (p * q)%R pq); auto.
unfold Zminus in |- *; rewrite powerRZ_add; auto with real arith.
rewrite Rmult_assoc; apply Rmult_le_compat_l.
apply powerRZ_le; auto with real arith.
unfold pPred, Zpred in |- *; rewrite pGivesBound.
rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ.
replace (powerRZ radix (- precision) * (powerRZ radix precision + (-1)%Z))%R
 with (1 + - powerRZ radix (- precision))%R.
apply Rle_trans with (1 + - powerRZ radix (- 1%nat))%R.
simpl in |- *.
replace (radix * 1)%R with (IZR radix); [ idtac | ring ].
replace (/ (1 + 1))%R with (1 + - / 2)%R.
apply Rplus_le_compat_l; apply Ropp_le_contravar.
apply Rle_Rinv; auto with real arith zarith.
replace 2%R with (1 + 1)%R; auto with real arith zarith.
cut ((1 + 1)%R <> 0%R :>R); [ intros | idtac ].
2: replace 2%R with (INR 2); auto with real arith zarith.
apply Rmult_eq_reg_l with (1 + 1)%R; auto.
rewrite Rmult_plus_distr_l.
simpl. rewrite (Rmult_comm (1 + 1) (- / (1 + 1))).
rewrite Ropp_mult_distr_l_reverse.
rewrite (Rmult_comm (/ (1 + 1)) (1 + 1)).
rewrite Rinv_r; auto with real; ring.
apply Rplus_le_compat_l; apply Ropp_le_contravar.
apply Rle_powerRZ; auto with real arith zarith.
rewrite Rmult_plus_distr_l.
rewrite <- powerRZ_add; auto with real arith.
replace (- precision + precision)%Z with 0%Z; simpl in |- *; ring.
Qed.
End FRoundP.


From mathcomp Require Import ssreflect ssrbool eqtype.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma and_true_l :
  forall a b : bool, a && b = true -> a = true.
Proof.
  move=>a; by elim: a.
Qed.

Lemma and_true_r :
  forall a b : bool, a && b = true -> b = true.
Proof.
  move=>a; by elim: a.
Qed.

Lemma and_true :
  forall a b : bool, a && b = true -> a = true /\ b = true.
Proof.
  move=>a; by elim: a.
Qed.

Lemma and_false :
  forall a b : bool, a && b = false -> a = false \/ b = false.
Proof.
  move=> a b /nandP H.
  case: H => H.
  - left; exact: (negbTE H).
  - right; exact: (negbTE H).
Qed.


Require Export prosa.model.task.arrivals.

(** In this file we provide basic properties related to tasks on arrival sequences. *)
Section TaskArrivals.

  (** Consider any type of job associated with any type of tasks. *)
  Context {Job : JobType}.
  Context {Task : TaskType}.
  Context `{JobTask Job Task}.

  (** Consider any job arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** Let [tsk] be any task. *)
  Variable tsk : Task.

  (** We show that the number of arrivals of task can be split into disjoint intervals. *)
  Lemma num_arrivals_of_task_cat:
    forall t t1 t2,
      t1 <= t <= t2 ->
      number_of_task_arrivals arr_seq tsk t1 t2 =
      number_of_task_arrivals arr_seq tsk t1 t + number_of_task_arrivals arr_seq tsk t t2.
  Proof.
    move => t t1 t2 /andP [GE LE].
    rewrite /number_of_task_arrivals /task_arrivals_between /arrivals_between.
    rewrite (@big_cat_nat _ _ _ t) //=.
      by rewrite filter_cat size_cat.
  Qed.

End TaskArrivals.


Require Import Setoid.

Module Type Group.

Parameter S:Type.
Parameter opT:S->S->S.
Parameter s0:S.
Parameter eqT:S->S->Prop.
Parameter inclT:S->Prop.
Infix "/":=opT.
Definition e:S:=s0/s0.

Hypothesis unit:forall a:S,eqT (a/a) e.
Hypothesis eqT_dec:forall a b:S,{eqT a b}+{~eqT a b}.
Hypothesis inclT_dec:forall a:S,{inclT a}+{~inclT a}.
Hypothesis equiv_eqT:Equivalence eqT.
Hypothesis well_opT:forall a1 a2 b1 b2:S,
eqT a1 a2->eqT b1 b2->eqT(a1/b1)(a2/b2).
Hypothesis closed_opT:forall a b:S,
inclT a->inclT b->inclT (a/b).
Hypothesis well_inclT:forall a b:S,
eqT a b->if inclT_dec a then inclT b else ~inclT b.
Infix "==":=eqT (at level 70,no associativity).
Hypothesis ga0:forall a:S,a/e==a.
Hypothesis ga1:forall b c:S,e/(b/c)==c/b.
Hypothesis ga2:forall a b c:S,(a/c)/(b/c)==a/b.
End Group.
Module GroupProperty(Gr:Group).
Include Gr.
Definition inv(a:S):S:=e/a.
Definition mult(a b:S):S:=a/(inv b).
Infix "*":=mult.
Add Parametric Relation:S eqT
reflexivity proved by (@Equivalence_Reflexive S eqT equiv_eqT)
symmetry proved by (@Equivalence_Symmetric S eqT equiv_eqT)
transitivity proved by(@Equivalence_Transitive S eqT equiv_eqT)
as eqT_equivalence.
Add Parametric Morphism :opT with signature(eqT==>eqT==>eqT)
as opT_well_defined.
intros.
apply well_opT.
exact H.
exact H0.
Qed.

Theorem well_inclT_iff:forall a b:S,
eqT a b->(inclT a<->inclT b).
intros.
split.
intros.
generalize (well_inclT a b H).
intros.
case (inclT_dec a) in *.
apply H1.
case (n H0).
info symmetry in H.
generalize (well_inclT b a H).
case (inclT_dec b).
auto.
tauto.
Qed.

Add Parametric Morphism:inclT
with signature (eqT==>iff)
as inclT_well_defined.
exact well_inclT_iff.
Qed.

Theorem mul_s_inv:forall s:S,
s*inv s==e.
intros.
unfold mult.
unfold inv.
rewrite ga1.
rewrite ga0.
apply unit.
Qed.

Theorem mul_inv_s:forall s:S,
(inv s)*s==e.
intros.
apply unit.
Qed.

Theorem mul_e_s:forall s:S,
e*s==s.
unfold mult.
unfold inv.
intros.
rewrite ga1.
apply ga0.
Qed.
Theorem mul_s_e:forall s:S,
s*e==s.
intros.
unfold mult.
unfold inv.
rewrite unit.
apply ga0.
Qed.

Lemma inv_inv_s:forall s:S,
inv (inv s)==s.
intro.
unfold inv.
rewrite ga1.
apply ga0.
Qed.
Lemma mult_op:forall a b:S,
(a*b)/b==a.
intros.
unfold mult.
cut (a/inv b/b==a/(e/b)/(inv (inv b))).
intros.
rewrite H.
unfold inv.
rewrite ga2.
exact (ga0 a).
rewrite inv_inv_s.
reflexivity.
Qed.

Theorem assoc:forall a b c:S,
a*(b*c)==(a*b)*c.
intros.
unfold mult.
unfold inv.

rewrite ga1.
rewrite <-(ga2 (a/(e/b))  (e/c) b).
assert (a==a/(e/b)/b).
cut (a/(e/b)==a*b).
intros.

rewrite H.
symmetry;apply (mult_op a b).
unfold mult,inv;reflexivity.
rewrite <-H.
reflexivity.
Qed.

End GroupProperty.

Add Parametric Relation(G:Group):S eqT
reflexivity proved by (@Equivalence_Reflexive S eqT equiv_eqT)
symmetry proved by (@Equivalence_Symmetric S eqT equiv_eqT)
transitivity proved by(@Equivalence_Transitive S eqT equiv_eqT)
as eqT_equivalence.
Add Parametric Morphism :opT with signature(eqT==>eqT==>eqT)
as opT_well_defined.
intros.
apply well_opT.
exact H.
exact H0.
Qed.
Add Parametric Morphism:inclT
with signature (eqT==>iff)
as inclT_well_defined.
exact well_inclT_iff.
Qed.

Module Type SubGroup(G:Group)<:Group.
Definition S:Type:=G.S.
Parameter (subT:S->Prop).
Definition inclT:=subT.
Hypothesis subT_then_inclT:
forall a:S,
subT a->G.inclT a.
Parameter (subT_dec:forall s:S,{subT s}+{~subT s}).
Definition opT:=G.opT.
Parameter (subT_closed_opT:forall a b:S,subT a->subT b->
subT (opT a b)).
Definition eqT:=G.eqT.
Parameter well_subT:
forall a b:S,
eqT a b->if subT_dec a then subT b else ~subT b.
Definition s0:=G.e.
Definition e:=opT s0 s0.
Definition unit:forall a:S,eqT(opT a a)e.
intro.
rewrite G.unit.
symmetry.
unfold e.
apply G.unit.
Qed.
Definition eqT_dec:forall a b:S,{eqT a b}+{~eqT a b}:=G.eqT_dec.
Definition inclT_dec:forall a:S,{inclT a}+{~inclT a}:=subT_dec.
Definition equiv_eqT:Equivalence eqT:=G.equiv_eqT.
Infix "/":=opT.
Definition well_opT:forall a1 a2 b1 b2:S,
eqT a1 a2->eqT b1 b2->eqT(a1/b1)(a2/b2):=G.well_opT.
Definition closed_opT:forall a b:S,
inclT a->inclT b->inclT (a/b):=subT_closed_opT.
Definition well_inclT:forall a b:S,
eqT a b->if inclT_dec a then inclT b else ~inclT b.
apply well_subT.
Qed.
Infix "==":=eqT (at level 70,no associativity).
Definition ga0:forall a:S,a/e==a.
intro.
unfold e.
repeat rewrite G.ga0.
reflexivity.
Qed.
Definition ga1:forall b c:S,e/(b/c)==c/b.
intros.
unfold e.
rewrite G.ga0.
rewrite G.ga1.
reflexivity.
Qed.
Definition ga2:forall a b c:S,(a/c)/(b/c)==a/b:=G.ga2.
Definition inv(s:S):=opT e s.
Definition mult(a b:S):=a/(inv b).
Add Parametric Relation:S eqT
reflexivity proved by (@Equivalence_Reflexive S eqT equiv_eqT)
symmetry proved by (@Equivalence_Symmetric S eqT equiv_eqT)
transitivity proved by(@Equivalence_Transitive S eqT equiv_eqT)
as eqT_equivalence.
Add Parametric Morphism :opT with signature(eqT==>eqT==>eqT)
as opT_well_defined.
intros.
apply well_opT.
exact H.
exact H0.
Qed.
Theorem well_inclT_iff:forall a b:S,
eqT a b->(inclT a<->inclT b).
intros.
split.
intros.
generalize (well_inclT a b H).
intros.
case (inclT_dec a) in *.
apply H1.
case (n H0).
info symmetry in H.
generalize (well_inclT b a H).
case (inclT_dec b).
auto.
tauto.
Qed.
Add Parametric Morphism:inclT
with signature (eqT==>iff)
as inclT_well_defined.
exact well_inclT_iff.
Qed.
Infix "*":=mult.
Theorem mul_s_inv:forall s:S,
s*inv s==e.
intro.
unfold mult.
unfold inv.
rewrite ga1.
rewrite ga0.
apply unit.
Qed.

Theorem mul_inv_s:forall s:S,
(inv s)*s==e.
intros.
apply unit.
Qed.

Theorem mul_e_s:forall s:S,
e*s==s.
unfold mult.
unfold inv.
intros.
rewrite ga1.
apply ga0.
Qed.
Theorem mul_s_e:forall s:S,
s*e==s.
intros.
unfold mult.
unfold inv.
rewrite unit.
apply ga0.
Qed.

Lemma inv_inv_s:forall s:S,
inv (inv s)==s.
intro.
unfold inv.
rewrite ga1.
apply ga0.
Qed.
Lemma mult_op:forall a b:S,
(a*b)/b==a.
intros.
unfold mult.
cut (a/inv b/b==a/(e/b)/(inv (inv b))).
intros.
rewrite H.
unfold inv.
rewrite ga2.
exact (ga0 a).
rewrite inv_inv_s.
reflexivity.
Qed.

Theorem assoc:forall a b c:S,
a*(b*c)==(a*b)*c.
intros.
unfold mult.
unfold inv.

rewrite ga1.
rewrite <-(ga2 (a/(e/b))  (e/c) b).
assert (a==a/(e/b)/b).
cut (a/(e/b)==a*b).
intros.

rewrite H.
symmetry;apply (mult_op a b).
unfold mult,inv;reflexivity.
rewrite <-H.
reflexivity.
Qed.

End SubGroup.


From Coq Require Import String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import ZArith.
From VFA Require Import Perm.
From VFA Require Import Extract.

Open Scope Z_scope.

Section ValueType.
  Variable V : Type.
  Variable default : V.

  Definition key := int.

  Inductive color := Red | Black.

  Inductive tree : Type :=
  | E : tree
  | T : color -> tree -> key -> V -> tree -> tree.

  Definition empty_tree : tree := E.

  Fixpoint lookup (x: key) (t : tree) : V :=
    match t with
    | E => default
    | T _ tl k v tr => if ltb x k then lookup x tl
                      else if ltb k x then lookup x tr
                           else v
    end.

   Definition balance (rb : color) (t1 : tree) (k : key) (vk : V) (t2 : tree) : tree :=
    match rb with
    | Red => T Red t1 k vk t2
    | _ => match t1 with
          | T Red (T Red a x vx b) y vy c =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
          | T Red a x vx (T Red b y vy c) =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
          | _ => match t2 with
                | T Red (T Red b y vy c) z vz d =>
                  T Red (T Black t1 k vk b) y vy (T Black c z vz d)
                | T Red b y vy (T Red c z vz d) =>
                  T Red (T Black t1 k vk b) y vy (T Black c z vz d)
                | _ => T Black t1 k vk t2
                end
          end
    end.

  Fixpoint ins (x : key) (vx : V) (t : tree) : tree :=
    match t with
    | E => T Red E x vx E
    | T c a y vy b => if ltb x y then balance c (ins x vx a) y vy b
                      else if ltb y x then balance c a y vy (ins x vx b)
                           else T c a x vx b
    end.

  Definition make_black (t : tree) : tree :=
    match t with
    | E => E
    | T _ a x vx b => T Black a x vx b
    end.

  Definition insert (x : key) (vx : V) (t : tree) := make_black (ins x vx t).

  Fixpoint elements_tr (t : tree) (acc: list (key * V)) : list (key * V) :=
    match t with
    | E => acc
    | T _ l k v r => elements_tr l ((k, v) :: elements_tr r acc)
    end.

  Definition elements (t : tree) : list (key * V) := elements_tr t [].

  Lemma ins_not_E : forall (x : key) (vx : V) (t : tree),
      ins x vx t <> E.
  Proof.
    intros. destruct t; simpl.
    discriminate.
    (* Let's destruct on the topmost case, ltb x k. We can use
       destruct instead of bdestruct because we don't need to know
       whether x < k or x ≥ k. *)
    destruct (ltb x k).
    unfold balance.
    (* A huge goal!  The proof of this goal begins by matching
       against a color. *)
    destruct c.
    discriminate.
    (* Another match, this time against a tree. *)
    destruct (ins x vx t1).
    (* Another match against a tree. *)
    destruct t2.
    discriminate.
    (* Yet another match. This pattern deserves automation.  The
       following tactic applies destruct whenever the current goal
       is a match against a color or a tree. *)

    match goal with
    | |- match ?c with Red => _ | Black => _ end <> _ => destruct c
    | |- match ?t with E => _ | T _ _ _ _ _ => _ end <> _=> destruct t
    end.
    (* Let's apply that tactic repeatedly. *)
    repeat
      match goal with
      | |- match ?c with Red => _ | Black => _ end <> _ => destruct c
      | |- match ?t with E => _ | T _ _ _ _ _ => _ end <> _=> destruct t
      end.
    (* Now we're down to a base case. *)
    discriminate.
    (* And another base case. We could match against those, too. *)
    match goal with
    | |- T _ _ _ _ _ <> E => discriminate
    end.
    (* Let's restart the proof to incorporate this automation. *)
  Abort.

  Lemma ins_not_E : forall (x : key) (vx : V) (t : tree),
      ins x vx t <> E.
  Proof.
    intros. destruct t; simpl.
    - discriminate.
    - unfold balance.
      repeat
        match goal with
        | |- (if ?x then _ else _) <> _ => destruct x
        | |- match ?c with Red => _ | Black => _ end <> _=> destruct c
        | |- match ?t with E => _ | T _ _ _ _ _ => _ end <> _=> destruct t
        | |- T _ _ _ _ _ <> E => discriminate
        end.
  Qed.

  Fixpoint ForallT (P: int -> V -> Prop) (t: tree) : Prop :=
    match t with
    | E           => True
    | T c l k v r => P k v /\ ForallT P l /\ ForallT P r
    end.

  Inductive BST : tree -> Prop :=
  | ST_E : BST E
  | ST_T : forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (T c l k v r).

  Lemma empty_tree_BST: BST empty_tree.
  Proof.
    unfold empty_tree. constructor.
  Qed.

 Lemma balance_BST: forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (balance c l k v r).
  Proof.
    intros c l k v r PL PR BL BR. unfold balance.
    repeat
      match goal with
      | |- BST (match ?c with Red => _ | Black => _ end) => destruct c
      | |- BST (match ?t with E => _ | T _ _ _ _ _ => _ end) => destruct t
      end.
  Abort.

  Lemma balance_BST: forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (balance c l k v r).
  Proof.
    intros. unfold balance.
    repeat
      (match goal with
       | |- BST (match ?c with Red => _ | Black => _ end) => destruct c
       | |- BST (match ?t with E => _ | T _ _ _ _ _ => _ end) => destruct t
       | |- ForallT _ (T _ _ _ _ _) => repeat split
       | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
       | H: BST (T _ _ _ _ _) |- _ => inv H
       end;
       (try constructor; auto; try lia)).
  Abort.

  Lemma ForallT_imp : forall (P Q : int -> V -> Prop) t,
      ForallT P t ->
      (forall k v, P k v -> Q k v) ->
      ForallT Q t.
  Proof.
    induction t; intros.
    - auto.
    - destruct H as [? [? ?]]. repeat split; auto.
  Qed.

  Lemma ForallT_greater : forall t k k0,
      ForallT (fun k' _ => Abs k' > Abs k) t ->
      Abs k > Abs k0 ->
      ForallT (fun k' _ => Abs k' > Abs k0) t.
  Proof.
    intros. eapply ForallT_imp; eauto.
    intros. simpl in H1. lia.
  Qed.

  Lemma ForallT_less : forall t k k0,
      ForallT (fun k' _ => Abs k' < Abs k) t ->
      Abs k < Abs k0 ->
      ForallT (fun k' _ => Abs k' < Abs k0) t.
  Proof.
    intros; eapply ForallT_imp; eauto.
    intros. simpl in H1. lia.
  Qed.

  Lemma balance_BST: forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (balance c l k v r).
  Proof.
    intros. unfold balance.
    repeat
      (match goal with
       | |- BST (match ?c with Red => _ | Black => _ end) => destruct c
       | |- BST (match ?s with E => _ | T _ _ _ _ _ => _ end) => destruct s
       | |- ForallT _ (T _ _ _ _ _) => repeat split
       | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
       | H: BST (T _ _ _ _ _) |- _ => inv H
       end;
       (try constructor; auto; try lia)).
    (* all: t   applies t to every subgoal. *)
    all: try eapply ForallT_greater; try eapply ForallT_less; eauto; try lia.
  Qed.

  Lemma balanceP : forall (P : key -> V -> Prop) (c : color) (l r : tree) (k : key) (v : V),
      ForallT P l ->
      ForallT P r ->
      P k v ->
      ForallT P (balance c l k v r).
  Proof.
    intros. unfold balance.
    repeat
      (match goal with
       | |- ForallT P (match ?c with Red => _ | Black => _ end) => destruct c
       | |- ForallT P (match ?s with E => _ | T _ _ _ _ _ => _ end) => destruct s
       | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
       end; try (constructor; auto); try assumption).
  Qed.

  Lemma insP : forall (P : key -> V -> Prop) (t : tree) (k : key) (v : V),
      ForallT P t ->
      P k v ->
      ForallT P (ins k v t).
  Proof.
    intros.
    induction t.
    - unfold ins. simpl. auto.
    - simpl. unfold balance.
      inversion H; subst.
      destruct H2 as [Hl Hr].
      repeat
        (match goal with
        | H: ?a, G: ?a -> ?b |- _ => apply G in H
        end).
      repeat
        (match goal with
         | |- ForallT P (if ?c then _ else _) => destruct c
         | |- ForallT P (match ?c with Red => _ | Black => _ end) => destruct c
         | |- ForallT P (match ?s with E => _ | T _ _ _ _ _ => _ end) => destruct s
         | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
         end; try (constructor; auto); try assumption).
      all: simpl; repeat split; try assumption.
  Qed.

  Lemma ins_BST : forall (t : tree) (k : key) (v : V),
      BST t ->
      BST (ins k v t).
  Proof.
    intros.
    induction H.
    - simpl. constructor; simpl; auto; constructor.
    - simpl.
      bdestruct (ltb k k0); bdestruct (ltb k0 k).
      + exfalso. lia.
      + apply balance_BST; try assumption.
        apply insP; try assumption.
      + apply balance_BST; try assumption.
        apply insP; try assumption.
        lia.
      + constructor; try assumption.
        * eapply ForallT_imp.
          apply H. intros. simpl in *. lia.
        * eapply ForallT_imp.
          apply H0. intros. simpl in *. lia.
  Qed.

  Theorem make_black_BST : forall t,
      BST t <-> BST (make_black t).
  Proof.
    intros. unfold make_black.
    split.
    * intro H. destruct t.
      - constructor.
      - inversion H.
        constructor; assumption.
    * intro H. destruct t.
      - constructor.
      - inversion H.
        constructor; assumption.
  Qed.

  Theorem insert_BST : forall t v k,
      BST t ->
      BST (insert k v t).
  Proof.
    intros.
    induction H.
    - unfold insert. simpl. constructor; simpl; auto; constructor.
    - unfold insert in *. simpl.
      rewrite <- make_black_BST in *.
      bdestruct (ltb k k0); bdestruct (ltb k0 k).
      + exfalso. lia.
      + apply balance_BST; simpl; try assumption.
        * apply insP; auto.
      + apply balance_BST; simpl; try assumption.
        * apply insP; auto. lia.
      + constructor; try assumption.
        * eapply (ForallT_imp _ _ _ H).
          intros. lia.
        * eapply (ForallT_imp _ _ _ H0).
          intros. lia.
  Qed.

(* Verification *)

  Lemma lookup_empty : forall k, lookup k empty_tree = default.
  Proof. auto. Qed.

 Lemma balance_lookup: forall (c : color) (k k' : key) (v : V) (l r : tree),
      BST l ->
      BST r ->
      ForallT (fun k' _ => Abs k' < Abs k) l ->
      ForallT (fun k' _ => Abs k' > Abs k) r ->
      lookup k' (balance c l k v r) =
      if Abs k' <? Abs k
      then lookup k' l
      else if Abs k' >? Abs k
           then lookup k' r
           else v.
  Proof.
    intros. unfold balance.
    repeat
      (match goal with
       | |- lookup k' (match ?c with Red => _ | Black => _ end) = _ => destruct c; simpl
       | |- lookup k' (match ?s with E => _ | T _ _ _ _ _ => _ end) = _ => destruct s; simpl
       | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
       | H: BST (T _ _ _ _ _) |- _ => inv H
       end).
    all: try bdall; try (exfalso; lia).
Qed.

  Lemma lookup_ins_eq: forall (t : tree) (k : key) (v : V),
      BST t ->
      lookup k (ins k v t) = v.
  Proof.
    intros t.
    induction t; simpl; intros.
    - bdestruct (ltb k k).
      + exfalso. lia.
      + reflexivity.
    - inv H.
      bdall.
      + rewrite balance_lookup.
        * bdall.
        * apply ins_BST. assumption.
        * assumption.
        * apply insP. assumption. lia.
        * assumption.
      + rewrite balance_lookup.
        * bdall.
        * assumption.
        * apply ins_BST. assumption.
        * assumption.
        * apply insP. assumption. lia.
  Qed.

  Theorem lookup_ins_neq: forall (t : tree) (k k' : key) (v : V),
      BST t ->
      k <> k' ->
      lookup k' (ins k v t) = lookup k' t.
  Proof.
    intros t.
    induction t; simpl; intros.
    - bdestruct (ltb k' k).
      + reflexivity.
      + bdestruct (ltb k k').
        * reflexivity.
        * exfalso.
          assert (G: Abs k = Abs k'). { lia. }
          apply Abs_inj in G.
          apply H0. apply G.
    - inv H.
      bdall;
        try (rewrite balance_lookup);
        try (bdall; lia);
        try assumption;
        try (apply ins_BST; assumption);
        try (apply insP; assumption).
      + apply insP. eapply ForallT_imp. apply H7.
        * intros. simpl in *. lia.
        * lia.
      + apply insP. eapply ForallT_imp. apply H7.
        * intros. simpl in *. lia.
        * lia.
      + apply insP. eapply ForallT_imp. apply H7.
        * intros. simpl in *. lia.
        * lia.
      + exfalso.
        assert (G: Abs k = Abs k'). { lia. }
        assert (G': Abs k = Abs k0). { lia. }
        exfalso. apply H0.
        apply Abs_inj in G, G'.
        rewrite G' in G.
        assumption.
  Qed.

  Lemma elim_make_black_ins_eq: forall k v t,
    lookup k (make_black (ins k v t)) = lookup k (ins k v t).
  Proof.
    intros.
    destruct (ins k v t).
    - simpl. reflexivity.
    - simpl. bdall.
  Qed.

  Theorem lookup_insert_eq : forall (t : tree) (k : key) (v : V),
      BST t ->
      lookup k (insert k v t) = v.
  Proof.
    intros.
    unfold insert. simpl in *.
    rewrite elim_make_black_ins_eq.
    apply lookup_ins_eq.
    assumption.
  Qed.

  Lemma elim_make_black_ins_neq: forall k' k v t,
    lookup k' (make_black (ins k v t)) = lookup k' (ins k v t).
  Proof.
    intros.
    destruct (ins k v t).
    - simpl. reflexivity.
    - simpl. bdall.
  Qed.

  Theorem lookup_insert_neq: forall (t : tree) (k k' : key) (v : V),
      BST t ->
      k <> k' ->
      lookup k' (insert k v t) = lookup k' t.
  Proof.
    intros.
    unfold insert. simpl in *.
    rewrite elim_make_black_ins_neq.
    apply lookup_ins_neq.
    all: assumption.
  Qed.

(* Efficiency TODO *)

End ValueType.


Require Import OrderedTypeEx.
Require Import OrderedType.
Require Import FSetFacts.
Require Import FiniteSets.
Require Import FSetDecide.
Require Import FSetNotin.

Module Type NATSET.
  Declare Module OT : UsualOrderedType with Definition t := nat.
  Parameter eq_nat_dec : forall x y : nat, {x = y} + {x <> y}.
End NATSET.

Module NatSetImpl : NATSET.
  Module OT := Nat_as_OT.
  Module Facts := OrderedTypeFacts OT.
  Definition eq_nat_dec : forall x y : nat, {x = y} + {x <> y} := Facts.eq_dec.
End NatSetImpl.

Module NatSet : FiniteSets.S with Module E := NatSetImpl.OT :=
  FiniteSets.Make NatSetImpl.OT.

Notation nats := NatSet.F.t.
Notation "{}N" := NatSet.F.empty.

Module NatSetDecide := FSetDecide.Decide NatSet.F.
Module NatSetNotin  := FSetNotin.Notin   NatSet.F.
Module NatSetFacts  := FSetFacts.Facts NatSet.F.
Module NatSetProperties := FSetProperties.Properties NatSet.F.

Ltac fnsetdec := try apply NatSet.eq_if_Equal; NatSetDecide.fsetdec.


(* Following http://REDACTED.net/theses/REDACTED.pdf chapter 3 *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia Crypto.Algebra.Nsatz.
Require Import Crypto.Util.Tactics.UniquePose Crypto.Util.Decidable.
Require Import Crypto.Util.Tuple Crypto.Util.Prod Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.NatUtil.
Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil.
Require Import Crypto.Algebra.Ring Crypto.Util.Decidable.Bool2Prop.
Import ListNotations. Local Open Scope Z_scope.

Definition runtime_mul := Z.mul.
Definition runtime_add := Z.add.
Declare Scope runtime_scope.
Delimit Scope runtime_scope with RT.
Infix "*" := runtime_mul : runtime_scope.
Infix "+" := runtime_add : runtime_scope.

Module Associational.
  Definition eval (p:list (Z*Z)) : Z :=
    fold_right Z.add 0%Z (map (fun t => fst t * snd t) p).

  Lemma eval_nil : eval nil = 0.
  Proof. trivial.                                             Qed.
  Lemma eval_cons p q : eval (p::q) = fst p * snd p + eval q.
  Proof. trivial.                                             Qed.
  Lemma eval_app p q: eval (p++q) = eval p + eval q.
  Proof. induction p; rewrite <-?List.app_comm_cons;
           rewrite ?eval_nil, ?eval_cons; nsatz.              Qed.

  Hint Rewrite eval_nil eval_cons eval_app : push_eval.
  Local Ltac push := autorewrite with
      push_eval push_map push_partition push_flat_map
      push_fold_right push_nth_default cancel_pair.

  Lemma eval_map_mul (a x:Z) (p:list (Z*Z))
  : eval (List.map (fun t => (a*fst t, x*snd t)) p) = a*x*eval p.
  Proof. induction p; push; nsatz.                            Qed.
  Hint Rewrite eval_map_mul : push_eval.

  Definition mul (p q:list (Z*Z)) : list (Z*Z) :=
    flat_map (fun t =>
      map (fun t' =>
        (fst t * fst t', (snd t * snd t')%RT))
    q) p.
  Lemma eval_mul p q : eval (mul p q) = eval p * eval q.
  Proof. induction p; cbv [mul]; push; nsatz.                 Qed.
  Hint Rewrite eval_mul : push_eval.

  Example base10_2digit_mul (a0:Z) (a1:Z) (b0:Z) (b1:Z) :
    {ab| eval ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)]}.
    eexists ?[ab].
    (* Goal: eval ?ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)] *)
    rewrite <-eval_mul.
    (* Goal: eval ?ab = eval (mul [(10,a1);(1,a0)] [(10,b1);(1,b0)]) *)
    cbv -[runtime_mul eval].
    (* Goal: eval ?ab = eval [(100,(a1*b1));(10,a1*b0);(10,a0*b1);(1,a0*b0)]%RT *)
    trivial.                                              Defined.

  Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => fst t mod s =? 0) p in
       (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)).
  Lemma eval_split s p (s_nz:s<>0) :
    eval (fst (split s p)) + s * eval (snd (split s p)) = eval p.
  Proof. cbv [split]; induction p;
    repeat match goal with
    | |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(trivial) ltac:(trivial))
    | _ => progress push
    | _ => progress break_match
    | _ => progress nsatz                                end. Qed.

  Lemma reduction_rule a b s c (modulus_nz:s-c<>0) :
    (a + s * b) mod (s - c) = (a + c * b) mod (s - c).
  Proof. replace (a + s * b) with ((a + c*b) + b*(s-c)) by nsatz.
    rewrite Z.add_mod,Z_mod_mult,Z.add_0_r,Z.mod_mod;trivial. Qed.

  Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) :=
    let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi).

  Lemma eval_reduce s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0) :
    eval (reduce s c p) mod (s - eval c) = eval p mod (s - eval c).
  Proof. cbv [reduce]; push.
         rewrite <-reduction_rule, eval_split; trivial.      Qed.
  Hint Rewrite eval_reduce : push_eval.
End Associational.

Module Positional. Section Positional.
  Context (weight : nat -> Z)
          (weight_0 : weight 0%nat = 1)
          (weight_nz : forall i, weight i <> 0).

  Definition to_associational {n:nat} (xs:tuple Z n) : list (Z*Z)
    := combine (map weight (List.seq 0 n)) (Tuple.to_list n xs).
  Definition eval {n} x := Associational.eval (@to_associational n x).
  Lemma eval_to_associational {n} x :
    Associational.eval (@to_associational n x) = eval x.
  Proof using Type. trivial.                                             Qed.

  (* SKIP over this: zeros, add_to_nth *)
  Local Ltac push := autorewrite with push_eval push_map distr_length
    push_flat_map push_fold_right push_nth_default cancel_pair natsimplify.
  Program Definition zeros n : tuple Z n
    := Tuple.from_list n (List.map (fun _ => 0) (List.seq 0 n)) _.
  Next Obligation. push; reflexivity. Qed.
  Lemma eval_zeros n : eval (zeros n) = 0.
  Proof using weight_0.
    cbv [eval Associational.eval to_associational zeros];
      rewrite Tuple.to_list_from_list.
    generalize dependent (List.seq 0 n); intro xs.
    induction xs; simpl; nsatz.                               Qed.
  Program Definition add_to_nth {n} i x : tuple Z n -> tuple Z n
    := Tuple.on_tuple (ListUtil.update_nth i (runtime_add x)) _.
  Next Obligation. apply ListUtil.length_update_nth. Defined.
  Lemma eval_add_to_nth {n} (i:nat) (H:(i<n)%nat) (x:Z) (xs:tuple Z n) :
    eval (add_to_nth i x xs) = weight i * x + eval xs.
  Proof using Type.
    cbv [eval to_associational add_to_nth Tuple.on_tuple runtime_add].
    rewrite !Tuple.to_list_from_list.
    rewrite ListUtil.combine_update_nth_r at 1.
    rewrite <-(update_nth_id i (List.combine _ _)) at 2.
    rewrite <-!(ListUtil.splice_nth_equiv_update_nth_update _ _
      (weight 0, 0)) by (push; lia); cbv [ListUtil.splice_nth id].
    repeat match goal with
           | _ => progress push
           | _ => progress break_match
           | _ => progress (apply Zminus_eq; ring_simplify)
           | _ => rewrite <-ListUtil.map_nth_default_always
           end; lia.                                          Qed.
  Hint Rewrite @eval_add_to_nth eval_zeros : push_eval.

  Fixpoint place (t:Z*Z) (i:nat) : nat * Z :=
    if dec (fst t mod weight i = 0)
    then (i, let c := fst t / weight i in (c * snd t)%RT)
    else match i with S i' => place t i' | O => (O, fst t * snd t)%RT end.
  Lemma place_in_range (t:Z*Z) (n:nat) : (fst (place t n) < S n)%nat.
  Proof using Type. induction n; cbv [place] in *; break_match; autorewrite with cancel_pair; try lia. Qed.
  Lemma weight_place t i : weight (fst (place t i)) * snd (place t i) = fst t * snd t.
  Proof using weight_0 weight_nz. induction i; cbv [place] in *; break_match; push;
    repeat match goal with |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(auto) ltac:(auto))
           end; nsatz.                                        Qed.
  Hint Rewrite weight_place : push_eval.

  Definition from_associational n (p:list (Z*Z)) :=
    List.fold_right (fun t =>
      let p := place t (pred n) in
      add_to_nth (fst p) (snd p)    ) (zeros n) p.
  Lemma eval_from_associational {n} p (n_nz:n<>O) :
    eval (from_associational n p) = Associational.eval p.
  Proof using weight_0 weight_nz. induction p; cbv [from_associational] in *; push; try
  pose proof place_in_range a (pred n); destruct n; cbn [pred] in *; try lia; try nsatz. Qed.
  Hint Rewrite @eval_from_associational : push_eval.

  Section mulmod.
    Context (m:Z) (m_nz:m <> 0) (s:Z) (s_nz:s <> 0)
            (c:list (Z*Z)) (Hm:m = s - Associational.eval c).
    Definition mulmod {n} (a b:tuple Z n) : tuple Z n
      := let a_a := to_associational a in
         let b_a := to_associational b in
         let ab_a := Associational.mul a_a b_a in
         let abm_a := Associational.reduce s c ab_a in
         from_associational n abm_a.
    Lemma eval_mulmod {n} (H:(n<>0)%nat) (f g:tuple Z n) :
      eval (mulmod f g) mod m = (eval f * eval g) mod m.
    Proof using Hm m_nz s_nz weight_0 weight_nz. cbv [mulmod]; rewrite Hm in *; push; trivial.      Qed.
  End mulmod.
End Positional. End Positional.

Import Associational Positional.
Local Coercion Z.of_nat : nat >-> Z.
Local Coercion QArith_base.inject_Z : Z >-> Q.

Definition w (i:nat) : Z := 2^Qceiling((25+1/2)*i).

Example base_25_5_mul (f g:tuple Z 10) :
  { fg : tuple Z 10 | (eval w fg) mod (2^255-19)
                    = (eval w f * eval w g) mod (2^255-19) }.
  (* manually assign names to limbs for pretty-printing *)
  destruct f as [[[[[[[[[f9 f8]f7]f6]f5]f4]f3]f2]f1]f0].
  destruct g as [[[[[[[[[g9 g8]g7]g6]g5]g4]g3]g2]g1]g0].
  eexists ?[fg].
  erewrite <-eval_mulmod with (s:=2^255) (c:=[(1,19)])
      by (try eapply pow_ceil_mul_nat_nonzero; vm_decide).
(*   eval w ?fg mod (2 ^ 255 - 19) = *)
(*   eval w *)
(*     (mulmod w (2^255) [(1, 19)] (f9,f8,f7,f6,f5,f4,f3,f2,f1,f0) *)
(*        (g9,g8,g7,g6,g5,g4,g3,g2,g1,g0)) mod (2^255 - 19) *)
  eapply f_equal2; [|trivial]. eapply f_equal.
(*   ?fg = *)
(*   mulmod w (2 ^ 255) [(1, 19)] (f9, f8, f7, f6, f5, f4, f3, f2, f1, f0) *)
(*     (g9, g8, g7, g6, g5, g4, g3, g2, g1, g0) *)
  cbv -[runtime_mul runtime_add]; cbv [runtime_mul runtime_add].
  ring_simplify_subterms.
(* ?fg =
 (f0*g9+ f1*g8+    f2*g7+    f3*g6+    f4*g5+    f5*g4+    f6*g3+    f7*g2+    f8*g1+    f9*g0,
  f0*g8+ 2*f1*g7+  f2*g6+    2*f3*g5+  f4*g4+    2*f5*g3+  f6*g2+    2*f7*g1+  f8*g0+    38*f9*g9,
  f0*g7+ f1*g6+    f2*g5+    f3*g4+    f4*g3+    f5*g2+    f6*g1+    f7*g0+    19*f8*g9+ 19*f9*g8,
  f0*g6+ 2*f1*g5+  f2*g4+    2*f3*g3+  f4*g2+    2*f5*g1+  f6*g0+    38*f7*g9+ 19*f8*g8+ 38*f9*g7,
  f0*g5+ f1*g4+    f2*g3+    f3*g2+    f4*g1+    f5*g0+    19*f6*g9+ 19*f7*g8+ 19*f8*g7+ 19*f9*g6,
  f0*g4+ 2*f1*g3+  f2*g2+    2*f3*g1+  f4*g0+    38*f5*g9+ 19*f6*g8+ 38*f7*g7+ 19*f8*g6+ 38*f9*g5,
  f0*g3+ f1*g2+    f2*g1+    f3*g0+    19*f4*g9+ 19*f5*g8+ 19*f6*g7+ 19*f7*g6+ 19*f8*g5+ 19*f9*g4,
  f0*g2+ 2*f1*g1+  f2*g0+    38*f3*g9+ 19*f4*g8+ 38*f5*g7+ 19*f6*g6+ 38*f7*g5+ 19*f8*g4+ 38*f9*g3,
  f0*g1+ f1*g0+    19*f2*g9+ 19*f3*g8+ 19*f4*g7+ 19*f5*g6+ 19*f6*g5+ 19*f7*g4+ 19*f8*g3+ 19*f9*g2,
  f0*g0+ 38*f1*g9+ 19*f2*g8+ 38*f3*g7+ 19*f4*g6+ 38*f5*g5+ 19*f6*g4+ 38*f7*g3+ 19*f8*g2+ 38*f9*g1) *)
  trivial.
Defined.

(* Eval cbv on this one would produce an ugly term due to the use of [destruct] *)


From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.
From mathcomp Require Import all_ssreflect ssralg all_algebra seq matrix.

Import List ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify Float_notations Automate.
Set Bullet Behavior "Strict Subproofs".

Require Import floatlib.

Section WITHNANS.
Context {NANS: Nans}.

Definition sum ty (a b : ftype ty) : ftype ty := BPLUS a b.

Definition list_to_vec_float {ty} {n:nat}
(l : list (ftype ty)): 'cV[ftype ty]_n :=
\col_(i < n) (List.nth (nat_of_ord i) l (Zconst ty 0)).

(** Define matrix_addition **)
Definition addmx_float {ty} {m n:nat} (A B: 'M[ftype ty]_(m,n))
  : 'M[ftype ty]_(m,n) :=
  \matrix_(i, j) (sum ty (A i j) (B i j)).

Fixpoint vec_to_list_float {ty} {n:nat} (m:nat) (v :'cV[ftype ty]_n.+1)
   : list (ftype ty) :=
   match m with
   | O => []
   | S p => [v (@inord n p) ord0] ++ vec_to_list_float p v
   end.

Definition vec_to_list_float_1 {ty} {n:nat} (m:nat) (v :'cV[ftype ty]_n.+1) :=
  rev (vec_to_list_float m v).

Lemma nth_vec_to_list_float {ty} {n:nat} i m (v :'cV[ftype ty]_n.+1) d:
  (i < m)%nat ->
  nth (m.-1 -i) (@vec_to_list_float _ n m v) d = v (@inord n i) ord0.
Proof.
intros.
elim: m i H => [ | m IHm] i H.
+ by [].
+ simpl.
  rewrite leq_eqVlt in H.
  assert ((i == m) \/ (i < m)%nat).
  { by apply /orP. } destruct H0.
  - assert (i = m). { by apply /eqP. }
    rewrite H1. simpl.
    assert ((m - m)%nat = 0%N).
    { apply /eqP. rewrite subn_eq0. by []. } by rewrite H2 /=.
  - assert (nth (m.-1 - i) (vec_to_list_float m v)
                d = v (inord i) ord0).
    { by apply IHm. }
    rewrite -H1. rewrite -[in RHS]predn_sub.
    rewrite -subn_gt0 in H0. rewrite -predn_sub in H1.
    by destruct (m - i)%nat.
Qed.

Definition dotprod_r {t: type} (v1 v2: list (ftype t)) : ftype t :=
  fold_right (fun x12 s => BFMA (fst x12) (snd x12) s)
                 (Zconst t 0) (List.combine v1 v2)  .

Lemma combine_rev {ty}:
forall (v1 v2: vector ty),
  length v1 = length v2 ->
  (combine (rev v1) (rev v2)) = rev (combine v1 v2).
Proof.
intros.
elim: v1 v2 H => [ |s v1 IHv1] v2 H.
+ simpl;auto.
+ destruct v2.
  - by simpl in H.
  - specialize (IHv1 v2).
    assert (length v1 = length v2).
    { simpl in H. lia. } specialize (IHv1 H0).
    simpl. rewrite -IHv1.
    assert (length (rev v1) = length (rev v2)).
    { by rewrite !rev_length. }
    clear IHv1 H H0.
    elim: (rev v1) (rev v2) H1  => [ |a1 v3 IHv3] v4 H.
    * destruct v4.
      ++ simpl;auto.
      ++ by simpl in H.
    * destruct v4.
      ++ by simpl in H.
      ++ simpl. rewrite IHv3; try by [].
         simpl in H. lia.
Qed.

Lemma dotprod_rev_equiv {ty} (v1 v2: vector ty):
  length v1 = length v2 ->
  dotprod (rev v1) (rev v2) = dotprod_r v1 v2.
Proof.
intros.
unfold dotprod, dotprod_r.
assert (combine (rev v1) (rev v2) = rev (combine v1 v2)).
{ by rewrite combine_rev. } rewrite H0.
rewrite <-fold_left_rev_right.
rewrite rev_involutive. reflexivity.
Qed.

(** The issue is that b could appear more than once in the list.
    So the current version of lemma is not correct
***)
(*
Lemma fold_right_except_zero {A B}
  (f: B -> A -> A) (a : A) (L: list B) (b :  B) :
  In b L ->
  (forall s d, In s L -> s <> b -> f s d = d) ->
  fold_right f a L = f b a.
Admitted.
*)

Definition mulmx_float {ty} {m n p : nat}
  (A: 'M[ftype ty]_(m.+1,n.+1)) (B: 'M[ftype ty]_(n.+1,p.+1)) :
  'M[ftype ty]_(m.+1,p.+1):=
  \matrix_(i, k)
    let l1 := vec_to_list_float n.+1 (\row_(j < n.+1) A i j)^T in
    let l2 := vec_to_list_float n.+1 (\col_(j < n.+1) B j k) in
    @dotprod_r ty l1 l2.

Definition opp_mat {ty} {m n: nat} (A : 'M[ftype ty]_(m.+1, n.+1))
  : 'M[ftype ty]_(m.+1, n.+1) :=
  \matrix_(i,j) (BOPP (A i j)).

Definition sub_mat {ty} {m n: nat} (A B : 'M[ftype ty]_(m.+1, n.+1))
  : 'M[ftype ty]_(m.+1, n.+1) :=
  \matrix_(i,j) (BMINUS (A i j) (B i j)).

Notation "A +f B" := (addmx_float A B) (at level 80).
Notation "-f A" := (opp_mat A) (at level 50).
Notation "A *f B" := (mulmx_float A B) (at level 70).
Notation "A -f B" := (sub_mat A B) (at level 80).

Definition A1_inv_J {ty} {n:nat} (A: 'M[ftype ty]_n.+1) : 'cV[ftype ty]_n.+1 :=
  \col_i (BDIV (Zconst ty 1) (A i i)).

Definition A2_J {ty} {n:nat} (A: 'M[ftype ty]_n.+1):
  'M[ftype ty]_n.+1 :=
  \matrix_(i,j)
    if (i==j :> nat) then (Zconst ty 0) else A i j.

Definition diag_vector_mult {ty} {n:nat} (v1 v2: 'cV[ftype ty]_n.+1)
  : 'cV[ftype ty]_n.+1 :=
  \col_i (BMULT (nth (n.+1.-1 -i) (vec_to_list_float n.+1 v1) (Zconst ty 0))
            (nth (n.+1.-1 - i) (vec_to_list_float n.+1 v2) (Zconst ty 0))).

Definition jacobi_iter {ty} {n:nat} x0 b (A: 'M[ftype ty]_n.+1) :
  'cV[ftype ty]_n.+1 :=
   let r := b -f ((A2_J A) *f x0) in
   diag_vector_mult (A1_inv_J A) r.

Definition X_m_jacobi {ty} {n:nat} m x0 b (A: 'M[ftype ty]_n.+1) :
  'cV[ftype ty]_n.+1 :=
   Nat.iter m  (fun x0 => jacobi_iter x0 b A) x0.

Definition matrix_inj' {t} (A: matrix t) m n  d d': 'M[ftype t]_(m,n):=
    \matrix_(i < m, j < n)
     nth j (nth i A d) d'.

Definition matrix_inj {t} (A: matrix t) m n  : 'M[ftype t]_(m,n):=
  matrix_inj' A m n [::] (Zconst t 0).

Definition vector_inj' {t} (v: vector t) n d : 'cV[ftype t]_n :=
   \col_(i < n) nth i v d.

Definition vector_inj {t} (v: vector t) n : 'cV[ftype t]_n :=
   vector_inj' v n (Zconst t 0).

Lemma length_veclist {ty} {n m:nat} (v: 'cV[ftype ty]_n.+1):
  length (@vec_to_list_float _ n m v) = m.
Proof.
induction m.
+ simpl. auto.
+ simpl. by rewrite IHm.
Qed.

Definition FT2R_mat {m n: nat} {ty} (A : 'M[ftype ty]_(m.+1, n.+1)) :
   'M[R]_(m.+1, n.+1):=
  \matrix_(i, j) FT2R (A i j).

End WITHNANS.


Add LoadPath "C:\Users\Hp\Documents\CoqGit\Rel" as CoqRelDir.

Load RelEuclDiv.

Definition CongMod (k : rel) (x y : rel) : Prop :=
  ( ∃ q : rel, x == q*k + y ).

Notation "x ≡ y 'mod' k" := (CongMod k x y) (at level 50).

Instance sym_CongMod (k : rel) : Symmetric (CongMod k).
Proof.
  move => x y.
  case => q => Ck_xy.
  unfold "_ ≡ _ 'mod' _".
  exists (-q). ring [Ck_xy].
Qed.

Instance refl_CongMod (k : rel) : Reflexive (CongMod k).
Proof.
  move => x.
  exists O_Z. ring.
Qed.

Instance trans_CongMod (k : rel) : Transitive (CongMod k).
Proof.
  move => x y z.
  case => q_xy Ck_xy.
  case => q_yz Ck_yz.
  exists (q_xy + q_yz).
  ring [Ck_xy Ck_yz].
Qed.

Instance equiv_CongMod (k : rel) : Equivalence (CongMod k).
Proof.
  split.
  apply refl_CongMod.
  apply sym_CongMod.
  apply trans_CongMod.
Qed.

Instance CongMod_Proper (k : rel) : Proper (rel_eq ==> rel_eq ==> iff) (CongMod k).
Proof.
  move => x x' Eqxx' y y' Eqyy'.
  unfold "_ ≡ _ mod _ ".
  split.
    case => q H. exists q.
    setoid_rewrite <-Eqxx'.
    setoid_rewrite <-Eqyy'.
    assumption.
    case => q H. exists q.
    setoid_rewrite Eqxx'.
    setoid_rewrite Eqyy'.
    assumption.
Qed.

Example test_CongMod_Propper : forall k x y z t : rel,
  (x == y) -> (y == z) -> (z == t) -> ( x ≡ t mod k ) .
Proof.
  move => k x y z t.
  move => -> -> ->.
  reflexivity.
Qed.

Lemma simpl_CongMod0 : ∀ y M : rel, M > O_Z -> O_Z <= y -> y < M -> O_Z ≡ y mod M -> O_Z == y.
Proof.
  move => y M Mspos y_pos y_infM.
  unfold CongMod.
  intro congr; inversion congr; clear congr.

  assert ((x == O_Z) \/ (x > O_Z) \/ (x < O_Z)) as Disj.
  case x as [x_0 x_1].
  unfold "==", "<", O_Z.
  lia.

  case Disj.

  + move => Eqx0.
    setoid_rewrite Eqx0 in H.
    ring_simplify in H; fold O_Z in H.
    assumption.

  + case => Hx.
    assert (x * M + y > O_Z).
      assert (O_Z < x * M) as H1 by apply relspos_prod => //.
      apply (@rel_plusProper_ltle O_Z (x * M) H1 O_Z y) => //.
    rewrite <-H in H0.
    unfold O_Z, rel_lt in H0; lia.

    assert (x * M + y < O_Z ).
      assert (x * M <= - M) as H1 by apply rel_spos_sneg_prod => //.
      assert (x * M < - y) as H2.
        assert (- M < - y) by apply rel_minusProper_lt => //.
        apply (@rel_lelt_lt (x * M) (- M) (- y)) => //.
        assert (y <= y) by reflexivity.
      pose H3 := (@rel_plusProper_ltle (x * M) (- y) H2 y y H0).
      ring_simplify in H3; fold O_Z in H3; assumption.
      rewrite <-H in H0. unfold "<", O_Z in H0. lia.
Qed.


Require Export P14.

(** **** Exercise: 3 stars, optional (inequiv_exercise)  *)
(** Prove that an infinite loop is not equivalent to [SKIP] *)

Theorem loop_never_stops : forall st st',
  ~(loop / st \\ st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef
           eqn:Heqloopdef.
  induction contra; inversion Heqloopdef.
  - (* WhileEnd *) rewrite H1 in H. inversion H.
  - (* WhileLoop *) subst. contradiction.
Qed.

Theorem inequiv_exercise:
  ~ cequiv (WHILE BTrue DO SKIP END) SKIP.
Proof.
  intro H.
  eapply loop_never_stops with empty_state empty_state.
  unfold loop. apply H. constructor.
Qed.


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday :
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition negb' (b : bool) : bool :=
  if b then false
  else true.

Example test_negb1 : (negb true) = false.
Proof. simpl. reflexivity. Qed.

Example test_negb2 : (negb false) = true.
Proof. simpl. reflexivity. Qed.

Definition andb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition andb' (b1 : bool) (b2 : bool) : bool :=
  if b1 then b2
  else false.

Notation "x && y" := (andb x y).

Example test_andb1 : (andb true false) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb2 : (andb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb3 : (andb false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb4 : (andb true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_andb5 : true && true && false = false.
Proof. simpl. reflexivity. Qed.

Definition orb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Definition orb' (b1 : bool) (b2 : bool) : bool :=
  if b1 then true
  else b2.

Notation "x || y" := (orb x y).

Example test_orb1 : (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb2 : (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_orb3 : (orb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb4 : (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb5 : false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1 : bool) (b2 : bool) : bool :=
  negb (andb b1 b2).

Example test_nandb1 : (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2 : (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3 : (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4 : (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1 : bool) (b2 : bool) (b3 : bool) : bool :=
  andb b1 (andb b2 b3).

Example test_monochrome : (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_andb32 : (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb33 : (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb34 : (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.
Check true : bool.
Check (negb true) : bool.
Check negb : bool -> bool.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

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

Example test_monochrome1 : (monochrome (black)) = true.
Proof. simpl. reflexivity. Qed.

Example test_monochrome2 : (monochrome (white)) = true.
Proof. simpl. reflexivity. Qed.

Example test_monochrome3 : (monochrome (primary blue)) = false.
Proof. simpl. reflexivity. Qed.

Definition isred (c : color) : bool :=
  match c with
  | primary red => true
  | _ => false
  end.

Compute (isred (primary red)).
Compute (isred (black)).
Compute (isred (white)).
Compute (isred (primary blue)).
Compute (isred (primary green)).

Example test_isred1 : (isred (primary red)) = true.
Proof. simpl. reflexivity. Qed.

Example test_isred2 : (isred (primary blue)) = false.
Proof. simpl. reflexivity. Qed.

Example test_isred3 : (isred black) = false.
Proof. simpl. reflexivity. Qed.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

Module TuplePlayground.
  Inductive bit : Type :=
    | B0
    | B1.

  Inductive nybble : Type :=
    | bits (b0 b1 b2 b3 : bit).

  Check (bits B1 B0 B1 B0)
    : nybble.

  Definition all_zero (nb : nybble) : bool :=
    match nb with
    | bits B0 B0 B0 B0 => true
    | _ => false
    end.

  Compute (all_zero (bits B1 B0 B1 B0)).

  Compute (all_zero (bits B0 B0 B0 B0)).
End TuplePlayground.

Module NatPlayground.
  Inductive nat : Type :=
    | O
    | S (n : nat).

  Inductive nat' : Type :=
    | stop
    | tick (foo : nat').

  Definition pred (n : nat) : nat :=
    match n with
    | O => O
    | S n' => n'
    end.
End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1 : odd 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_odd2 : odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.
  Fixpoint plus (n : nat) (m : nat) : nat :=
    match n with
    | O => m
    | S n' => S (plus n' m)
    end.

  Compute (plus 3 2).

  Fixpoint mult (n m : nat) : nat :=
    match n with
    | O => O
    | S n' => plus m (mult n' m)
    end.

  Fixpoint minus (n m : nat) : nat :=
    match n, m with
    | O, _ => O
    | _, O => n
    | S n', S m' => minus n' m'
    end.
End NatPlayground2.

Fixpoint exp (b p : nat) : nat :=
  match p with
  | O => S O
  | S p' => mult b (exp b p')
  end.

Fixpoint factorial (n : nat) : nat :=
  match n with
  | O => S O
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                    (at level 50, left associativity)
                    : nat_scope.

Notation "x - y" := (minus x y)
                    (at level 50, left associativity)
                    : nat_scope.

Notation "x * y" := (mult x y)
                    (at level 40, left associativity)
                    : nat_scope.

Check ((0 + 1) + 1) : nat.

Fixpoint eqb (n m : nat) : bool :=
  match n, m with
  | O, O => true
  | S n', S m' => eqb n' m'
  | _, _ => false
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Example test_eqb1 : eqb 0 0 = true.
Proof. simpl. reflexivity. Qed.

Example test_eqb2 : eqb 1 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_eqb3 : eqb 4 2 = false.
Proof. simpl. reflexivity. Qed.

Example test_eqb4 : 1 =? 1 = true.
Proof. simpl. reflexivity. Qed.

Fixpoint leb (n m : nat) : bool :=
  match n, m with
  | O, _ => true
  | S n', S m' => leb n' m'
  | _, _ => false
  end.

Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Example test_leb1 : leb 0 0 = true.
Proof. simpl. reflexivity. Qed.

Example test_leb2 : leb 1 3 = true.
Proof. simpl. reflexivity. Qed.

Example test_leb3 : leb 5 2 = false.
Proof. simpl. reflexivity. Qed.

Example test_leb4 : 1 <=? 2 = true.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
  if eqb n m then false
  else leb n m.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1 : ltb 0 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_ltb2 : ltb 0 0 = false.
Proof. simpl. reflexivity. Qed.

Example test_ltb3 : ltb 5 2 = false.
Proof. simpl. reflexivity. Qed.

Example test_ltb4 : 1 <? 2 = true.
Proof. simpl. reflexivity. Qed.

Theorem plus_0_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_0_n' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_0_n'' : forall n : nat, 0 + n = n.
Proof.
  intros m. reflexivity. Qed.

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m : nat,
  n = m ->
  n + m = m + m.

Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity. Qed.

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

Proof.
  intros n m o.
  intros H.
  intros G.
  rewrite -> H.
  rewrite -> G.
  reflexivity. Qed.

Check mult_n_O.

Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn : E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn : E.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn : Eb.
  - destruct c eqn : Ec.
    + reflexivity.
    + reflexivity.
  - destruct c eqn : Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn : Eb.
  { destruct c eqn : Ec.
    { reflexivity. }
    { reflexivity. } }
  { destruct c eqn : Ec.
    { reflexivity. }
    { reflexivity. } }
Qed.

Theorem andb3_exchange : forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn : Eb.
  - destruct c eqn : Ec.
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn : Ec.
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct c eqn : Ec.
  - reflexivity.
  - intros H. rewrite <- H. destruct b eqn : Eb.
    + reflexivity.
    + reflexivity.
Qed.

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative'' : forall b c,
  andb c b = andb b c.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [|n].
    - reflexivity.
    - reflexivity.
Qed.

(* Level means precendence level, 1 + 2 * 3 * 4 -> (1 + ((2 * 3) * 4)) *)
(* Coq tries to understand context with scopes, type_scope *)
Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.

Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

(* plus' is performing structural recursion on `n` (descreasing)
  That implies that all calls of plus' will terminate.
  Coq demands that. *)
Fixpoint plus' (n m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus' n' m)
  end.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool), (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool), (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  destruct b eqn : Eb.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool), (andb b c = orb b c) ->
  b = c.
Proof.
  intros [] c.
  - simpl. intros H. rewrite <- H. reflexivity.
  - simpl. intros H. rewrite <- H. reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (b : bin) : bin :=
  match b with
  | Z => B1 Z
  | B0 b' => B1 b'
  | B1 b' => B0 (incr b')
  end.

Fixpoint bin_to_nat (b : bin) : nat :=
  match b with
  | Z => 0
  | B0 b' => 2 * (bin_to_nat b')
  | B1 b' => 1 + 2 * (bin_to_nat b')
  end.

Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
Proof. simpl. reflexivity. Qed.

Example test_bin_incr5 :
        bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr6 :
        bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.


Require Export PredMonad.Ordered6.OrderedType.

(***
 *** The monad typeclass
 ***)

Class MonadOps (M: OType -> OType) : Type :=
  { returnM : forall {A}, A -o> M A;
    bindM : forall {A B}, M A -o> (A -o> M B) -o> M B }.

Class Monad M `{MOps:MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall A B (f: A -o> M B) x,
        bindM @o@ (returnM @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall A (m : M A), bindM @o@ m @o@ returnM =o= m;

    monad_assoc :
      forall A B C m (f: A -o> M B) (g: B -o> M C),
        bindM @o@ (bindM @o@ m @o@ f) @o@ g
        =o=
        bindM @o@ m @o@ (mkOTerm _ (fun x => bindM @o@ (f @o@ x) @o@ g));
  }.

(* Helpful bind notation *)
Notation "'do' x <- m1 ; m2" :=
  (bindM @o@ m1 @o@ (mkOTerm _ (fun x => m2))) (at level 60, right associativity).

(* Add the monad laws to the OT rewrite set *)
Hint Rewrite @monad_return_bind @monad_bind_return @monad_assoc : OT.

(***
 *** The Identity Monad
 ***)

Definition Identity (A:OType) := A.

Instance IdMonad_MonadOps : MonadOps Identity :=
  { returnM := fun A => mkOTerm (A -o> Identity A) (fun x => x);
    bindM := fun A B =>
               mkOTerm (A -o> (A -o> B) -o> B)
                       (fun m (f:Pfun A B) => f @o@ m) }.

Instance IdMonad : Monad Identity.
Proof.
  constructor; intros; simpl; reflexivity.
Qed.


Set Implicit Arguments.
Require Import List Morphisms FinFun.
From Undecidability.HOU Require Import std.tactics std.ars.basic std.ars.confluence.
Import ListNotations.

Set Default Proof Using "Type".

Section ListRelations.

  Variable (X : Type) (R: X -> X -> Prop).
  Inductive lstep: list X -> list X -> Prop :=
  | stepHead s s' A: R s s' -> lstep (s :: A) (s' :: A)
  | stepTail s A A': lstep A A' -> lstep (s :: A) (s :: A').

  Hint Constructors lstep : core.

  Lemma lstep_cons_nil S:
    lstep S nil -> False.
  Proof.
    intros. inv H.
  Qed.

  Lemma lsteps_cons_nil s S:
    star lstep (s :: S) nil -> False.
  Proof.
    intros. remember (s :: S) as S'. remember nil as T.  revert S s HeqS' HeqT.
    induction H.
    - intros; subst; discriminate.
    - intros; subst. inv H; eapply IHstar; eauto.
  Qed.

  Lemma lstep_nil_cons S:
    lstep nil S -> False.
  Proof.
    intros H. inv H.
  Qed.

  Lemma lsteps_nil_cons s S:
    star lstep nil (s :: S) -> False.
  Proof.
    intros H. inv H.
    eapply lstep_nil_cons; eauto.
  Qed.

  Lemma lsteps_cons_inv s t S T:
    star lstep (s :: S) (t :: T) -> star R s t /\ star lstep S T.
  Proof.
    intros H. remember (s :: S) as S'. remember (t :: T) as T'.
    revert s t S T HeqS' HeqT'.
    induction H; intros.
    - subst. injection HeqT' as ??; subst. intuition.
    - subst. inv H.
      + destruct (IHstar s' t S T); eauto.
      + destruct (IHstar s t A' T); eauto.
  Qed.

  Global Instance lsteps_cons :
    Proper (star R ++> star lstep ++> star lstep) cons.
  Proof.
    intros ??; induction 1; intros ??; induction 1; eauto.
  Qed.

  Lemma confluence_lstep:
    confluent R -> confluent lstep.
  Proof.
    intros conf ?. induction x; intros.
    - inv H. inv H0. exists nil; eauto. inv H. inv H1.
    - destruct y, z; try solve [exfalso; eapply lsteps_cons_nil; eauto].
      eapply lsteps_cons_inv in H; eapply lsteps_cons_inv in H0.
      intuition; destruct (IHx _ _ H2 H3) as [V].
      destruct (conf _ _ _ H1 H) as [v].
      exists (v :: V).
      now rewrite H5, H0. now rewrite H6, H4.
  Qed.

  Hint Resolve confluence_lstep : core.

  Lemma normal_lstep_in A:
    Normal lstep A -> forall x, In x A  -> Normal R x.
  Proof.
    induction A; cbn; intuition; subst; eauto.
    intros ? H1. eapply H. constructor. eassumption.
    eapply IHA; eauto. intros ? H2. eapply H.
    econstructor 2; eauto.
  Qed.

  Lemma normal_in_lstep A:
    (forall x, In x A  -> Normal R x) -> Normal lstep A.
  Proof.
    induction A; cbn; intuition.
    - intros ? H1. inv H1.
    - intros ? H1. inv H1.
      eapply H; eauto.
      eapply IHA; eauto.
  Qed.

  Lemma lstep_normal_cons_l a A:
    Normal lstep (a :: A) -> Normal R a.
  Proof. intros ? ? ?. eapply H; econstructor; eauto. Qed.

  Lemma lstep_normal_cons_r a A:
    Normal lstep (a :: A) -> Normal lstep A.
  Proof. intros ? ? ?. eapply H; econstructor 2; eauto. Qed.

  Lemma lstep_normal_cons a A:
    Normal R a -> Normal lstep A -> Normal lstep (a :: A).
  Proof. intros ? ? ? ?. inv H1; firstorder.  Qed.

  Lemma lstep_normal_nil:
    Normal lstep nil.
  Proof. intros ? H; inv H. Qed.

  Hint Resolve
       lstep_normal_nil
       lstep_normal_cons_l
       lstep_normal_cons_r
       lstep_normal_cons : core.

  Hint Resolve normal_lstep_in normal_in_lstep : core.

  Lemma equiv_lstep_cons_inv s t S T:
    equiv lstep (s :: S) (t :: T) -> equiv R s t /\ equiv lstep S T.
  Proof.
    intros H. remember (s :: S) as S'. remember (t :: T) as T'.
    revert s t S T HeqS' HeqT'.
    induction H; intros.
    - subst. injection HeqT' as ??; subst; intuition.
    - subst. inv H.
      + destruct x'. eapply lstep_cons_nil in H1 as [].
        edestruct IHstar; eauto. inv H1.
        * intuition.
          transitivity x; eauto.
        * intuition. transitivity x'; eauto.
      + destruct x'. eapply lstep_nil_cons in H1 as [].
        edestruct IHstar; eauto. inv H1; intuition.
        * transitivity x; eauto.
        * transitivity x'; eauto.
  Qed.

  Global Instance equiv_lstep_cons_proper:
    Proper (equiv R ++> equiv lstep ++> equiv lstep) cons.
  Proof.
    intros ??; induction 1; intros ??; induction 1; eauto.
    - rewrite <-IHstar. destruct H.
      eauto. symmetry. eauto.
    - rewrite <-(IHstar x0 x0); try reflexivity.
      destruct H. eauto. symmetry. eauto.
    - rewrite <-IHstar0.
      destruct H1. eauto. symmetry. eauto.
  Qed.

  Lemma not_equiv_lstep_nil_cons a A:
    ~ equiv lstep nil (a :: A).
  Proof.
    intros H; inv H; inv H0; inv H.
  Qed.

  Lemma list_equiv_ind (P: list X -> list X -> Prop):
    P nil nil ->
    (forall s t S T, equiv R s t -> equiv lstep S T -> P S T -> P (s :: S) (t :: T)) ->
    forall S T, equiv lstep S T -> P S T.
  Proof.
    intros B IH S T H; induction S in T, H |-*; destruct T; eauto.
    - exfalso; eapply not_equiv_lstep_nil_cons; eauto.
    - exfalso; eapply not_equiv_lstep_nil_cons; symmetry; eauto.
    - eapply equiv_lstep_cons_inv in H as (? & ?).
      eapply IH; eauto.
  Qed.

End ListRelations.

#[export] Hint Constructors lstep : core.

#[export] Hint Resolve
     lstep_normal_nil
     lstep_normal_cons_l
     lstep_normal_cons_r
     lstep_normal_cons : core.

#[export] Hint Resolve confluence_lstep : core.
#[export] Hint Resolve normal_lstep_in normal_in_lstep : core.