(************************************************************************)
(*  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.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (x : lst) (n : natural) : lst := Cons n x.


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.


(** Proof of correctness of a persistent union-find data structure.
    See http://www.lri.fr/~filliatr/puf/ *)

(** 1. Persistent arrays *)

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.
Require Export Wf_nat.
Require Export ZArith.
Open Scope Z_scope.

(** Polymorphic pointer map for the memory model *)

Parameter pointer : Set.

Module PM.
  Parameter t : Set -> Set.
  Parameter find : forall a, t a -> pointer -> option a.
  Parameter add : forall a, t a -> pointer -> a -> t a.
  Parameter new : forall a, t a -> pointer.

  Axiom find_add_eq :
    forall a, forall m:t a, forall p:pointer, forall v:a,
    find (add m p v) p = Some v.
  Axiom find_add_neq :
    forall a, forall m:t a, forall p p':pointer, forall v:a,
    ~p'=p -> find (add m p v) p' = find m p'.
  Axiom find_new :
    forall a, forall m:t a, find m (new m) = None.

End PM.

Lemma old_is_not_new :
  forall a, forall m:PM.t a, forall p, PM.find m p <> None -> p <> PM.new m.
Proof.
  intros a m p hp1 hp2.
  generalize (PM.find_new m); subst p; assumption.
Qed.

(** memory model for datatypes t = data ref and data = ... *)
Inductive data : Set :=
  | Array : data
  | Diff  : Z -> Z -> pointer -> data.

Record mem : Set := { ref : PM.t data; arr : Z->Z }.

Definition upd (f:Z->Z) (i:Z) (v:Z) :=
  fun j => if Z_eq_dec j i then v else f j.
Axiom upd_ext : forall f g:Z->Z, (forall i, f i = g i) -> f=g.

Lemma upd_eq : forall f i j v, i=j -> upd f i v j = v.
Proof.
  intros; unfold upd; case (Z_eq_dec j i); auto.
  intro; absurd (i=j); auto.
Qed.
Ltac upd_eq := rewrite upd_eq; auto.

Lemma upd_neq : forall f i j v, i<>j -> upd f i v j = f j.
Proof.
  intros; unfold upd; case (Z_eq_dec j i); auto.
  intro; absurd (i=j); auto.
Qed.
Ltac upd_neq := rewrite upd_neq; auto.

(* the property of being a well-formed persistent array:
   from a given pointer, there is a finite Diff chain ending on Array *)
Inductive pa_valid (m: mem) : pointer -> Prop :=
  | array_pa_valid :
     forall p, PM.find (ref m) p = Some Array -> pa_valid m p
  | diff_pa_valid :
     forall p i v p', PM.find (ref m) p = Some (Diff i v p') ->
     pa_valid m p' -> pa_valid m p.

Inductive pa_model (m: mem) : pointer -> (Z -> Z) -> Prop :=
  | pa_model_array :
     forall p, PM.find (ref m) p = Some Array -> pa_model m p (arr m)
  | pa_model_diff :
     forall p i v p', PM.find (ref m) p = Some (Diff i v p') ->
     forall f, pa_model m p' f -> pa_model m p (upd f i v).

Lemma pa_model_pa_valid :
  forall m p f, pa_model m p f -> pa_valid m p.
Proof.
  induction 1.
  apply array_pa_valid; auto.
  apply diff_pa_valid with (i:=i) (v:=v) (p':=p'); auto.
Qed.
Hint Resolve pa_model_pa_valid.

Lemma pa_valid_pa_model :
  forall m p, pa_valid m p -> exists f, pa_model m p f.
Proof.
  induction 1.
  exists (arr m); apply pa_model_array; auto.
  destruct IHpa_valid.
  exists (upd x i v); apply pa_model_diff with (i:=i) (v:=v) (p':=p'); auto.
Qed.

(** auxiliary lemmas to circumvent Coq deficiencies *)
Lemma array_pa_valid_2 :
  forall m, forall p:pointer, forall a,
  PM.find m p = Some Array -> pa_valid (Build_mem m a) p.
Proof.
  intros m p a pr; exact (array_pa_valid (Build_mem m a) pr).
Qed.

Lemma pa_model_array_2 :
  forall m, forall p:pointer, forall a,
  PM.find m p = Some Array -> pa_model (Build_mem m a) p a.
Proof.
  intros m p a pr; exact (pa_model_array (Build_mem m a) pr).
Qed.

Lemma pa_model_diff_2 :
  forall m, forall p:pointer, forall i v p', forall f f',
  PM.find m p = Some (Diff i v p') ->
  pa_model (Build_mem m f) p' f' ->
  f = upd f' i v ->
  pa_model (Build_mem m f) p f.
Proof.
  intros m p i v p' f f' pr1 pr2 pr3.
  subst f;
  apply pa_model_diff with (p':=p'); auto.
Qed.

Lemma pa_model_function :
  forall m p f1, pa_model m p f1 -> forall f2, pa_model m p f2 -> f1=f2.
Proof.
  induction 1; induction 1; intuition.
  rewrite H in H0; discriminate H0.
  rewrite H in H1; discriminate H1.
  rewrite H in H1; injection H1; intros; subst; auto.
  generalize (IHpa_model f0 H2); intro; subst; auto.
Qed.

(** main separation lemma *)
Lemma pa_valid_sep :
  forall m, forall p, forall d,
  pa_valid m p ->
  pa_valid (Build_mem (PM.add (ref m) (PM.new (ref m)) d) (arr m)) p.
Proof.
  induction 1; simpl.
  apply array_pa_valid_2.
  rewrite PM.find_add_neq; trivial.
  apply old_is_not_new; rewrite H; discriminate.
  apply diff_pa_valid with (i:=i) (v:=v) (p':=p').
  simpl; rewrite PM.find_add_neq; trivial.
  apply old_is_not_new; rewrite H; discriminate.
  trivial.
Qed.

(** the same, for [pa_model] *)
Lemma pa_model_sep :
  forall m, forall p, forall d, forall f,
  pa_model m p f->
  pa_model (Build_mem (PM.add (ref m) (PM.new (ref m)) d) (arr m)) p f.
Proof.
  induction 1; simpl.
  apply pa_model_array_2.
  rewrite PM.find_add_neq; trivial.
  apply old_is_not_new; rewrite H; discriminate.
  apply pa_model_diff with (p':=p').
  simpl; rewrite PM.find_add_neq; trivial.
  apply old_is_not_new; rewrite H; discriminate.
  trivial.
Qed.

(** We have a well-founded order relation on pointers, as soon as they point
    to valid persistent arrays. This is simply the usual order on the
    lengths to the immediate array i.E. the number of [Diff]s to follow to
    reach [Array]. *)

Inductive dist (m:PM.t data) : pointer -> nat -> Prop :=
  | dist_zero : forall p, PM.find m p = Some Array -> dist m p O
  | dist_succ : forall p p' i v n,
                PM.find m p = Some (Diff i v p') ->
                dist m p' n -> dist m p (S n).

Lemma dist_function : forall m, forall p n1,
  dist m p n1 -> forall n2, dist m p n2 -> n1=n2.
Proof.
  induction 1.
  destruct 1; auto.
  rewrite H0 in H; discriminate H.
  induction 1; auto.
  rewrite H in H1; discriminate H1.
  rewrite H in H1; injection H1.
  intros; subst.
  generalize (IHdist n0 H2); auto.
Qed.

Definition lt_dist (m:PM.t data) (p1 p2 : pointer) : Prop :=
  exists n1:nat,
  exists n2:nat,
  dist m p1 n1 /\ dist m p2 n2 /\ (n1 < n2)%nat.

Lemma lt_dist_wf : forall m, well_founded (lt_dist m).
Proof.
intro m.
apply well_founded_inv_lt_rel_compat with
 (F := fun (x:pointer) (n:nat) => dist m x n).
unfold lt_dist, inv_lt_rel.
intros p1 p2 (n1, (n2, (h1,(h2,h3)))).
exists n1.
assumption.
intros n3 hn3; generalize (dist_function h2 hn3).
intros; subst; auto.
Qed.

Lemma lt_dist_diff :
  forall m p, pa_valid m p ->
  forall i v p',
  PM.find (ref m) p = Some (Diff i v p') -> lt_dist (ref m) p' p.
Proof.
  unfold lt_dist; induction 1; intros.
  rewrite H0 in H; discriminate H.
  rewrite H1 in H; injection H; intros; subst.
  inversion H0.
  exists O; exists (S O); intuition.
  apply dist_zero; auto.
  apply dist_succ with (i:=i) (v:=v) (p':=p'); auto.
  apply dist_zero; auto.
  generalize (IHpa_valid i0 v0 p'0 H2).
  intros (n1,(n2,(h1,(h2,h3)))).
  exists (S n1); exists (S n2); intuition.
  apply dist_succ with (i:=i0) (v:=v0) (p':=p'0); auto.
  apply dist_succ with (i:=i) (v:=v) (p':=p'); auto.
Qed.

Lemma mem_inv :
  forall m p,
  { d:data | PM.find (ref m) p = Some d }+
  { PM.find (ref m) p = None }.
Proof.
  intros m p; destruct (PM.find (ref m) p).
  left; exists d; auto.
  right; auto.
Defined.

Lemma pa_inversion :
  forall m p, pa_valid m p ->
  { p':pointer & { i:Z & { v:Z |
    PM.find (ref m) p = Some (Diff i v p') /\ pa_valid m p' }}}
+ { PM.find (ref m) p = Some Array}.
Proof.
  intros m p h.
  elim (mem_inv m p).
  intros (d,hp). destruct d.
  right; auto.
  left; exists p0; exists z; exists z0; intuition.
  inversion h; rewrite H in hp.
  discriminate hp.
  injection hp; intros; subst; auto.
  intro; elimtype False.
  inversion h; rewrite H in b; discriminate b.
Defined.

(** The function [get] *)
(* ***************************************************************************
 let rec get t i = match !t with
  | Array a -> a.(i)
  | Diff (j, v, t') -> if i == j then v else get t' i
*************************************************************)

Definition get :
  forall m, forall p, pa_valid m p ->
  forall i, { v:Z | forall f, pa_model m p f -> v = f i }.
Proof.
  intros m; induction p using (well_founded_induction (lt_dist_wf (ref m))).
  intros h i.
  elim (pa_inversion h).
  (* Diff j v p' *)
  intros (p',(j,(v,(h1,h2)))).
  case (Z_eq_dec i j); intro hij.
  exists v; intros.
  inversion H0; rewrite H1 in h1.
  discriminate h1.
  injection h1; intros; subst.
  unfold upd; case (Z_eq_dec j j); simpl; auto.
  intros; absurd (j<>j); auto.
  assert (hp': lt_dist (ref m) p' p).
  apply lt_dist_diff with j v; auto.
  elim (H p' hp' h2 i); intros.
  exists x; intuition.
  inversion H0; rewrite H1 in h1. discriminate h1.
  injection h1; intros; subst.
  unfold upd; case (Z_eq_dec i j); intuition.
  (* Array *)
  intro; exists (arr m i); intros.
  inversion H0; auto.
  rewrite H1 in b; discriminate b.
Defined.
Implicit Arguments get [].

(* ************************************************************
let set t i v = match !t with
  | Array a as n ->
      let old = a.(i) in
      a.(i) <- v;
      let res = ref n in
      t := Diff (i, old, res);
      res
  | Diff _ ->
      ref (Diff (i, v, t))
***************************************************************)

(** The function [set] *)
(* set : mem -> pointer -> Z -> Z -> pointer * mem *)

Definition set_code (m:mem) (p:pointer) (i v : Z) :=
  match PM.find (ref m) p with
  | Some Array =>
      let old := arr m i in
      let arrm := upd (arr m) i v in
      let res := PM.new (ref m) in
      let refm := PM.add (ref m) res Array in
      let refm := PM.add refm p (Diff i old res) in
      (res, Build_mem refm arrm)
  | Some (Diff _ _ _) =>
      let p' := PM.new (ref m) in
      let refm := PM.add (ref m) p' (Diff i v p) in
      (p', Build_mem refm (arr m))
  | None =>
      (* absurd *) (p,m)
  end.

Lemma set_correct :
  forall m:mem, forall p:pointer, forall i v:Z,
  forall f, pa_model m p f ->
  let (p',m') := set_code m p i v in
  pa_model m' p f /\
  pa_model m' p' (upd f i v).
Proof.
  unfold set_code; destruct 1; simpl.
  rewrite H; simpl.
  split.
  set (res := PM.new (ref m)).
  pattern (arr m) at 3.
  replace (arr m) with (upd (upd (arr m) i v) i (arr m i)).
  apply pa_model_diff with (p':=res).
  simpl.
  rewrite PM.find_add_eq; trivial.
  apply pa_model_array_2.
  rewrite PM.find_add_neq.
  rewrite PM.find_add_eq; trivial.
  red; intro; generalize (PM.find_new (ref m)).
  unfold res in *|-*; subst p.
  rewrite H; discriminate.
  apply upd_ext; intro i0.
  unfold upd; case (Z_eq_dec i0 i); simpl; intros; subst; auto.
  set (res := PM.new (ref m)).
  apply pa_model_array_2.
  rewrite PM.find_add_neq.
  rewrite PM.find_add_eq; trivial.
  red; intro; generalize (PM.find_new (ref m)).
  unfold res in *|-*; subst p.
  rewrite H; discriminate.
(* Diff *)
  rewrite H; simpl.
  split.
  apply pa_model_diff with (p':=p').
  simpl; rewrite PM.find_add_neq; trivial.
  apply old_is_not_new; rewrite H; discriminate.
  apply pa_model_sep; trivial.
  apply pa_model_diff with (p':=p); simpl.
  rewrite PM.find_add_eq; trivial.
  apply pa_model_diff with (p':=p'); simpl.
  rewrite PM.find_add_neq; trivial.
  apply old_is_not_new; rewrite H; discriminate.
  apply pa_model_sep; trivial.
Qed.

Definition set :
  forall m:mem, forall p:pointer, forall i v:Z,
  forall f:Z->Z, pa_model m p f ->
  { p':pointer & { m':mem | pa_model m' p f /\
                            pa_model m' p' (upd f i v) } }.
Proof.
  intros m p i v f h.
  generalize (set_correct i v h).
  destruct (set_code m p i v).
  intros (h1,h2); exists p0; exists m0; intuition.
Defined.

(* or, equivalently *)
Definition set2 :
  forall m:mem, forall p:pointer, forall i v:Z,
  pa_valid m p ->
  { p':pointer & { m':mem |
    forall f, pa_model m p f ->
       pa_model m' p f /\
       pa_model m' p' (upd f i v) } }.
Admitted.

(** 2. Persistent union-find *)

Parameter N : Z.

Inductive repr (f: Z->Z)  : Z->Z->Prop :=
  | repr_zero :
      forall i, f i = i -> repr f i i
  | repr_succ :
      forall i j r, f i = j -> 0<=j<N -> ~j=i -> repr f j r -> repr f i r.

Lemma repr_below_N :
  forall f i r, 0<=i<N -> repr f i r -> 0<=r<N.
Proof.
  induction 2; auto.
Qed.
Hint Resolve repr_below_N.

(* *
Definition is_puf (m:mem2) (p:pointer) (fc:Z->Z) (f:Z->Z) :=
  pa_valid (c m) p fc /\ pa_valid (father m) p f
 /\ forall i, 0<=i<N -> exists j, repr f i j.
**)

Definition reprf (f:Z->Z) :=
  (forall i, 0<=i<N -> 0<=f i<N) /\
  (forall i, 0<=i<N -> exists j, repr f i j).

Definition uf_valid (m:mem) (p:pointer) :=
  pa_valid m p /\
  forall f, pa_model m p f -> reprf f.

Inductive distr (f : Z->Z) : Z -> nat -> Prop :=
  | distr_zero : forall i, f i = i -> distr f i O
  | distr_succ : forall i j n,
                 j = f i -> j <> i ->
                 distr f j n -> distr f i (S n).

Lemma distr_function : forall f, forall i n1,
  distr f i n1 -> forall n2, distr f i n2 -> n1=n2.
Proof.
  induction 1.
  destruct 1; auto with *.
  induction 1; auto with *.
  intros; subst.
  generalize (IHdistr n0 H4); auto.
Qed.

Definition lt_distr (m:mem) (p : pointer) (i1 i2 : Z) : Prop :=
  exists n1:nat,
  exists n2:nat,
  exists f, pa_model m p f /\
  distr f i1 n1 /\ distr f i2 n2 /\ (n1 < n2)%nat.

Require Export Wf_nat.

Lemma lt_distr_wf : forall m p, well_founded (lt_distr m p).
Proof.
intros m p.
apply well_founded_inv_lt_rel_compat with
 (F := fun (i:Z) (n:nat) => exists f, pa_model m p f /\ distr f i n).
unfold lt_distr, inv_lt_rel.
intros i1 i2 (n1, (n2, (f,(h1,(h2,(h3,h4)))))).
exists n1.
exists f; intuition.
intros n3 (f1,(hf1a,hf1b)).
assert (f1=f). apply pa_model_function with m p; auto.
subst f1.
generalize (distr_function h3 hf1b).
intros; subst; auto.
Qed.

(* **
  let rec find_aux f i =
    let fi = A.get f i in
    if fi == i then
      f, i
    else
      let f, r = find_aux f fi in
      let f = A.set f i r in
      f, r

  let find h x =
    let f,rx = find_aux h.father x in h.father <- f; rx
***)

(* f1 and f2 define the same representatives *)
Definition same_reprs f1 f2 :=
  forall i, 0<=i<N -> forall j, repr f1 i j <-> repr f2 i j.

Lemma same_reprs_repr :
  forall f1 f2, same_reprs f1 f2 ->
  forall x rx, 0<=x<N -> repr f1 x rx -> repr f2 x rx.
Proof.
  unfold same_reprs; intros.
  assert (0<=rx<N).
  eauto.
  generalize (H x H0 rx); intuition.
Qed.
Hint Resolve same_reprs_repr.

(* x and y are in the same class *)
Definition equiv f x y :=
  forall rx ry, repr f x rx -> repr f y ry -> rx=ry.

(* x and y are not in the same class *)
Definition disjoint f x y :=
  forall rx ry, repr f x rx -> repr f y ry -> ~rx=ry.

Lemma repr_function :
  forall f x r1, repr f x r1 -> forall r2, repr f x r2 -> r1=r2.
Proof.
  induction 1.
  induction 1; auto.
  assert (eqij: i=j).
  omega.
  rewrite eqij; apply IHrepr; rewrite <- eqij; assumption.
  induction 1; auto.
  absurd (i=j); auto with *.
  assert (j=j0). omega. subst.
  eauto.
Qed.
Hint Resolve repr_function.

Lemma repr_fixpoint :
  forall f i r, repr f i r -> f r = r.
Proof.
  induction 1; auto.
Qed.
Hint Resolve repr_fixpoint.

(** equiv is an equivalence relation *)
Lemma equiv_refl :
  forall f a, equiv f a a.
Proof.
  unfold equiv; eauto.
Qed.

Lemma equiv_trans :
  forall f, reprf f ->
  forall a b c, 0<=a<N -> 0<=b<N -> 0<=c<N ->
  equiv f a b -> equiv f b c -> equiv f a c.
Proof.
  unfold equiv; intuition.
  unfold reprf in H.
  destruct H.
  elim (H10 b).
  intros rb hrb.
  transitivity rb; auto.
  auto.
Qed.

Lemma equiv_sym :
  forall f a b, equiv f a b -> equiv f b a.
Proof.
  unfold equiv; intuition.
  symmetry; auto.
Qed.

Hint Resolve equiv_refl equiv_sym equiv_trans.

Lemma same_reprs_refl :
  forall f, same_reprs f f.
Proof.
  unfold same_reprs; intuition.
Qed.

Lemma same_reprs_sym :
  forall f1 f2, same_reprs f1 f2 -> same_reprs f2 f1.
Proof.
  unfold same_reprs; intuition; firstorder.
Qed.

Lemma same_reprs_trans :
  forall f1 f2 f3, same_reprs f1 f2 -> same_reprs f2 f3 ->
  same_reprs f1 f3.
Proof.
  unfold same_reprs; intros.
  generalize (H i H1 j) (H0 i H1 j); intuition.
Qed.
Hint Resolve same_reprs_refl same_reprs_sym same_reprs_trans.

Lemma reprf_distr :
  forall f, reprf f ->
  forall x, 0<=x<N -> exists n, distr f x n.
Proof.
  unfold reprf; intros.
  destruct H; destruct (H1 x H0).
  induction H2.
  exists O; auto.
  apply distr_zero; auto.
  elim (IHrepr H3); intros n hn.
  exists (S n).
  apply distr_succ with j; auto.
Qed.

Ltac case_eq x y :=
  case (Z_eq_dec x y); intro; [subst x | idtac].

Lemma path_compression :
  forall f, reprf f ->
  forall x, 0<=x<N ->
  forall r, repr f x r ->
  reprf (upd f x r).
Proof.
  unfold reprf; intros.
  destruct H.
  split; intros.
  unfold upd; case (Z_eq_dec i x); intro.
  apply repr_below_N with f x; auto.
  auto.
  destruct (H2 i H3) as [j hj].
  induction hj.
  case_eq x i.
  exists r.
  assert (i=r).
  inversion H1; auto.
  absurd (i<>j); auto with *.
  subst i; apply repr_zero.
  upd_eq.
  exists i; apply repr_zero; auto.
  upd_neq.
  case_eq i x.
  exists r.
  case_eq x r.
  apply repr_zero; auto.
  upd_eq.
  apply repr_succ with r; auto.
  upd_eq.
  apply repr_below_N with f x; auto.
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with x; auto.
  destruct (IHhj H5) as [j0 hj0].
  exists j0; apply repr_succ with j; auto.
  upd_neq.
Qed.

Lemma path_compression_2 :
  forall f, reprf f ->
  forall x, 0<=x<N ->
  forall r, repr f x r ->
  same_reprs f (upd f x r).
Proof.
  intros; unfold same_reprs; split.
  induction 1.
  case (Z_eq_dec i x); intro.
  apply repr_zero; auto.
  upd_eq.
  assert (repr f i i). apply repr_zero; auto.
  subst i; apply repr_function with f x; auto.
  apply repr_zero; auto.
  upd_neq.
  generalize (IHrepr H4); intro h; clear IHrepr.
  case (Z_eq_dec i x); intro.
  assert (repr f i r0).
  apply repr_succ with j; auto.
  assert (r=r0).
  subst i; apply repr_function with f x; auto.
  subst i r0.
  case_eq x r.
  apply repr_zero; auto.
  upd_eq.
  apply repr_succ with r; auto.
  upd_eq.
  apply repr_below_N with f x; auto.
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with x; auto.
  apply repr_succ with j; auto.
  upd_neq.
(* upd f -> f *)
  induction 1.
  case_eq i x.
  rewrite upd_eq in H3; auto.
  subst x; apply repr_zero; auto.
  apply repr_fixpoint with r; auto.
  rewrite upd_neq in H3; auto.
  apply repr_zero; auto.
  generalize (IHrepr H4); clear IHrepr; intro h.
  case_eq i x.
  rewrite upd_eq in H3; auto.
  subst j.
  assert (repr (upd f x r) r r).
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with x; auto.
  assert (r=r0).
  apply repr_function with (upd f x r) r; auto.
  subst r0. assumption.
  rewrite upd_neq in H3; auto.
  apply repr_succ with j; auto.
Qed.

Definition find :
  forall (m:mem), forall p, uf_valid m p ->
  forall x, 0<=x<N ->
  { r:Z & { p':pointer & { m':mem |
    (*(forall p, uf_valid m p -> uf_valid m' p) /\ *)
    uf_valid m' p' /\
    forall f, pa_model m p f -> repr f x r /\
    forall f', pa_model m' p' f' -> same_reprs f f' } } }.
Proof.
  intros m p h; induction x using (well_founded_induction (lt_distr_wf m p)).
  intros hx.
   (* let x0 = get m p x *)
  destruct h.
  destruct (get m p H0 x).
  case (Z_eq_dec x0 x); intro.
  (* x0 = x *)
  subst x0; exists x; exists p; exists m; intuition.
  unfold uf_valid; intuition.
  apply repr_zero; symmetry; intuition.
  assert (f'=f). apply pa_model_function with m p; auto.
  subst f'; auto.
  (* x0 <> x *)
  (* let r,p',m' = find x0 *)
  destruct (H x0) as [r (p0,(m0,(h1,h2)))]; clear H.
  elim (pa_valid_pa_model H0); intros f hf.
  generalize (H1 f hf); clear H1; intro H1.
  generalize (e f hf); clear e; intro e.
  unfold lt_distr.
  assert (Ix0: 0<=x0<N). unfold reprf in H1. subst x0; firstorder.
  destruct (reprf_distr H1 Ix0).
  exists x1; exists (S x1); exists f; intuition.
  apply distr_succ with x0; auto.
  elim (pa_valid_pa_model H0); intros f hf.
  generalize (e f hf); clear e; intro e.
  generalize (H1 f hf); clear H1; intro H1.
  unfold reprf in H1. subst x0; firstorder.
  (* let p1,m1 = set2 m0 p0 x r *)
  destruct h1.
  destruct (set2 x r H) as [p1 (m1,h3)].
  exists r; exists p1; exists m1.
  elim (pa_valid_pa_model H0); intros f hf.
  generalize (H1 f hf); clear H1; intro H1.
  generalize (e f hf); clear e; intro e.
  elim (pa_valid_pa_model H); intros f0 hf0.
  generalize (H2 f0 hf0); clear H2; intro H2.
  destruct (h2 f hf) as [h4 h5]; clear h2.
  generalize (h5 f0 hf0); clear h5; intro h5.
  generalize (h3 f0 hf0); clear h3; intros (h6,h7).
  split.
  unfold uf_valid. split. eauto.
  intros f2 hf2. assert (f2 = upd f0 x r).
  eapply pa_model_function; eauto.
  subst f2.
  assert (repr f x r).
  apply repr_succ with x0; auto.
  unfold reprf in H1. destruct H1. subst x0.
  apply H1; auto.
  assert (repr f0 x r).
  unfold same_reprs in h5.
  destruct (h5 x hx r).
  auto.
  apply path_compression; auto.
  intros f1 hf1.
  assert (f1=f).
  apply pa_model_function with m p; auto.
  subst f1; clear hf1.
  split.
  apply repr_succ with x0; auto.
  unfold reprf in H1. destruct H1. subst x0.
  apply H1; auto.
  intros f' hf'.
  assert (f' = upd f0 x r).
  apply pa_model_function with m1 p1; auto.
  subst f'; clear hf'.
  assert (repr f x r).
  apply repr_succ with x0; auto.
  unfold reprf in H1. destruct H1. subst x0.
  apply H1; auto.
  assert (repr f0 x r).
  unfold same_reprs in h5.
  destruct (h5 x hx r).
  auto.
  apply same_reprs_trans with f0; auto.
  apply path_compression_2; auto.
Defined.

(* TODO: reroot *)

(* ** simpler version not using the ranks:

  let union h x y =
    let rx = find h x in
    let ry = find h y in
    if rx != ry then begin
      { h with father = A.set h.father ry rx }
    end else
      h
***)

Lemma same_reprs_equiv :
  forall f1 f2 x y, 0<=x<N -> 0<=y<N ->
  same_reprs f1 f2 -> equiv f1 x y -> equiv f2 x y.
Proof.
  unfold same_reprs,equiv; intros.
  generalize (H1 x H rx) (H1 y H0 ry) (H2 rx ry); intuition.
Qed.

Lemma same_reprs_equiv_2 :
  forall f1 f2 x y r, 0<=x<N -> 0<=y<N ->
  same_reprs f1 f2 -> repr f1 x r -> repr f2 y r -> equiv f2 x y.
Proof.
  unfold same_reprs, equiv; intros.
  generalize (H1 x H r) (H1 y H0 r); intuition.
  assert (r=rx); eauto.
  assert (r=ry); eauto.
  subst; auto.
Qed.
Hint Resolve same_reprs_equiv same_reprs_equiv_2.

Lemma repr_snoc :
  forall f x rx ry, 0<=rx<N -> rx<>ry -> repr f x rx ->
  forall y, repr f y ry -> repr (upd f ry rx) y rx.
Proof.
  induction 4.
  apply repr_succ with rx; auto.
  upd_eq.
  generalize (repr_fixpoint H1).
  intro; apply repr_zero; auto.
  upd_neq.
  case (Z_eq_dec i r); intro.
  subst i.
  apply repr_succ with rx; auto.
  upd_eq.
  apply repr_zero; auto.
  generalize (repr_fixpoint H1).
  intro; upd_neq.
  apply repr_succ with j; intuition.
  upd_neq.
Qed.
Hint Resolve repr_snoc.

Lemma repr_main_lemma :
  forall f,
  reprf f ->
  forall x y rx ry,
  0 <= x < N -> 0 <= y < N -> rx <>ry ->
  repr f x rx ->
  repr f y ry ->
  reprf (upd f ry rx).
Proof.
  red; intros.
  unfold reprf in H; destruct H.
  assert (0 <= rx < N).
  apply repr_below_N with f x; auto.
  split; intros.
  unfold upd; case_eq i ry; auto.
  assert (repr (upd f ry rx) y rx).
  apply repr_snoc with x; auto.
  destruct (H5 i H7) as [j hj].
  case_eq i ry.
  exists rx.
  apply repr_succ with rx; auto.
  upd_eq.
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with x; auto.
  induction hj.
  exists i.
  apply repr_zero; auto.
  upd_neq.
  case_eq j ry.
  exists rx.
  apply repr_succ with ry; auto.
  upd_neq.
  apply repr_below_N with f y; auto.
  apply repr_succ with rx; auto.
  upd_eq.
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with x; auto.
  assert (0 <= j < N).
  subst j; apply H; auto.
  destruct (IHhj H12 n0) as [r0 hr0].
  exists r0.
  apply repr_succ with j; auto.
  upd_neq.
Qed.

Lemma repr_x_inv_upd :
  forall f rx ry x,
  repr f x rx -> repr (upd f ry rx) x rx.
Proof.
  induction 1.
  apply repr_zero.
  unfold upd; case (Z_eq_dec i ry); auto.
  case (Z_eq_dec i ry); auto.
  intro; subst i.
  case (Z_eq_dec r ry); auto.
  intro; subst; apply repr_zero; auto.
  upd_eq.
  intro; apply repr_succ with r; auto.
  upd_eq.
  apply repr_below_N with f j; auto.
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with j; auto.
  intro; apply repr_succ with j; auto.
  upd_neq.
Qed.
Hint Resolve repr_x_inv_upd.

Hint Resolve pa_model_function.

Lemma equiv_def :
  forall f a b, equiv f a b ->
  forall ra rb, repr f a ra -> repr f b rb -> ra=rb.
Proof.
  unfold equiv; intuition.
Qed.
Hint Resolve equiv_def.

Lemma equiv_inv :
  forall f a b r, repr f a r -> repr f b r -> equiv f a b.
Proof.
  unfold equiv; intuition.
  assert (r=rx). apply repr_function with f a; auto.
  assert (r=ry). apply repr_function with f b; auto.
  subst; auto.
Qed.
Hint Resolve equiv_inv.

Lemma repr_idem :
  forall f x rx, repr f x rx -> repr f rx rx.
Proof.
  induction 1; auto.
  apply repr_zero; auto.
Qed.

Lemma union_lemma_1 :
  forall x y,
  0 <= x < N -> 0 <= y < N ->
  forall rx ry, rx <> ry ->
  forall (f : Z -> Z), reprf f ->
  repr f x rx -> repr f y ry ->
  forall a, 0 <= a < N ->
  repr (upd f ry rx) a rx -> (repr f a rx \/ repr f a ry).
Proof.
  intros.
  induction H6.
  case_eq i ry.
  left; apply repr_zero; auto.
  apply repr_fixpoint with y; auto.
  rewrite upd_neq in H6; auto.
  left; apply repr_zero; auto.
  generalize (IHrepr H7); clear IHrepr; intro hj.
  case_eq i ry.
  right; apply repr_idem with y; auto.
  rewrite upd_neq in H6; auto.
  destruct hj; [left | right]; apply repr_succ with j; auto.
Qed.

Lemma union_lemma_2 :
  forall x y,
  0 <= x < N -> 0 <= y < N ->
  forall rx ry, rx <> ry ->
  forall (f : Z -> Z), reprf f ->
  repr f x rx -> repr f y ry ->
  forall a ra, 0 <= a < N -> repr (upd f ry rx) a ra -> ra<>rx ->
  repr f a ra.
Proof.
  intros.
  induction H6.
  case_eq i ry.
  rewrite upd_eq in H6; auto.
  absurd (rx=ry); auto with *.
  apply repr_zero; auto.
  rewrite upd_neq in H6; auto.
  generalize (IHrepr H8 H7); clear IHrepr; intro hjr.
  case_eq i ry.
  rewrite upd_eq in H6; auto.
  subst j.
  assert (repr (upd f ry rx) rx rx).
  apply repr_zero; auto.
  upd_neq.
  apply repr_fixpoint with x; auto.
  absurd (r=rx); auto.
  apply repr_function with (upd f ry rx) rx; auto.
  apply repr_succ with j; auto.
  rewrite upd_neq in H6; auto.
Qed.

Lemma repr_inv_upd :
  forall x y,
  0 <= x < N -> 0 <= y < N ->
  forall rx ry, rx <> ry ->
  forall (f : Z -> Z), reprf f ->
  repr f x rx -> repr f y ry ->
  forall a ra, 0 <= a < N -> repr f a ra -> ra<>ry ->
  repr (upd f ry rx) a ra.
Proof.
  intros.
  induction H6.
  apply repr_zero; auto.
  upd_neq.
  case_eq ry j.
  assert (repr f j j).
  apply repr_idem with y; auto.
  assert (j=r). apply repr_function with f j; auto.
  absurd (j=r); auto with *.
  case_eq i ry.
  assert (f ry = ry). apply repr_fixpoint with y; auto.
  absurd (f ry = ry); auto with *.
  apply repr_succ with j; auto.
  upd_neq.
Qed.

Lemma union_main_lemma :
  forall x y,
  0 <= x < N -> 0 <= y < N ->
  forall rx ry, rx <> ry ->
  forall (f : Z -> Z), reprf f ->
  repr f x rx -> repr f y ry ->
  forall a b, 0 <= a < N -> 0 <= b < N ->
  (equiv (upd f ry rx) a b <->
   (equiv f a b \/ ((equiv f a x /\ equiv f b y) \/
                    (equiv f b x /\ equiv f a y)))).
Proof.
  intros.
  assert (rrx: repr (upd f ry rx) x rx).
  apply repr_x_inv_upd; auto.
  assert (Irx: 0 <= rx < N).
  apply repr_below_N with f x; auto.
  assert (rry: repr (upd f ry rx) y rx).
  apply repr_snoc with x; auto.
  assert (reprf_updf: reprf (upd f ry rx)).
  apply repr_main_lemma with x y; auto.
  split; intros.
  destruct reprf_updf.
  destruct (H9 a H5) as [ra hra].
  destruct (H9 b H6) as [rb hrb].
  assert (ra=rb). eauto.
  subst rb.
  case_eq ra rx.
  assert (repr f a rx \/ repr f a ry).
  apply union_lemma_1 with x y; auto.
  assert (repr f b rx \/ repr f b ry).
  apply union_lemma_1 with x y; auto.
  destruct H10; destruct H11.
  left; eauto.
  right; left; eauto.
  right; right; eauto.
  left; eauto.
  left.
  assert (repr f a ra). apply (union_lemma_2 H H0 H1); auto.
  assert (repr f b ra). apply (union_lemma_2 H H0 H1); auto.
  eauto.
  (* <- *)
  destruct H2.
  destruct (H8 a H5) as [ra hra].
  destruct (H8 b H6) as [rb hrb].
  destruct H7.
  assert (ra=rb). eauto. subst rb.
  case_eq ra ry.
  assert (repr (upd f ry rx) a rx).
  apply repr_snoc with x; auto.
  assert (repr (upd f ry rx) b rx).
  apply repr_snoc with x; auto.
  eauto.
  assert (repr (upd f ry rx) a ra).
  apply repr_inv_upd with x y; auto.
  red; auto.
  assert (repr (upd f ry rx) b ra).
  apply repr_inv_upd with x y; auto.
  red; auto.
  eauto.
  destruct H7; destruct H7 as [h1 h2].
  assert (repr (upd f ry rx) a rx).
  assert (ra=rx). eauto. subst ra.
  apply repr_inv_upd with x y; auto.
  red; auto.
  assert (rb=ry). eauto. subst rb.
  assert (repr (upd f ry rx) b rx).
  apply repr_snoc with x; auto.
  eauto.
  assert (ra=ry). eauto. subst ra.
  assert (repr (upd f ry rx) a rx).
  apply repr_snoc with x; auto.
  assert (rb=rx). eauto. subst rb.
  assert (repr (upd f ry rx) b rx).
  apply repr_inv_upd with x y; auto.
  red; auto.
  eauto.
Qed.

Definition union :
  forall (m:mem), forall p, uf_valid m p ->
  forall x y, 0<=x<N -> 0<=y<N ->
  { p':pointer & { p1:pointer & { m':mem |
       uf_valid m' p1 /\ uf_valid m' p'  /\
       forall f1, pa_model m p f1 ->
       ((forall f2, pa_model m' p1 f2 -> same_reprs f1 f2) /\
        (forall f', pa_model m' p' f' ->
         (*equiv f' x y /\*)
         forall a b, 0<=a<N -> 0<=b<N ->
            (equiv f' a b <->
             (equiv f1 a b \/ ((equiv f1 a x /\ equiv f1 b y) \/
                               (equiv f1 b x /\ equiv f1 a y))))))
        }}}.
Proof.
  intros m p hpuf x y Ix Iy.
  elim (find hpuf Ix); intros rx (p0,(m0,(uf_m0_p0,hrx))).
  elim (find uf_m0_p0 Iy); intros ry (p1,(m1,(uf_m1_p1,hry))).
  case (Z_eq_dec rx ry); intro.

  (* rx = ry *)
  exists p1; exists p1; exists m1.
  split. assumption. split. assumption.
  intros f1 hf1.
  destruct uf_m0_p0.
  elim (pa_valid_pa_model H); intros f1m0 hf1m0.
  generalize (hrx f1 hf1); clear hrx; intros (h1,hrx).
  generalize (hrx f1m0 hf1m0); clear hrx; intros h2.
  split.
  intros f2 hf2.
  generalize (hry f1m0 hf1m0); clear hry; intros (h3,hry).
  generalize (hry f2 hf2); clear hry; intros h4.
  eauto.
  intros f' hf'.
  assert (equiv f' x y).
  generalize (hry f1m0 hf1m0); clear hry; intros (h3,hry).
  generalize (hry f' hf'); clear hry; intros h4.
  apply same_reprs_equiv with f1m0; auto.
  apply same_reprs_equiv_2 with f1 rx; subst; auto.
  generalize (hry f1m0 hf1m0); clear hry; intros (h3,hry).
  generalize (hry f' hf'); clear hry; intros h4.
  generalize (H0 f1m0 hf1m0); clear H0; intro.
  intros a b; split.
  intros hab.
  assert (equiv f1m0 a b). eauto.
  assert (equiv f1 a b); eauto.
  assert (reprf f').   red in uf_m1_p1; intuition.
  assert (equiv f1 x y). eauto.
  assert (same_reprs f1 f'). eauto.
  intuition eauto.
  assert (equiv f' a x). eauto.
  assert (equiv f' b y); eauto.
  apply equiv_trans with x; eauto.
  apply equiv_trans with y; auto.
  assert (equiv f' a y). eauto.
  assert (equiv f' b x); eauto.
  apply equiv_trans with y; eauto.
  apply equiv_trans with x; auto.

  (* rx <> ry: father = set ry rx *)
  destruct uf_m1_p1.
  elim (set2 ry rx H); intros p' (m2,hm2).
  exists p'; exists p1; exists m2.
  destruct hpuf.
  elim (pa_valid_pa_model H1); intros f hf.
  generalize (H2 f hf); clear H2; intro reprf_f.
  destruct uf_m0_p0.
  elim (pa_valid_pa_model H2); intros f0 hf0.
  generalize (H3 f0 hf0); clear H3; intro reprf_f0.
  generalize (hrx f hf); clear hrx; intros (h1,h2).
  generalize (h2 f0 hf0); clear h2; intro h2.
  elim (pa_valid_pa_model H); intros f1 hf1.
  generalize (H0 f1 hf1); clear H0; intro reprf_f1.
  generalize (hry f0 hf0); clear hry; intros (h3,h4).
  generalize (h4 f1 hf1); clear h4; intro h4.
  generalize (hm2 f1 hf1); clear hm2; intros (h5,h6).
  split.
  unfold uf_valid; simpl; intuition eauto.
  assert (f2 = f1). eauto. subst f2; auto.
  split.
  unfold uf_valid; simpl; intuition eauto.
  assert (f2 = upd f1 ry rx). eauto.
  subst f2; apply repr_main_lemma with x y; eauto.
  intros.
  assert (f2 = f). eauto. subst f2.
  split; intros.
  assert (f2 = f1). eauto. subst f2.
  eauto.
  assert (f' = upd f1 ry rx). eauto. subst f'; clear H0 H3.
  assert (repr f1 x rx). eauto.
  assert (repr f1 y ry). eauto.
  assert (equiv f a b <-> equiv f1 a b). split; eauto.
  assert (equiv f a x <-> equiv f1 a x). split; eauto.
  assert (equiv f a y <-> equiv f1 a y). split; eauto.
  assert (equiv f b x <-> equiv f1 b x). split; eauto.
  assert (equiv f b y <-> equiv f1 b y). split; eauto.
  generalize (union_main_lemma Ix Iy n reprf_f1 H0 H3 H4 H5).
  intuition.
Defined.


(* 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] *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) : natural := lf1.