(** * Carac.v: Characteristic functions *)
Require Export Prog.
Set Implicit Arguments.
Unset Standard Proposition Elimination Names.
Require Export Sets.
Require Export Arith.
Module CaracFun (Univ:Universe).

Module RP := (Rules Univ).
(* begin hide *)
Import Univ.
Import RP.
Import RP.PP.
Import RP.PP.MP.
Import RP.PP.MP.UP.
(* end hide *)

Definition carac (A:Type)(P:A -> Prop)(Pdec:dec P)(z:A): U := if (Pdec z) then 1 else 0.

Lemma carac_one : forall (A:Type)(P:A -> Prop)(Pdec:dec P)(z:A),
       P z -> carac Pdec z == 1.
unfold carac; intros; case (Pdec z); intuition.
Qed.

Lemma carac_zero : forall (A:Type)(P:A -> Prop)(Pdec:dec P)(z:A),
       ~P z -> carac Pdec z == 0.
unfold carac; intros; case (Pdec z); intuition.
Qed.

Lemma carac_unit : forall (A:Type)(P:A -> Prop)(Pdec : dec P)(a:A),
                                  (P a) -> 1 <= (mu (Munit a)) (carac Pdec).
simpl;intros.
unfold unit,carac.
case (Pdec a); intuition.
Qed.

Lemma carac_let_one : forall (A B:Type)(m1: distr A)(m2: A -> distr B) (P:B -> Prop)(Pdec: dec P),
     mu m1 (f_one A) == 1 -> (forall x:A, 1 <= mu (m2 x) (carac Pdec)) -> 1 <= mu (Mlet m1 m2) (carac Pdec) .
intros A B m1 m2.
simpl.
unfold star; intuition.
rewrite <- H.
apply (mu_monotonic m1).
red; intros.
unfold f_one; simpl; auto.
Qed.

Lemma carac_let : forall (A B:Type)(m1: distr A)(m2: A->distr B) (P:A->Prop)(Pdec: dec P)(f:B->U)(p:U),
     1 <= mu m1 (carac Pdec) -> (forall x:A, P x -> p <= mu (m2 x) f)
     -> p <= mu (Mlet m1 m2) f.
intros A B m1 m2.
simpl.
unfold star; intuition.
setoid_replace p with (mu m1 (fun x => p * (carac Pdec x))); auto.
apply (mu_monotonic m1).
red; intros.
unfold carac at 1; destruct (Pdec x);repeat Usimpl; auto.
rewrite (mu_stable_mult m1 p (carac Pdec)).
apply Ueq_trans with (p * 1); auto.
Qed.

Lemma carac_incl: forall (A:Type)(P Q:A -> Prop)(Pdec: dec P)(Qdec: dec Q),
                                incl P Q -> fle (carac Pdec) (carac Qdec).
red; intros;unfold carac.
case (Pdec x); case (Qdec x); intuition.
absurd (Q x); intuition.
Qed.

Definition equiv_dec : forall (A:Type)(P Q:A -> Prop),dec P -> equiv P Q -> dec Q.
intros A P Q Pdec EQ.
unfold dec; intro a; case (Pdec a); intro.
left; assert (eqA:=EQ a); intuition.
right; assert (eqA:=EQ a); intuition.
Defined.

Lemma carac_equiv : forall (A:Type)(P Q:A -> Prop)(Pdec : dec P)(EQ : equiv P Q),
feq  (carac (equiv_dec Pdec EQ)) (carac Pdec).
red; unfold carac; intros; unfold equiv_dec; case (Pdec x); intuition.
Qed.

Definition union_dec : forall (A:Type)(P Q:A -> Prop), dec P -> dec Q -> dec (union P Q).
intros A P Q Pdec Qdec.
unfold dec,union; intro a; case (Pdec a); intuition; case (Qdec a); intuition.
Defined.

Lemma carac_union : forall (A:Type)(P Q:A -> Prop)(Pdec : dec P)(Qdec : dec Q),
feq  (carac (union_dec Pdec Qdec)) (fun a => (carac Pdec a) + (carac Qdec a)).
red; unfold carac; intros.
unfold union_dec; case (Pdec x); intuition; case (Qdec x); intuition.
Qed.

Definition inter_dec : forall (A:Type)(P Q:A -> Prop),(dec P)->(dec Q) -> dec (inter P Q).
intros A P Q Pdec Qdec.
unfold dec,inter; intro a; case (Pdec a); intuition; case (Qdec a); intuition.
Defined.

Lemma carac_inter : forall (A:Type)(P Q:A -> Prop)(Pdec : dec P)(Qdec : dec Q),
feq  (carac (inter_dec Pdec Qdec)) (fun a => (carac Pdec a) * (carac Qdec a)).
red; unfold carac; intros.
unfold inter_dec; case (Pdec x); intuition; case (Qdec x); intuition.
Qed.

Definition  compl_dec : forall (A:Type)(P:A -> Prop), dec P -> dec (compl P).
intros A P Pdec.
unfold dec,compl; intro a; case (Pdec a); intuition.
Defined.

Lemma carac_compl : forall (A:Type)(P:A -> Prop)(Pdec : dec P),
feq  (carac (compl_dec Pdec)) (fun a => [1-](carac Pdec a)).
red; unfold carac; intros.
unfold compl_dec; case (Pdec x); intuition.
Qed.

Definition empty_dec : forall (A:Type)(P:A->Prop), equiv P (empty A) ->dec P.
unfold dec,empty; right; red; intros.
apply (equiv_empty_false (P:=P)) with x; auto.
Defined.

Lemma carac_empty : forall (A:Type)(P:A->Prop)
       (empP:equiv P (empty A)),feq (carac (empty_dec empP)) (f_zero A).
red; unfold carac; intros.
unfold empty_dec; intuition.
Qed.

Lemma carac_mult_fun : forall (A:Type)(P:A -> Prop)(Pdec : dec P)(f g:A->U),
  (forall x, P x -> f x==g x) -> forall x, carac Pdec x * f x == carac Pdec x * g x.
unfold carac; intros; destruct (Pdec x); repeat Usimpl; auto.
Qed.

Lemma carac_esp_fun : forall (A:Type)(P:A -> Prop)(Pdec : dec P)(f g:A->U),
  (forall x, P x -> f x==g x) -> forall x, carac Pdec x & f x == carac Pdec x & g x.
unfold carac; intros; destruct (Pdec x); repeat Usimpl; auto.
Qed.
Hint Resolve carac_esp_fun.

Lemma carac_esp_fun_le : forall (A:Type)(P:A -> Prop)(Pdec : dec P)(f g:A->U),
  (forall x, P x -> f x<=g x) -> forall x, carac Pdec x & f x <= carac Pdec x & g x.
unfold carac; intros; destruct (Pdec x); repeat Usimpl; auto.
Qed.
Hint Resolve carac_esp_fun_le.

Lemma carac_ok : forall (A:Type)(P Q:A -> Prop)(Pdec : dec P)(Qdec : dec Q),
        (forall x, P x -> ~ Q x) -> fplusok (carac Pdec) (carac Qdec).
red; red; intros.
unfold finv; case (Pdec x); intro.
rewrite carac_one; auto; rewrite carac_zero; auto.
rewrite carac_zero; auto.
Qed.
Hint Resolve carac_ok.

(** ** Modular reasoning on programs *)

Lemma mu_carac_esp : forall (A:Type)(m:distr A)(P:A -> Prop)(Pdec : dec P)(f:A->U),
  1<=mu m (carac Pdec) -> mu m f == mu m (fun x => carac Pdec x & f x).
intros; apply Ule_antisym.
apply Ule_trans with (mu m (carac Pdec) & mu m f).
setoid_replace (mu m (carac Pdec)) with 1; auto.
apply mu_le_esp with (f:=carac Pdec) (g:=f).
apply mu_monotonic.
repeat red; intros; auto.
Qed.

Lemma mu_cut : forall (A:Type)(m:distr A)(P:A -> Prop)(Pdec : dec P)(f g:A->U),
  (forall x, P x -> f x==g x) -> 1<=mu m (carac Pdec) -> mu m f == mu m g.
intros; apply Ueq_trans with (mu m (fun x => carac Pdec x & f x)).
apply mu_carac_esp; auto.
intros; apply Ueq_trans with (mu m (fun x => carac Pdec x & g x)).
apply mu_stable_eq; repeat red; intros;auto.
apply Ueq_sym; apply mu_carac_esp; auto.
Qed.

(** count the number of elements between 0 and n-1 which satisfy P *)
Fixpoint nb_elts (P:nat -> Prop)(Pdec : dec P)(n:nat) {struct n} : nat :=
match n with
   0 => 0%nat
  | S n => if Pdec n then (S (nb_elts Pdec n)) else (nb_elts Pdec n)
end.

(** the probability for a random number between 0 and n to satisfy P is equal
     to the number of elements below n which satisfy P divided by n+1 *)

Lemma random_carac : forall (P:nat -> Prop)(Pdec : dec P)(n:nat),
    random n (carac Pdec) == (nb_elts Pdec (S n)) */ [1/]1+n.
unfold random,fnth; intros.
elim (S n); simpl; intros;auto.
rewrite sigma_S.
rewrite H; unfold carac;case (Pdec n0); Usimpl; auto.
Qed.

Lemma mu_carac_inv : forall (A:Type)(P:A->Prop)(Pdec:dec P)(notPdec : dec (fun x => ~ (P x)))
     (m : distr A), mu m (carac Pdec) == mu m (finv (carac notPdec)).
intros; apply (mu_stable_eq m); red; intros.
unfold finv,carac.
case (Pdec x); case (notPdec x); intuition.
Qed.

Section SigmaFinite.
Variable A:Type.
Variable decA : forall x y:A, {x=y}+{~x=y}.

Section RandomFinite.

(** ** Uniform measure on finite sets *)

(** *** Distribution for [random_fin P] over $\{k:nat | k \leq n\}$
The distribution associated to [random_fin P] is
       $f \mapsto \Sigma_{a\in P} \frac{f(a)}{n+1}$
       with $n+1$ the size of $P$
       we cannot factorize $\frac{1}{n+1}$ because of possible overflow *)

Fixpoint sigma_fin (f:A->U)(P:A->Prop)(FP:finite P){struct FP}:U :=
match FP with
  | (fin_eq_empty eq) => 0
  | (fin_eq_add x Q nQx FQ eq) => (f x) + sigma_fin f FQ
end.

Definition retract_fin (P:A->Prop) (f:A->U) :=
     forall Q (FQ: finite Q), incl Q P -> forall x, ~(Q x) -> (P x) -> f x <= [1-](sigma_fin f FQ).

Lemma retract_fin_incl : forall P Q f, retract_fin P f -> incl Q P -> retract_fin Q f.
unfold retract_fin; intros.
apply (H Q0 FQ); auto.
apply incl_trans with Q; auto.
Qed.

Lemma sigma_fin_monotonic : forall (f g : A -> U)(P:A->Prop)(FP:finite P),
       (forall x, P x -> (f x)<=(g x))-> sigma_fin f FP <= sigma_fin g FP.
induction FP; simpl; intros; auto.
apply Ule_trans with (f x + sigma_fin g FP); repeat Usimpl.
apply IHFP.
intros; case (e x0); unfold add in *; intuition.
apply H; case (e x); unfold add in *; intuition.
Qed.

Lemma sigma_fin_eq_compat :
forall (f g : A -> U)(P:A->Prop)(FP:finite P),
       (forall x, P x -> (f x)==(g x))-> sigma_fin f FP == sigma_fin g FP.
intros; apply Ule_antisym; apply sigma_fin_monotonic; auto.
intros; rewrite (H x); auto.
Qed.

Lemma retract_fin_le : forall (P:A->Prop) (f g:A->U),
        (forall x, P x -> f x <= g x) -> retract_fin P g -> retract_fin P f.
unfold retract_fin; intros.
apply Ule_trans with (g x); auto.
apply Ule_trans with ([1-] sigma_fin g FQ); auto.
apply Uinv_le_compat.
apply sigma_fin_monotonic; auto.
Qed.

Lemma sigma_fin_mult : forall (f : A -> U) c (P:A->Prop)(FP:finite P),
       retract_fin P f -> sigma_fin (fun k  => c * f k) FP == c * sigma_fin f FP.
induction FP; simpl; intros.
repeat Usimpl; auto.
assert (incl Q P).
apply incl_trans with (add x Q); auto.
rewrite Udistr_plus_left; auto.
rewrite IHFP; auto.
apply retract_fin_incl with P; auto.
case (e x); intuition.
Qed.

Lemma sigma_fin_plus : forall (f g: A -> U) (P:A->Prop)(FP:finite P),
       sigma_fin (fun k  => f k + g k) FP == sigma_fin f FP + sigma_fin g FP.
induction FP; simpl; intros.
repeat Usimpl; auto.
rewrite IHFP.
repeat norm_assoc_left; repeat Usimpl.
repeat norm_assoc_right; repeat Usimpl; auto.
Qed.

Lemma sigma_fin_prod_maj :
forall (f g : A -> U)(P:A->Prop)(FP:finite P),
       sigma_fin (fun k  => f k * g k) FP <= sigma_fin f FP.
induction FP; simpl; auto.
Qed.

Lemma sigma_fin_prod_le :
forall (f g : A -> U) (c:U) , (forall k, f k <= c) -> forall (P:A->Prop)(FP:finite P),
retract_fin P g -> sigma_fin (fun k  => f k * g k) FP <= c * sigma_fin g FP.
induction FP; simpl; intros.
repeat Usimpl; auto.
assert (incl Q P).
apply incl_trans with (add x Q); auto.
assert (retract_fin Q g).
apply retract_fin_incl with P; auto.
apply Ule_trans with ((f x) * (g x) + (c * sigma_fin g FP)); auto.
apply Ule_trans with ( c * (g x) + (c * sigma_fin g FP)); auto.
rewrite Udistr_plus_left; auto.
case (e x); intuition.
Qed.

Lemma sigma_fin_prod_ge :
forall (f g : A -> U) (c:U) , (forall k, c <= f k) -> forall (P:A->Prop)(FP:finite P),
retract_fin P g -> c * sigma_fin g FP <= sigma_fin (fun k  => f k * g k) FP.
induction FP; simpl; intros.
repeat Usimpl; auto.
assert (incl Q P).
apply incl_trans with (add x Q); auto.
assert (retract_fin Q g).
apply retract_fin_incl with P; auto.
apply Ule_trans with ((f x) * (g x) + (c * sigma_fin g FP)); auto.
apply Ule_trans with ( c * (g x) + (c * sigma_fin g FP)); auto.
case (e x); intuition.
Qed.
Hint Resolve sigma_fin_prod_maj sigma_fin_prod_ge sigma_fin_prod_le.

Lemma sigma_fin_inv : forall (f g : A -> U)(P:A->Prop)(FP:finite P),
       retract_fin P f ->
       [1-] sigma_fin (fun k  => f k * g k) FP ==
       sigma_fin (fun k => f k * [1-] g k) FP + [1-] sigma_fin f FP.
induction FP; simpl.
repeat Usimpl; auto.
intro.
assert (incl Q P).
apply incl_trans with (add x Q); auto.
assert (retract_fin Q f).
apply retract_fin_incl with P; auto.
assert (px:P x).
case (e x); intuition.

apply Uplus_eq_simpl_right with ((f x) * (g x)).
repeat Usimpl; auto.

apply Uinv_le_perm_right.
rewrite (Udistr_inv_left (f x) (g x)).
repeat norm_assoc_right; apply Uplus_le_compat_right.
apply Ule_trans with
  (sigma_fin f FP + [1-] (f x + sigma_fin f FP)); repeat Usimpl.
apply (sigma_fin_prod_maj f (fun k => [1-](g k)) FP).

assert (sigma_fin f FP <= [1-] (f x)); auto.
rewrite <- (Uinv_plus_right H2); auto.

assert (sigma_fin (fun k => f k * g k) FP <= [1-] (f x * g x)).
apply Ule_trans with (sigma_fin f FP); auto.

apply Ule_trans with ([1-] (f x)); auto.
rewrite (Uinv_plus_left H2).
apply Ueq_trans with (1:=IHFP H1).
rewrite (Uplus_sym (f x * [1-] (g x))
                          (sigma_fin (fun k  => f k * [1-] (g k)) FP)).
repeat norm_assoc_right;apply Uplus_eq_compat_right.
setoid_rewrite (Uplus_sym  ([1-] (f x + sigma_fin f FP)) (f x * g x)).
repeat norm_assoc_left.
assert ([1-] (g x) <= [1-] (g x)); auto.

rewrite <- (Udistr_plus_left (f x) H3).
rewrite (Uinv_opp_left (g x)).
rewrite (Umult_one_right (f x)); auto.
rewrite (Uplus_sym (f x) ([1-] (f x + sigma_fin f FP))).
apply Ueq_sym; apply Uinv_plus_left; auto.
Qed.

Lemma sigma_fin_equiv : forall f P Q  (FP:finite P) (e:equiv P Q),
    (sigma_fin f (fin_equiv e FP)) = (sigma_fin f FP).
induction FP; simpl; intros; auto.
Qed.

Lemma sigma_fin_rem : forall f P (FP:finite P) a,
             P a -> sigma_fin f FP == f a + sigma_fin f (finite_rem decA a FP).
induction FP;  intuition.
case (equiv_empty_false a e);auto.
simpl; case (decA x a); simpl; intros.
case e0; unfold eq_rect_r;simpl; auto.
rewrite sigma_fin_equiv; auto.
rewrite (IHFP a); auto.
case (e a); unfold add; intuition.
case f0; auto.
Qed.

Lemma sigma_fin_incl : forall f P (FP:finite P) Q (FQ:finite Q),
              (incl P Q) -> sigma_fin f FP <= sigma_fin f FQ.
induction FP; simpl; intros; auto.
destruct FQ; simpl; intros.
case incl_add_empty with (a:=x) (P:=Q).
apply incl_trans with Q0; auto.
apply incl_trans with P; auto.
case (decA x x0); intro.
(* case x=x0*)
subst; Usimpl; auto.
apply IHFP.
apply incl_trans with (rem x0 P); auto.
apply incl_add_rem; auto.
apply incl_trans with (rem x0 Q0); auto.
rewrite incl_rem_add_iff; auto.
(* Case x<>x0 *)
rewrite (sigma_fin_rem f FQ x); auto.
repeat norm_assoc_left.
rewrite (Uplus_sym (f x0) (f x)).
repeat norm_assoc_right.
Usimpl.
assert (H3:~(rem x Q1 x0)).
unfold rem; intuition.
assert (incl Q (add x0 (rem x Q1))).
red; intros; case (e0 x1); clear e0; intuition.
case (e x1); clear e; intuition.
generalize (H x1); clear H; intuition.
unfold add,rem in *; intuition.
subst; intuition.
case (decA x1 x0); intuition; subst; intuition.
case (decA x1 x); intuition; subst; intuition.
exact (IHFP (add x0 (rem x Q1)) (fin_eq_add H3 (finite_rem decA x FQ) (equiv_refl (add x0 (rem x Q1)))) H0).
assert (P x).
red in e; rewrite e; auto.
assert (Q0 x);auto.
assert (Q1 x);auto.
case (e0 x); intuition.
case H4; intuition.
Qed.

Lemma sigma_fin_unique : forall f P Q (FP:finite P) (FQ:finite Q), (equiv P Q) -> sigma_fin f FP == sigma_fin f FQ.
intros; apply Ule_antisym.
apply sigma_fin_incl; auto.
apply sigma_fin_incl; auto.
Qed.

Lemma sigma_fin_cte : forall c P (FP:finite P),
       sigma_fin (fun _ => c) FP == (size FP) */ c.
induction FP; auto.
simpl sigma_fin; simpl size; rewrite IHFP; auto.
Qed.

(** *** Definition and Properties of [random_fin] *)

Variable P : A->Prop.
Variable FP : finite P.
Let s:= (size FP - 1)%nat.
Lemma pred_size_le : (size FP <=S s)%nat.
unfold s; omega.
Qed.
Hint Resolve pred_size_le.

Lemma pred_size_eq : notempty P -> size FP =S s.
destruct FP; intros; simpl.
unfold notempty in *; contradiction.
unfold s; simpl; omega.
Qed.

Definition random_fin :M A := fun (f:A->U) => sigma_fin (fun k => Unth s *  f k) FP.

Lemma fnth_retract_fin:
       forall n, (size FP<=S n)%nat -> (retract_fin P (fun _ => [1/]1+n)).
red; intros.
rewrite sigma_fin_cte.
apply Ule_trans with ([1-] (n */ [1/]1+n)); auto.
apply Uinv_le_compat.
apply Nmult_le_compat_left.
apply le_trans with (size (finite_rem decA x FP)); auto.
apply size_incl; auto.
unfold incl, rem; intuition.
subst; intuition.
apply le_S_n.
apply le_trans with (size FP); auto.
rewrite (size_finite_rem decA x FP); auto.
Qed.

Lemma random_fin_stable_inv : stable_inv random_fin.
unfold random_fin, stable_inv, finv; intros; auto.
rewrite (@sigma_fin_inv (fun k => [1/]1+s) f P FP); auto.
apply fnth_retract_fin; trivial.
Qed.

Lemma random_fin_stable_plus : stable_plus random_fin.
unfold random_fin, stable_plus, fplus; intros; auto.
unfold fplusok, fle, finv in H.
apply Ueq_trans with
 (sigma_fin (fun k => ([1/]1+s * f k) + ([1/]1+s  * g k)) FP).
apply sigma_fin_eq_compat; intros; auto.
apply sigma_fin_plus with (f:=fun k => Unth s * f k)
                      (g:=fun k => Unth s * g k); auto.
Qed.

Lemma random_fin_stable_mult : stable_mult random_fin.
unfold random_fin, stable_mult, fmult; intros; auto.
apply Ueq_trans with  (sigma_fin (fun l => k * ([1/]1+s * f l)) FP).
apply sigma_fin_eq_compat; intros; auto.
apply sigma_fin_mult with (f:=fun k  => Unth s * f k).
apply retract_fin_le with (fun (k:A) => [1/]1+s); auto.
apply fnth_retract_fin; auto.
Qed.

Lemma random_fin_monotonic : monotonic random_fin.
unfold monotonic, random_fin; intros.
red in H.
apply sigma_fin_monotonic; auto.
Qed.

Definition Random_fin : (distr A).
exists random_fin.
apply random_fin_stable_inv; trivial.
apply random_fin_stable_plus.
apply random_fin_stable_mult; trivial.
apply random_fin_monotonic.
Defined.

Lemma random_fin_total : notempty P -> mu Random_fin (f_one A) == 1.
intros; simpl; unfold random_fin.
unfold f_one.
apply Ueq_trans with  (sigma_fin (fun k =>  [1/]1+s) FP).
apply sigma_fin_eq_compat.
intros; repeat Usimpl; auto.
rewrite sigma_fin_cte.
rewrite pred_size_eq; auto.
Qed.
End RandomFinite.

Lemma random_fin_carac :
    forall P Q (FP:finite P) (decQ:dec Q),
         mu (Random_fin FP) (carac decQ) == size (finite_inter decQ FP) */ [1/]1+(size FP-1)%nat.
intros; simpl mu.
unfold random_fin.
pattern P at 1 3 4 5, FP at 2 3.
elim FP; intros; auto.
simpl sigma_fin.
unfold carac at 1.
rewrite H.
case (decQ x); intro.
rewrite size_inter_add_in; auto.
rewrite Nmult_S; auto.
repeat Usimpl; rewrite size_inter_add_notin; auto.
Qed.

Lemma random_fin_P : forall P (FP:finite P) (decP:dec P),
         notempty P -> mu (Random_fin FP) (carac decP) ==1.
intros; rewrite random_fin_carac.
rewrite (size_inter_incl decA decP FP FP); auto.
pattern (size FP) at 1; rewrite pred_size_eq; auto.
Qed.

End SigmaFinite.
End CaracFun.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Axiom.Separation.
Require Import BBST.Axiom.Pairing.
Require Import BBST.Axiom.Union.
Require Import BBST.Axiom.Power.
Require Import BBST.Definition.Include.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.Singleton.

Definition 壹 := {∅,}.

Lemma 壹介入 : ∅ ∈ 壹.
Proof. apply 单集介入. Qed.

Lemma 壹除去 : ∀ x, x ∈ 壹 → x = ∅.
Proof. intros. now apply 单集除去. Qed.

Lemma 壹的子集为零或壹 : ∀ x, x ⊆ 壹 → x = ∅ ∨ x = 壹.
Proof. apply 单集的子集是空集或该单集. Qed.

Lemma 壹之并为零 : ⋃ 壹 = ∅.
Proof. apply 单集之并. Qed.

Lemma 零之幂为壹 : 𝒫 ∅ = 壹.
Proof. exact 空集之幂. Qed.

Lemma 只有零或壹之并为零 : ∀ x, ⋃ x = ∅ ↔ x = ∅ ∨ x = 壹.
Proof with eauto.
  split; intros.
  - destruct (空集排中 x) as [Hx0|[a Ha]]. left...
    destruct (空集排中 a) as [Ha0|[b Hb]].
    + right. 外延 y Hy.
      * destruct (空集排中 y) as [Hy0|[c Hc]].
        -- subst. apply 壹介入.
        -- exfalso. eapply 空集除去 in H. apply H. eapply 并集介入...
      * apply 单集除去 in Hy. subst...
    + exfalso. eapply 空集除去 in H. apply H. eapply 并集介入...
  - destruct H; subst.
    + apply 空集之并.
    + apply 壹之并为零.
Qed.

Definition 贰 := {∅, 壹}.

Lemma 贰介入0 : ∅ ∈ 贰.
Proof. apply 左配对介入. Qed.

Lemma 贰介入1 : 壹 ∈ 贰.
Proof. apply 右配对介入. Qed.

Lemma 贰除去 : ∀ x, x ∈ 贰 → x = ∅ ∨ x = 壹.
Proof. intros. now apply 配对除去. Qed.

Lemma 贰之并为壹 : ⋃ 贰 = 壹.
Proof.
  外延.
  - apply 并集除去 in H as [a [Ha Hx]].
    apply 贰除去 in Ha as []; subst. 空集归谬. auto.
  - eapply 并集介入; eauto. apply 贰介入1.
Qed.

Lemma 壹之幂为贰 : 𝒫 壹 = 贰.
Proof. apply 单集之幂. Qed.


From mathcomp Require Import ssreflect.
Require Import NPeano ZArith.
From Coquelicot Require Import Coquelicot.
Require Import Reals Field Psatz Plouffe CPlouffe Billion0.

(*
Time Eval native_compute in sumV cprecision cdigit 6.
*)

Definition comp4 := 289000933264774.

Lemma comp4_def : comp4 = sumV cprecision cdigit 6.
Proof.
native_cast_no_check (refl_equal comp4).
Time Qed.


Require Import PocklingtonRefl.

Open Local Scope positive_scope.

Lemma prime2166990353233 : prime 2166990353233.
Proof.
 apply (Pocklington_refl
         (Pock_certif 2166990353233 5 ((2383, 1)::(2,4)::nil) 23898)
        ((Proof_certif 2383 prime2383) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime1234567890123456789012353: prime  1234567890123456789012353.
apply (Pocklington_refl

(SPock_certif
1234567890123456789012353
2
((14246767565124824467, 1)::nil))
(
(Ell_certif
14246767565124824467
6574449
((2166990353233,1)::nil)
0
2058
7
49)
:: (Proof_certif 2166990353233 prime2166990353233) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

Class FeatureModel (F Conf: Type) : Type :=
{
  (*====================functions=======================*)
  FMRef        : F -> set Conf;
  FMRefinement : F -> F -> Prop;
  equivalentFMs: F -> F -> Prop;

  (*===========Axioms - Lemmas - Theorems====================*)

  eqFM :
    forall fm1: F, equivalentFMs fm1 fm1 /\
      (forall fm1 fm2: F,equivalentFMs fm1 fm2
        -> equivalentFMs fm2 fm1) /\
         (forall fm1 fm2 fm3: F,
            equivalentFMs fm1 fm2 /\ equivalentFMs fm2 fm3
              -> equivalentFMs fm1 fm3);
  refFM:
   forall fm1 fm2 fm3: F,
     FMRefinement fm1 fm2 -> FMRefinement fm2 fm3
      -> FMRefinement fm1 fm3
}.


Require Import BigO.Notation.
Require Import BigO.Util.DecField.
Require Import Coq.Classes.RelationClasses.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.interfaces.vectorspace.
Require Import MathClasses.orders.dec_fields.

(**
  Informal proof/overview:

  Assume f,g,h:V→V such that f ∈ O(g) and g ∈ O(h). Then

  By assumption,
    - ∃ k_g, n_g such that ∀ n > n_g, f(n) ≤ k_g * g(n)
    - ∃ k_h, n_h such that ∀ n > n_h, g(n) ≤ k_h * h(n)

  then, ∀ n > max(n_g, n_h),
    - g(n) ≤ k_h * h(n)
    - k_g * g(n) ≤ (k_g * k_h) * h(n)
  and
    - f(n) ≤ k_g * g(n)
  so by transitivity of ≤,
    - f(n) ≤ k_g * g(n) ≤ (k_g * k_h) * h(n)
    - f(n) ≤ (k_g * k_h) * h(n)
  hence, f ∈ O(h).
 *)

Section BigOTransitivity.
  Context `{@SemiNormedSpace
              K V
              Ke Kle Kzero Knegate Kabs Vnorm Ke Kplus Kmult Kzero Kone
              Knegate Krecip Ve Vop Vunit Vnegate smkv
           }.
  Context `{@SemiNormedSpace
              K W1
              Ke Kle Kzero Knegate Kabs Wnorm1 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We1 Wop1 Wunit1 Wnegate1 smkw1
           }.
  Context `{@SemiNormedSpace
              K W2
              Ke Kle Kzero Knegate Kabs Wnorm2 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We2 Wop2 Wunit2 Wnegate2 smkw2
           }.
  Context `{@SemiNormedSpace
              K W3
              Ke Kle Kzero Knegate Kabs Wnorm3 Ke Kplus Kmult Kzero Kone
              Knegate Krecip We3 Wop3 Wunit3 Wnegate3 smkw3
           }.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.

  Lemma big_O_trans :
    ∀ (f : V → W1) (g : V → W2) (h : V → W3),
      f ∈ O(g) → g ∈ O(h) → f ∈ O(h).

    (* Some arithmetic that will come in handy soon *)
    unfold transitive.
    intros f g h.
    unfold big_Theta in *.
    unfold big_O.

    (* Unfurl our hypotheses: f ∈ O(g), g ∈ O(h) *)
    intros [k_f_g [k_f_g_gt_0 [n0_f_g [n0_f_g_gt_0 HO_f_g]]]]
           [k_g_h [k_g_h_gt_0 [n0_g_h [n0_g_h_gt_0 HO_g_h]]]].

    exists (k_f_g * k_g_h).
    split.
    { (* 0 < k_f_g * k_g_h *)
      apply mult_pos_gt_0;
        assumption.
    }
    {
      exists (n0_f_g + n0_g_h).

      split.
      { (* 0 < n0_f_g + n0_g_h *)
        apply semirings.plus_lt_compat_r; assumption.
      }
      {
        intros n.

        (* Prove that our new n_0 is greater than the previous *)
        intros n_ge_n0.
        assert (n_ge_n0_f_g : n0_f_g ≤ ∥n∥) by (now apply (plus_le n0_f_g n0_g_h)).
        assert (n_ge_n0_g_h : n0_g_h ≤ ∥n∥) by
            (rewrite commutativity in n_ge_n0; now apply (plus_le n0_g_h n0_f_g)).
        clear n_ge_n0.

        assert (fn_le_gn : ∥f n∥ ≤ k_f_g * ∥g n∥) by (now apply HO_f_g).
        assert (gn_le_hn : ∥g n∥ ≤ k_g_h * ∥h n∥) by (now apply HO_g_h).

        clear HO_f_g HO_g_h.

        transitivity (k_f_g * ∥g n∥); try assumption.
        rewrite (order_preserving_mult_le (∥g n∥) (k_g_h * ∥h n∥));
          try assumption.
        now rewrite associativity.
      }
    }
  Qed.
End BigOTransitivity.


From Hammer Require Import Hammer.

Require Import FunInd Recdef FMapInterface FMapList ZArith Int FMapAVL ROmega.

Set Implicit Arguments.
Unset Strict Implicit.

Module AvlProofs (Import I:Int)(X: OrderedType).
Module Import Raw := Raw I X.
Module Import II:=MoreInt(I).
Import Raw.Proofs.
Local Open Scope pair_scope.
Local Open Scope Int_scope.

Ltac omega_max := i2z_refl; romega with Z.

Section Elt.
Variable elt : Type.
Implicit Types m r : t elt.

Inductive avl : t elt -> Prop :=
| RBLeaf : avl (Leaf _)
| RBNode : forall x e l r h,
avl l ->
avl r ->
-(2) <= height l - height r <= 2 ->
h = max (height l) (height r) + 1 ->
avl (Node l x e r h).

Hint Constructors avl.

Lemma height_non_negative : forall (s : t elt), avl s ->
height s >= 0.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.height_non_negative".
induction s; simpl; intros; auto with zarith.
inv avl; intuition; omega_max.
Qed.

Ltac avl_nn_hyp H :=
let nz := fresh "nz" in assert (nz := height_non_negative H).

Ltac avl_nn h :=
let t := type of h in
match type of t with
| Prop => avl_nn_hyp h
| _ => match goal with H : avl h |- _ => avl_nn_hyp H end
end.

Ltac avl_nns :=
match goal with
| H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
| _ => idtac
end.

Lemma avl_node : forall x e l r, avl l -> avl r ->
-(2) <= height l - height r <= 2 ->
avl (Node l x e r (max (height l) (height r) + 1)).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.avl_node".
intros; auto.
Qed.
Hint Resolve avl_node.

Lemma height_0 : forall l, avl l -> height l = 0 ->
l = Leaf _.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.height_0".
destruct 1; intuition; simpl in *.
avl_nns; simpl in *; exfalso; omega_max.
Qed.

Lemma empty_avl : avl (empty elt).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.empty_avl".
unfold empty; auto.
Qed.

Lemma create_avl :
forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
avl (create l x e r).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.create_avl".
unfold create; auto.
Qed.

Lemma create_height :
forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
height (create l x e r) = max (height l) (height r) + 1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.create_height".
unfold create; intros; auto.
Qed.

Lemma bal_avl : forall l x e r, avl l -> avl r ->
-(3) <= height l - height r <= 3 -> avl (bal l x e r).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.bal_avl".
intros l x e r; functional induction (bal l x e r); intros; clearf;
inv avl; simpl in *;
match goal with |- avl (assert_false _ _ _ _) => avl_nns
| _ => repeat apply create_avl; simpl in *; auto
end; omega_max.
Qed.

Lemma bal_height_1 : forall l x e r, avl l -> avl r ->
-(3) <= height l - height r <= 3 ->
0 <= height (bal l x e r) - max (height l) (height r) <= 1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.bal_height_1".
intros l x e r; functional induction (bal l x e r); intros; clearf;
inv avl; avl_nns; simpl in *; omega_max.
Qed.

Lemma bal_height_2 :
forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 ->
height (bal l x e r) == max (height l) (height r) +1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.bal_height_2".
intros l x e r; functional induction (bal l x e r); intros; clearf;
inv avl; avl_nns; simpl in *; omega_max.
Qed.

Ltac omega_bal := match goal with
| H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] =>
generalize (bal_height_1 x e H H') (bal_height_2 x e H H');
omega_max
end.

Lemma add_avl_1 :  forall m x e, avl m ->
avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.add_avl_1".
intros m x e; functional induction (add x e m); intros; inv avl; simpl in *.
intuition; try constructor; simpl; auto; try omega_max.

destruct IHt; auto.
split.
apply bal_avl; auto; omega_max.
omega_bal.

intuition; omega_max.

destruct IHt; auto.
split.
apply bal_avl; auto; omega_max.
omega_bal.
Qed.

Lemma add_avl : forall m x e, avl m -> avl (add x e m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.add_avl".
intros; generalize (add_avl_1 x e H); intuition.
Qed.
Hint Resolve add_avl.

Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) ->
avl (remove_min l x e r)#1 /\
0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.remove_min_avl_1".
intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
inv avl; simpl in *; split; auto.
avl_nns; omega_max.
inversion_clear H.
rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto.
split; simpl in *.
apply bal_avl; auto; omega_max.
omega_bal.
Qed.

Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) ->
avl (remove_min l x e r)#1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.remove_min_avl".
intros; generalize (remove_min_avl_1 H); intuition.
Qed.

Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 ->
-(2) <= height m1 - height m2 <= 2 ->
avl (merge m1 m2) /\
0<= height (merge m1 m2) - max (height m1) (height m2) <=1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.merge_avl_1".
intros m1 m2; functional induction (merge m1 m2); intros;
try factornode _x _x0 _x1 _x2 _x3 as m1.
simpl; split; auto; avl_nns; omega_max.
simpl; split; auto; avl_nns; omega_max.
generalize (remove_min_avl_1 H0).
rewrite e1; destruct 1.
split.
apply bal_avl; auto.
omega_max.
omega_bal.
Qed.

Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 ->
-(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.merge_avl".
intros; generalize (merge_avl_1 H H0 H1); intuition.
Qed.

Lemma remove_avl_1 : forall m x, avl m ->
avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.remove_avl_1".
intros m x; functional induction (remove x m); intros.
split; auto; omega_max.

inv avl.
destruct (IHt H0).
split.
apply bal_avl; auto.
omega_max.
omega_bal.

inv avl.
generalize (merge_avl_1 H0 H1 H2).
intuition omega_max.

inv avl.
destruct (IHt H1).
split.
apply bal_avl; auto.
omega_max.
omega_bal.
Qed.

Lemma remove_avl : forall m x, avl m -> avl (remove x m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.remove_avl".
intros; generalize (remove_avl_1 x H); intuition.
Qed.
Hint Resolve remove_avl.

Lemma join_avl_1 : forall l x d r, avl l -> avl r ->
avl (join l x d r) /\
0<= height (join l x d r) - max (height l) (height r) <= 1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.join_avl_1".
join_tac.

split; simpl; auto.
destruct (add_avl_1 x d H0).
avl_nns; omega_max.
set (l:=Node ll lx ld lr lh) in *.
split; auto.
destruct (add_avl_1 x d H).
simpl (height (Leaf elt)).
avl_nns; omega_max.

inversion_clear H.
assert (height (Node rl rx rd rr rh) = rh); auto.
set (r := Node rl rx rd rr rh) in *; clearbody r.
destruct (Hlr x d r H2 H0); clear Hrl Hlr.
set (j := join lr x d r) in *; clearbody j.
simpl.
assert (-(3) <= height ll - height j <= 3) by omega_max.
split.
apply bal_avl; auto.
omega_bal.

inversion_clear H0.
assert (height (Node ll lx ld lr lh) = lh); auto.
set (l := Node ll lx ld lr lh) in *; clearbody l.
destruct (Hrl H H1); clear Hrl Hlr.
set (j := join l x d rl) in *; clearbody j.
simpl.
assert (-(3) <= height j - height rr <= 3) by omega_max.
split.
apply bal_avl; auto.
omega_bal.

clear Hrl Hlr.
assert (height (Node ll lx ld lr lh) = lh); auto.
assert (height (Node rl rx rd rr rh) = rh); auto.
set (l := Node ll lx ld lr lh) in *; clearbody l.
set (r := Node rl rx rd rr rh) in *; clearbody r.
assert (-(2) <= height l - height r <= 2) by omega_max.
split.
apply create_avl; auto.
rewrite create_height; auto; omega_max.
Qed.

Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.join_avl".
intros; destruct (join_avl_1 x d H H0); auto.
Qed.
Hint Resolve join_avl.

Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.concat_avl".
intros m1 m2; functional induction (concat m1 m2); auto.
intros; apply join_avl; auto.
generalize (remove_min_avl H0); rewrite e1; simpl; auto.
Qed.
Hint Resolve concat_avl.

Lemma split_avl : forall m x, avl m ->
avl (split x m)#l /\ avl (split x m)#r.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.split_avl".
intros m x; functional induction (split x m); simpl; auto.
rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
simpl; inversion_clear 1; auto.
rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
Qed.

End Elt.
Hint Constructors avl.

Section Map.
Variable elt elt' : Type.
Variable f : elt -> elt'.

Lemma map_height : forall m, height (map f m) = height m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.map_height".
destruct m; simpl; auto.
Qed.

Lemma map_avl : forall m, avl m -> avl (map f m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.map_avl".
induction m; simpl; auto.
inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto.
Qed.

End Map.

Section Mapi.
Variable elt elt' : Type.
Variable f : key -> elt -> elt'.

Lemma mapi_height : forall m, height (mapi f m) = height m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.mapi_height".
destruct m; simpl; auto.
Qed.

Lemma mapi_avl : forall m, avl m -> avl (mapi f m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.mapi_avl".
induction m; simpl; auto.
inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto.
Qed.

End Mapi.

Section Map_option.
Variable elt elt' : Type.
Variable f : key -> elt -> option elt'.

Lemma map_option_avl : forall m, avl m -> avl (map_option f m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.map_option_avl".
induction m; simpl; auto; intros.
inv avl; destruct (f k e); auto using join_avl, concat_avl.
Qed.

End Map_option.

Section Map2_opt.
Variable elt elt' elt'' : Type.
Variable f : key -> elt -> option elt' -> option elt''.
Variable mapl : t elt -> t elt''.
Variable mapr : t elt' -> t elt''.
Hypothesis mapl_avl : forall m, avl m -> avl (mapl m).
Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m').

Notation map2_opt := (map2_opt f mapl mapr).

Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 ->
avl (map2_opt m1 m2).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.map2_opt_avl".
intros m1 m2; functional induction (map2_opt m1 m2); auto;
factornode _x0 _x1 _x2 _x3 _x4 as r2; intros;
destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl;
auto using join_avl, concat_avl.
Qed.

End Map2_opt.

Section Map2.
Variable elt elt' elt'' : Type.
Variable f : option elt -> option elt' -> option elt''.

Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.AvlProofs.map2_avl".
unfold map2; auto using map2_opt_avl, map_option_avl.
Qed.

End Map2.
End AvlProofs.

Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.

Module E := X.
Module Import AvlProofs := AvlProofs I X.
Import Raw.
Import Raw.Proofs.

Record bbst (elt:Type) :=
Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}.

Definition t := bbst.
Definition key := E.t.

Section Elt.
Variable elt elt' elt'': Type.

Implicit Types m : t elt.
Implicit Types x y : key.
Implicit Types e : elt.

Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt).
Definition is_empty m : bool := is_empty m.(this).
Definition add x e m : t elt :=
Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)).
Definition remove x m : t elt :=
Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)).
Definition mem x m : bool := mem x m.(this).
Definition find x m : option elt := find x m.(this).
Definition map f m : t elt' :=
Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
Definition mapi (f:key->elt->elt') m : t elt' :=
Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)).
Definition map2 f m (m':t elt') : t elt'' :=
Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)).
Definition elements m : list (key*elt) := elements m.(this).
Definition cardinal m := cardinal m.(this).
Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i.
Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this).

Definition MapsTo x e m : Prop := MapsTo x e m.(this).
Definition In x m : Prop := In0 x m.(this).
Definition Empty m : Prop := Empty m.(this).

Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt.

Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.MapsTo_1".   intros m; exact (@MapsTo_1 _ m.(this)). Qed.

Lemma mem_1 : forall m x, In x m -> mem x m = true.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.mem_1".
unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto.
apply m.(is_bst).
Qed.

Lemma mem_2 : forall m x, mem x m = true -> In x m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.mem_2".
unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
Qed.

Lemma empty_1 : Empty empty.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.empty_1".   exact (@empty_1 elt). Qed.

Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.is_empty_1".   intros m; exact (@is_empty_1 _ m.(this)). Qed.
Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.is_empty_2".   intros m; exact (@is_empty_2 _ m.(this)). Qed.

Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.add_1".   intros m x y e; exact (@add_1 elt _ x y e). Qed.
Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.add_2".   intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed.
Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.add_3".   intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed.

Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.remove_1".
unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto.
apply m.(is_bst).
Qed.
Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.remove_2".   intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed.
Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.remove_3".   intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed.

Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.find_1".   intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed.
Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.find_2".   intros m; exact (@find_2 elt m.(this)). Qed.

Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.fold_1".   intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed.

Lemma elements_1 : forall m x e,
MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.elements_1".
intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto.
Qed.

Lemma elements_2 : forall m x e,
InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.elements_2".
intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto.
Qed.

Lemma elements_3 : forall m, sort lt_key (elements m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.elements_3".   intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed.

Lemma elements_3w : forall m, NoDupA eq_key (elements m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.elements_3w".   intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed.

Lemma cardinal_1 : forall m, cardinal m = length (elements m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.cardinal_1".   intro m; exact (@elements_cardinal elt m.(this)). Qed.

Definition Equal m m' := forall y, find y m = find y m'.
Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
(forall k, In k m <-> In k m') /\
(forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
Definition Equivb cmp := Equiv (Cmp cmp).

Lemma Equivb_Equivb : forall cmp m m',
Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.Equivb_Equivb".
intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
generalize (H0 k); do 2 rewrite In_alt; intuition.
generalize (H0 k); do 2 rewrite In_alt; intuition.
generalize (H0 k); do 2 rewrite <- In_alt; intuition.
generalize (H0 k); do 2 rewrite <- In_alt; intuition.
Qed.

Lemma equal_1 : forall m m' cmp,
Equivb cmp m m' -> equal cmp m m' = true.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.equal_1".
unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
intros; simpl in *; rewrite equal_Equivb; auto.
Qed.

Lemma equal_2 : forall m m' cmp,
equal cmp m m' = true -> Equivb cmp m m'.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.equal_2".
unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
intros; simpl in *; rewrite <-equal_Equivb; auto.
Qed.

End Elt.

Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
MapsTo x e m -> MapsTo x (f e) (map f m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.map_1".   intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed.

Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.map_2".
intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
apply map_2; auto.
Qed.

Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
(f:key->elt->elt'), MapsTo x e m ->
exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.mapi_1".   intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed.
Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
(f:key->elt->elt'), In x (mapi f m) -> In x m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.mapi_2".
intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto.
Qed.

Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
(x:key)(f:option elt->option elt'->option elt''),
In x m \/ In x m' ->
find x (map2 f m m') = f (find x m) (find x m').
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.map2_1".
unfold find, map2, In; intros elt elt' elt'' m m' x f.
do 2 rewrite In_alt; intros; simpl; apply map2_1; auto.
apply m.(is_bst).
apply m'.(is_bst).
Qed.

Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
(x:key)(f:option elt->option elt'->option elt''),
In x (map2 f m m') -> In x m \/ In x m'.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake.map2_2".
unfold In, map2; intros elt elt' elt'' m m' x f.
do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
apply m.(is_bst).
apply m'.(is_bst).
Qed.

End IntMake.

Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
Sord with Module Data := D
with Module MapS.E := X.

Module Data := D.
Module Import MapS := IntMake(I)(X).
Import AvlProofs.
Import Raw.Proofs.
Module Import MD := OrderedTypeFacts(D).
Module LO := FMapList.Make_ord(X)(D).

Definition t := MapS.t D.t.

Definition cmp e e' :=
match D.compare e e' with EQ _ => true | _ => false end.

Definition elements (m:t) :=
LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)).

Fixpoint cardinal_e (e:Raw.enumeration D.t) :=
match e with
| Raw.End _ => 0%nat
| Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e)
end.

Lemma cons_cardinal_e : forall m e,
cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.cons_cardinal_e".
induction m; simpl; intros; auto.
rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith.
Qed.

Definition cardinal_e_2 ee :=
(cardinal_e (fst ee) + cardinal_e (snd ee))%nat.

Local Unset Keyed Unification.

Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t)
{ measure cardinal_e_2 ee } : comparison :=
match ee with
| (Raw.End _, Raw.End _) => Eq
| (Raw.End _, Raw.More _ _ _ _) => Lt
| (Raw.More _ _ _ _, Raw.End _) => Gt
| (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) =>
match X.compare x1 x2 with
| EQ _ => match D.compare d1 d2 with
| EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2)
| LT _ => Lt
| GT _ => Gt
end
| LT _ => Lt
| GT _ => Gt
end
end.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.cardinal_e_2".
intros; unfold cardinal_e_2; simpl;
abstract (do 2 rewrite cons_cardinal_e; romega with * ).
Defined.

Definition Cmp c :=
match c with
| Eq => LO.eq_list
| Lt => LO.lt_list
| Gt => (fun l1 l2 => LO.lt_list l2 l1)
end.

Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2,
X.eq x1 x2 -> D.eq d1 d2 ->
Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.cons_Cmp".
destruct c; simpl; intros; MX.elim_comp; auto.
Qed.
Hint Resolve cons_Cmp.

Lemma compare_aux_Cmp : forall e,
Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.compare_aux_Cmp".
intros e; functional induction (compare_aux e); simpl in *;
auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto.
rewrite 2 cons_1 in IHc; auto.
Qed.

Lemma compare_Cmp : forall m1 m2,
Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _)))
(Raw.elements m1) (Raw.elements m2).
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.compare_Cmp".
intros.
assert (H1:=cons_1 m1 (Raw.End _)).
assert (H2:=cons_1 m2 (Raw.End _)).
simpl in *; rewrite app_nil_r in *; rewrite <-H1,<-H2.
apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _),
Raw.cons m2 (Raw.End _))).
Qed.

Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2).
Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2).

Definition compare (s s':t) : Compare lt eq s s'.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.compare".
destruct s as (s,b,a), s' as (s',b',a').
generalize (compare_Cmp s s').
destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto.
Defined.

Definition selements (m1 : t) :=
LO.MapS.Build_slist (elements_sort m1.(is_bst)).

Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2).

Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.eq_seq".
unfold eq, seq, selements, elements, LO.eq; intuition.
Qed.

Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.lt_slt".
unfold lt, slt, selements, elements, LO.lt; intuition.
Qed.

Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.eq_1".
intros m m'.
rewrite eq_seq; unfold seq.
rewrite Equivb_Equivb.
rewrite Equivb_elements.
auto using LO.eq_1.
Qed.

Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.eq_2".
intros m m'.
rewrite eq_seq; unfold seq.
rewrite Equivb_Equivb.
rewrite Equivb_elements.
intros.
generalize (LO.eq_2 H).
auto.
Qed.

Lemma eq_refl : forall m : t, eq m m.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.eq_refl".
intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
Qed.

Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.eq_sym".
intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto.
Qed.

Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.eq_trans".
intros m1 m2 M3; rewrite 3 eq_seq; unfold seq.
intros; eapply LO.eq_trans; eauto.
Qed.

Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.lt_trans".
intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;
intros; eapply LO.lt_trans; eauto.
Qed.

Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
Proof. hammer_hook "FMapFullAVL" "FMapFullAVL.IntMake_ord.lt_not_eq".
intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq;
intros; apply LO.lt_not_eq; auto.
Qed.

End IntMake_ord.

Module Make (X: OrderedType) <: S with Module E := X
:=IntMake(Z_as_Int)(X).

Module Make_ord (X: OrderedType)(D: OrderedType)
<: Sord with Module Data := D
with Module MapS.E := X
:=IntMake_ord(Z_as_Int)(X)(D).


(*** Bounded ℤ-Like Types *)
(** This file specifies a ℤ-like type of bounded integers, with
    operations for Montgomery Reduction and Barrett Reduction. *)
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Notations.

Local Open Scope Z_scope.

Class ZLikeOps (small_bound smaller_bound : Z) (modulus : Z) :=
  {
    LargeT : Type;
    SmallT : Type;
    modulus_digits : SmallT;
    decode_large : LargeT -> Z;
    decode_small : SmallT -> Z;
    Mod_SmallBound : LargeT -> SmallT;
    DivBy_SmallBound : LargeT -> SmallT;
    DivBy_SmallerBound : LargeT -> SmallT;
    Mul : SmallT -> SmallT -> LargeT;
    CarryAdd : LargeT -> LargeT -> bool * LargeT;
    CarrySubSmall : SmallT -> SmallT -> bool * SmallT;
    ConditionalSubtract : bool -> SmallT -> SmallT;
    ConditionalSubtractModulus : SmallT -> SmallT
  }.

Delimit Scope small_zlike_scope with small_zlike.
Delimit Scope large_zlike_scope with large_zlike.
Local Open Scope small_zlike_scope.
Local Open Scope large_zlike_scope.
Local Open Scope Z_scope.
Bind Scope small_zlike_scope with SmallT.
Bind Scope large_zlike_scope with LargeT.
Arguments decode_large (_ _ _)%Z _ _%large_zlike.
Arguments decode_small (_ _ _)%Z _ _%small_zlike.
Arguments Mod_SmallBound (_ _ _)%Z _ _%large_zlike.
Arguments DivBy_SmallBound (_ _ _)%Z _ _%large_zlike.
Arguments DivBy_SmallerBound (_ _ _)%Z _ _%large_zlike.
Arguments Mul (_ _ _)%Z _ (_ _)%small_zlike.
Arguments CarryAdd (_ _ _)%Z _ (_ _)%large_zlike.
Arguments CarrySubSmall (_ _ _)%Z _ (_ _)%large_zlike.
Arguments ConditionalSubtract (_ _ _)%Z _ _%bool _%small_zlike.
Arguments ConditionalSubtractModulus (_ _ _)%Z _ _%small_zlike.

Infix "*" := Mul : large_zlike_scope.
Notation "x + y" := (snd (CarryAdd x y)) : large_zlike_scope.

Class ZLikeProperties {small_bound smaller_bound modulus : Z} (Zops : ZLikeOps small_bound smaller_bound modulus) :=
  {
    large_valid : LargeT -> Prop;
    medium_valid : LargeT -> Prop;
    small_valid : SmallT -> Prop;
    decode_large_valid : forall v, large_valid v -> 0 <= decode_large v < small_bound * small_bound;
    decode_medium_valid : forall v, medium_valid v -> 0 <= decode_large v < small_bound * smaller_bound;
    medium_to_large_valid : forall v, medium_valid v -> large_valid v;
    decode_small_valid : forall v, small_valid v -> 0 <= decode_small v < small_bound;
    modulus_digits_valid : small_valid modulus_digits;
    modulus_digits_correct : decode_small modulus_digits = modulus;
    Mod_SmallBound_valid : forall v, large_valid v -> small_valid (Mod_SmallBound v);
    Mod_SmallBound_correct
    : forall v, large_valid v -> decode_small (Mod_SmallBound v) = decode_large v mod small_bound;
    DivBy_SmallBound_valid : forall v, large_valid v -> small_valid (DivBy_SmallBound v);
    DivBy_SmallBound_correct
    : forall v, large_valid v -> decode_small (DivBy_SmallBound v) = decode_large v / small_bound;
    DivBy_SmallerBound_valid : forall v, medium_valid v -> small_valid (DivBy_SmallerBound v);
    DivBy_SmallerBound_correct
    : forall v, medium_valid v -> decode_small (DivBy_SmallerBound v) = decode_large v / smaller_bound;
    Mul_valid : forall x y, small_valid x -> small_valid y -> large_valid (Mul x y);
    Mul_correct
    : forall x y, small_valid x -> small_valid y -> decode_large (Mul x y) = decode_small x * decode_small y;
    CarryAdd_valid : forall x y, large_valid x -> large_valid y -> large_valid (snd (CarryAdd x y));
    CarryAdd_correct_fst
    : forall x y, large_valid x -> large_valid y -> fst (CarryAdd x y) = (small_bound * small_bound <=? decode_large x + decode_large y);
    CarryAdd_correct_snd
    : forall x y, large_valid x -> large_valid y -> decode_large (snd (CarryAdd x y)) = (decode_large x + decode_large y) mod (small_bound * small_bound);
    CarrySubSmall_valid : forall x y, small_valid x -> small_valid y -> small_valid (snd (CarrySubSmall x y));
    CarrySubSmall_correct_fst
    : forall x y, small_valid x -> small_valid y -> fst (CarrySubSmall x y) = (decode_small x - decode_small y <? 0);
    CarrySubSmall_correct_snd
    : forall x y, small_valid x -> small_valid y -> decode_small (snd (CarrySubSmall x y)) = (decode_small x - decode_small y) mod small_bound;
    ConditionalSubtract_valid : forall b x, small_valid x  -> small_valid (ConditionalSubtract b x);
    ConditionalSubtract_correct
    : forall b x, small_valid x -> decode_small (ConditionalSubtract b x)
                                 = if b then (decode_small x - decode_small modulus_digits) mod small_bound else decode_small x;
    ConditionalSubtractModulus_valid : forall x, small_valid x -> small_valid (ConditionalSubtractModulus x);
    ConditionalSubtractModulus_correct
    : forall x, small_valid x -> decode_small (ConditionalSubtractModulus x)
                                 = if (decode_small x <? decode_small modulus_digits) then decode_small x else decode_small x - decode_small modulus_digits
  }.

Arguments ZLikeProperties [small_bound smaller_bound modulus] Zops, small_bound smaller_bound modulus {Zops}.

Existing Class large_valid.
Existing Class medium_valid.
Existing Class small_valid.
Existing Instances Mod_SmallBound_valid DivBy_SmallerBound_valid DivBy_SmallBound_valid Mul_valid CarryAdd_valid CarrySubSmall_valid ConditionalSubtract_valid ConditionalSubtractModulus_valid modulus_digits_valid medium_to_large_valid.

Lemma ConditionalSubtractModulus_correct'
      {small_bound smaller_bound modulus : Z} {Zops : ZLikeOps small_bound smaller_bound modulus}
      {Zprops : ZLikeProperties Zops}
  : forall x, small_valid x -> decode_small (ConditionalSubtractModulus x)
                               = if (decode_small modulus_digits <=? decode_small x) then decode_small x - decode_small modulus_digits else decode_small x.
Proof.
  intros; rewrite ConditionalSubtractModulus_correct by assumption.
  break_match; Z.ltb_to_lt; omega.
Qed.

Lemma modulus_nonneg {small_bound smaller_bound modulus} (Zops : ZLikeOps small_bound smaller_bound modulus) {_ : ZLikeProperties Zops} : 0 <= modulus.
Proof.
  pose proof (decode_small_valid _ modulus_digits_valid) as H.
  rewrite modulus_digits_correct in H.
  omega.
Qed.

Create HintDb push_zlike_decode discriminated.
Create HintDb pull_zlike_decode discriminated.
Hint Rewrite @Mod_SmallBound_correct @DivBy_SmallBound_correct @DivBy_SmallerBound_correct @Mul_correct @CarryAdd_correct_fst @CarryAdd_correct_snd @CarrySubSmall_correct_fst @CarrySubSmall_correct_snd  @ConditionalSubtract_correct @ConditionalSubtractModulus_correct @ConditionalSubtractModulus_correct' @modulus_digits_correct using solve [ typeclasses eauto ] : push_zlike_decode.
Hint Rewrite <- @Mod_SmallBound_correct @DivBy_SmallBound_correct @DivBy_SmallerBound_correct @Mul_correct @CarryAdd_correct_fst @CarryAdd_correct_snd @CarrySubSmall_correct_fst @CarrySubSmall_correct_snd @ConditionalSubtract_correct @ConditionalSubtractModulus_correct @modulus_digits_correct using solve [ typeclasses eauto ] : pull_zlike_decode.

Ltac get_modulus :=
  match goal with
  | [ _ : ZLikeOps _ _ ?modulus |- _ ] => modulus
  end.

Ltac push_zlike_decode :=
  let modulus := get_modulus in
  repeat first [ erewrite !Mod_SmallBound_correct by typeclasses eauto
               | erewrite !DivBy_SmallBound_correct by typeclasses eauto
               | erewrite !DivBy_SmallerBound_correct by typeclasses eauto
               | erewrite !Mul_correct by typeclasses eauto
               | erewrite !CarryAdd_correct_fst by typeclasses eauto
               | erewrite !CarryAdd_correct_snd by typeclasses eauto
               | erewrite !CarrySubSmall_correct_fst by typeclasses eauto
               | erewrite !CarrySubSmall_correct_snd by typeclasses eauto
               | erewrite !ConditionalSubtract_correct by typeclasses eauto
               | erewrite !ConditionalSubtractModulus_correct by typeclasses eauto
               | erewrite !ConditionalSubtractModulus_correct' by typeclasses eauto
               | erewrite !(@modulus_digits_correct _ modulus _ _) by typeclasses eauto ].
Ltac pull_zlike_decode :=
  let modulus := get_modulus in
  repeat first [ match goal with
                 | [ |- context G[modulus] ]
                   => let G' := context G[decode_small modulus_digits] in
                      cut G'; [ rewrite !modulus_digits_correct by typeclasses eauto; exact (fun x => x) | ]
                 end
               | erewrite <- !Mod_SmallBound_correct by typeclasses eauto
               | erewrite <- !DivBy_SmallBound_correct by typeclasses eauto
               | erewrite <- !DivBy_SmallerBound_correct by typeclasses eauto
               | erewrite <- !Mul_correct by typeclasses eauto
               | erewrite <- !CarryAdd_correct_fst by typeclasses eauto
               | erewrite <- !CarryAdd_correct_snd by typeclasses eauto
               | erewrite <- !ConditionalSubtract_correct by typeclasses eauto
               | erewrite <- !CarrySubSmall_correct_fst by typeclasses eauto
               | erewrite <- !CarrySubSmall_correct_snd by typeclasses eauto
               | erewrite <- !ConditionalSubtractModulus_correct by typeclasses eauto
               | erewrite <- !ConditionalSubtractModulus_correct' by typeclasses eauto
               | erewrite <- !(@modulus_digits_correct _ modulus _ _) by typeclasses eauto ].


Require Import List.
Import ListNotations.
Require Import PeanoNat.
Require Import Coq.omega.Omega.

From Verbatim Require Import ltac.
From Verbatim Require Import regex.
From Verbatim Require Import matcher.
From Verbatim Require Import Table.

Module DFAFn (TabT : Table.T).

  Import TabT.
  Import TabT.Defs.

  Module Export CoreDefs.

    Fixpoint char_set (e : regex) : list Sigma :=
      SigmaEnum.
    (*
      match e with
      | EmptySet | EmptyStr => []
      | Char a => [a]
      | Union e1 e2 | App e1 e2 => nodup Sigma_dec ((char_set e1) ++ (char_set e2))
      | Star e1 => char_set e1
      end.
     *)

    Fixpoint regex_depth (e : regex) : nat :=
      match e with
      | EmptySet
      | EmptyStr
      | Char _ => 0
      | App e1 e2
      | Union e1 e2 =>
        let
          d1 := regex_depth e1 in
        let
          d2 := regex_depth e2 in
        if leb d2 d1 then d1 + 1 else d2 + 1
      | Star e0 => (regex_depth e0) + 1
      end.

    Fixpoint regex_length (e : regex) : nat :=
      match e with
      | EmptySet
      | EmptyStr
      | Char _ => 1
      | App e1 e2
      | Union e1 e2 => 1 + (regex_length e1) + (regex_length e2)
      | Star e1 => 1 + (regex_length e1)
      end.

    (* Computes positive with value 2^(n+1) - 1, which is larger than or equal to 2^n + 1 *)
    Fixpoint Brzozowski_bound' (n : nat) : positive :=
      match n with
      | 0 => xH
      | S m => xI (Brzozowski_bound' m)
      end.

    Definition Brzozowski_bound (e : regex) : positive :=
      Brzozowski_bound' (regex_length e).

    Definition fin_states (es : reFS.t) :=
      reFS.filter nullable es.
      (*
      match es with
      | [] => []
      | h :: t =>
        let t' := fin_states t in
        if nullable h
        then h :: t'
        else t'
      end.
      *)

    Definition DFA : Type := regex * Table * reFS.t.
    Definition defDFA : DFA := (EmptySet, emptyTable, reFS.empty).

    Definition DFAtransition (a : Sigma) (dfa : DFA) : DFA :=
      match dfa with
        (e, T, fins)
        => match get_Table T e a with
          | Some e' => (e', T, fins)
          | None => (derivative a e, T, fins)
          end
      end.

    Fixpoint DFAtransition_list (bs : list Sigma) (dfa : DFA) : DFA :=
      match bs with
      | [] => dfa
      | c :: cs => DFAtransition_list cs (DFAtransition c dfa)
      end.

    Definition DFAaccepting (dfa : DFA) : bool :=
      match dfa with
        (e, T, fins)
        => if reFS.mem e (get_states T)
          then reFS.mem e fins else nullable e
      end.

    Fixpoint DFAaccepts (z : String) (dfa : DFA) : bool :=
      match z with
      | [] => DFAaccepting dfa
      | x :: xs => DFAaccepts xs (DFAtransition x dfa)
      end.

    Definition regex2dfa (e : regex) : DFA :=
      let
        T := fill_Table_all_bin emptyTable (canon e) (char_set e) (Brzozowski_bound e)
      in
      let
        es := get_states T
      in
      (canon e, T, fin_states es).

    Definition dfa2regex (dfa : DFA) : regex :=
      match dfa with (e, _, _) => e end.

  End CoreDefs.

  Module Export Correct.

    Module Import Mat := MatcherFn TabT.R.

    Lemma DFAtransition_Delta : forall e T fs e' T' fs' a,
        DFAtransition a (e, T, fs) = (e', T', fs')
        -> T = T' /\ fs = fs'.
    Proof.
      intros. sis. dm; repeat inj_all; auto.
    Qed.

    Lemma compat_bool_nullable :
      SetoidList.compat_bool eq nullable.
    Proof.
      unfold SetoidList.compat_bool. unfold Morphisms.Proper. unfold Morphisms.respectful.
      intros. rewrite H. auto.
    Qed.

    Theorem DFAaccepting_nullable : forall T e,
        DFAaccepting (e, T, fin_states (get_states T)) = nullable e.
    Proof.
      intros. unfold DFAaccepting. dm.
      unfold fin_states. destruct (reFS.mem e (reFS.filter nullable (get_states T))) eqn:E1.
      - rewrite reFSF.filter_b in E1.
        + symmetry in E1. apply Bool.andb_true_eq in E1. destruct E1. auto.
        + apply compat_bool_nullable.
      - rewrite reFSF.filter_b in E1.
        + inv E1. rewrite E. auto.
        + apply compat_bool_nullable.
    Qed.

    Theorem transition_Table_correct : forall e e' T es,
        regex2dfa e = (e', T, es)
        -> derived T /\ (es = fin_states (get_states T)) /\ canon e = e'.
    Proof.
      intros.
      unfold regex2dfa in *. injection H; intros.
      repeat split.
      - apply derived_get_some in H3.
        + apply H3.
        + eapply derived_closure_all_bin; eauto. apply emptyTable_derived.
      - apply derived_get_some in H3.
        + apply H3.
        + eapply derived_closure_all_bin; eauto. apply emptyTable_derived.
      - inv H. auto.
      - auto.
    Qed.

    Theorem transition_deriv : forall es es' e e' T T' a,
        derived T
        -> DFAtransition a (e, T, es) = (e', T', es')
        -> re_equiv (derivative a e) e'
          /\ T = T' /\ es = es'.
    Proof.
      intros. unfold derived in *. unfold DFAtransition in *. dm.
      - injection H0; intros; subst. clear H0.
        apply H in E. split; [|split]; auto.
        unfold re_equiv in *. intros. symmetry. auto.
      - injection H0; intros; subst. inv H0.
        split; [| split]; auto. unfold re_equiv. reflexivity.
    Qed.

    Lemma accepts_cons : forall z a dfa,
        DFAaccepts (a :: z) dfa
        = DFAaccepts z (DFAtransition a dfa).
    Proof.
      auto.
    Qed.

    Lemma unfold_transition_list : forall bs a dfa,
        DFAtransition_list bs (DFAtransition a dfa)
        = DFAtransition_list (a :: bs) dfa.
    Proof.
      auto.
    Qed.

    Lemma accepts_str_lst : forall z dfa,
        DFAaccepts z dfa = DFAaccepting (DFAtransition_list z dfa).
    Proof.
      induction z; intros; auto.
      rewrite accepts_cons. rewrite <- unfold_transition_list.
      apply IHz.
    Qed.

    Theorem accepts_deriv : forall z T e a,
        (forall (T : Table) (e : regex),
            derived T -> DFAaccepts z (e, T, fin_states (get_states T)) = exp_matchb z e)
        -> derived T
        -> DFAaccepts (a :: z) (e, T, fin_states (get_states T))
          = DFAaccepts z (derivative a e, T, fin_states (get_states T)).
    Proof.
      intros. rewrite accepts_cons. do 2 rewrite accepts_str_lst.
      unfold DFAtransition. repeat dm.
      do 2 rewrite <- accepts_str_lst.
      rewrite H; auto. rewrite H; auto.
      apply derived_get_some in E; auto.
      unfold re_equiv in E.
      destruct (exp_matchb z r) eqn:E1.
      - symmetry in E1. rewrite match_iff_matchb in *. apply E. auto.
      - symmetry. rewrite false_not_true in *. intros C. destruct E1.
        symmetry. symmetry in C. rewrite match_iff_matchb in *. apply E. auto.
    Qed.

    Theorem accepts_matchb : forall z T e,
        derived T
        -> DFAaccepts z (e, T, fin_states (get_states T))
          = exp_matchb z e.
    Proof.
      induction z; intros.
      - rewrite DFAaccepting_nullable. destruct (nullable e) eqn:E.
        + apply nullable_bridge' in E. apply match_iff_matchb. auto.
        + symmetry. rewrite <- Bool.not_true_iff_false in *. intros C. destruct E.
          apply nullable_bridge'. symmetry in C. apply match_iff_matchb in C. auto.
      - rewrite accepts_deriv; auto.
        rewrite der_matchb'; auto.
    Qed.

    Theorem accepts_match : forall z T e,
        derived T ->
        (DFAaccepts z (e, T, fin_states (get_states T)) = true <-> exp_match z e).
    Proof.
      intros. rewrite accepts_matchb; auto.
      rewrite <- match_iff_matchb. split; symmetry; auto.
    Qed.

    Theorem r2d_accepts_match : forall z e,
        DFAaccepts z (regex2dfa e) = true <-> exp_match z e.
    Proof.
      intros. destruct regex2dfa eqn:H0. destruct p. apply transition_Table_correct in H0.
      do 2 destruct H0. subst.
      rewrite accepts_match; auto.
      apply canon_equiv.
    Qed.

    Lemma DFAaccepts_dt : forall bs a e,
        DFAaccepts bs (regex2dfa (derivative a e))
        = DFAaccepts bs (DFAtransition a (regex2dfa e)).
    Proof.
      intros. rewrite <- accepts_cons.
      destruct (DFAaccepts bs (regex2dfa (derivative a e))) eqn:E.
      - symmetry. rewrite r2d_accepts_match in *. apply der_match. auto.
      - symmetry. rewrite false_not_true in *. intros C. destruct E.
        rewrite r2d_accepts_match in *. apply der_match. auto.
    Qed.

    Lemma exact_table_moot : forall bs e T,
        derived T
        ->
        DFAaccepts bs (e, T, fin_states (get_states T)) =
        DFAaccepts bs (regex2dfa e).
    Proof.
      induction bs; intros; auto.
      - unfold regex2dfa. repeat rewrite DFAaccepting_nullable.
        clear. destruct (nullable e) eqn:E.
          + symmetry in E. rewrite nullable_bridge in *.
            assert(L := canon_equiv e []). rewrite L. auto.
          + symmetry. rewrite false_not_true in *. intros C. destruct E.
            symmetry. symmetry in C. rewrite nullable_bridge in *.
            assert(L := canon_equiv e []). rewrite L in *. auto.
      - rewrite accepts_deriv; auto. 2: { intros. apply accepts_matchb. auto. }
        rewrite IHbs; auto. rewrite accepts_cons.
        apply DFAaccepts_dt.
    Qed.

    Theorem DFAaccepting_dt_list : forall bs e,
        DFAaccepting (DFAtransition_list bs (regex2dfa e))
        = DFAaccepting (regex2dfa (derivative_list bs e)).
    Proof.
      intros. rewrite <- accepts_str_lst.
      generalize dependent e.
      induction bs; intros; auto.
      - destruct (regex2dfa e) eqn:E. destruct p.
        apply transition_Table_correct in E. destruct E. destruct H0. subst.
        subst.
        rewrite accepts_deriv; auto. 2: { intros. apply accepts_matchb. auto. }
        assert(
          DFAaccepts bs (derivative a (canon e), t0, fin_states (get_states t0)) =
          DFAaccepts bs (regex2dfa (derivative a (canon e)))).
        { apply exact_table_moot. auto. }
        rewrite H0. clear H0 H t0.
        rewrite IHbs.
        assert(
            DFAaccepting (regex2dfa (derivative_list bs (derivative a (canon e)))) =
            DFAaccepting (regex2dfa (derivative_list (a :: bs) (canon e)))).
        { auto. }
        rewrite H. clear H. unfold regex2dfa. repeat rewrite DFAaccepting_nullable.
        clear. destruct (nullable (canon (derivative_list (a :: bs) (canon e)))) eqn:E.
        + symmetry in E. rewrite nullable_bridge in *.
          assert(L := canon_equiv (derivative_list bs (derivative a (canon e))) []).
          rewrite L in *. clear L.
          assert(L := canon_equiv (derivative_list bs (derivative a e)) []).
          apply L. clear L.
          rewrite <- derivative_list_cons in *. rewrite derivative_list_str in *.
          apply canon_equiv. auto.
        + symmetry. rewrite false_not_true in *. intros C. destruct E. rename C into E.
          symmetry. symmetry in E.
          rewrite nullable_bridge in *.
          assert(L := canon_equiv (derivative_list bs (derivative a (canon e))) []).
          rewrite L in *. clear L.
          assert(L := canon_equiv (derivative_list bs (derivative a e)) []).
          rewrite L in *. clear L.
          rewrite <- derivative_list_cons in *. rewrite derivative_list_str in *.
          apply canon_equiv. auto.
    Qed.

  End Correct.

End DFAFn.