(* バイナリデータのタプル表現と集合表現 *)
(* @suharahiromichi *)

(* 参考：From Sets to Bits in Coq *)
(* coq-bits パッケージ、coq-bitset パッケージ *)

From mathcomp Require Import all_ssreflect.

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

Definition BITS n := n.-tuple bool.         (* タプル表現 *)
Definition FSET n := {set 'I_n}.            (* 集合表現 *)

Definition bits_data : BITS 4 := [tuple true; false; true; false].
Definition fset_data : FSET 4 := [set inord 0; inord 2].

(*
  coq-bitset/blob/master/src/repr_op.v などを参考に、
  タプル表現と集合表現の一致を証明する。
 *)

Section Repr.

  Definition repr' {n} (bs : BITS n) (fs : FSET n) :=
    forall (i : 'I_n), tnth bs i = (i \in fs).

  Definition repr {n} (bs : BITS n) (fs : FSET n) :=
    [set i : 'I_n | tnth bs i] = fs.

  Lemma reprs {n} (bs : BITS n) (fs : FSET n) : repr bs fs <-> repr' bs fs.
  Proof.
    rewrite /repr /repr'.
    split.
    - move=> <- i.
      by rewrite inE.
    - move=> H.
      apply/setP=> i'.
      by rewrite inE -H.
  Qed.

  (* ******** *)
  (* 変換関数 *)
  (* ******** *)

  (* タプル表現を集合表現に変換する関数。 *)
  Definition bs2fs {n} (bs : BITS n) : FSET n := [set x : 'I_n | tnth bs x].

  (* この変換関数を使った場合に、タプル表現の要素と集合表現に要素が一致する補題。 *)
  Lemma bs_eq_fs {n} (bs : BITS n) (fs : FSET n) : repr bs (bs2fs bs).
  Proof.
    apply/setP => i.
    now rewrite inE.
  Qed.

  (* ***** *)
  (* 長さ0 *)
  (* ***** *)

  Check [tuple] : BITS 0.
  Check set0 : FSET 0.
  Lemma zero_repr : repr [tuple] set0.
  Proof.
    apply/setP => i.
    by elim: i.
  Qed.

  (* *************** *)
  (* 全 true / false *)
  (* *************** *)

  (* 全 true *)
  Check (nseq_tuple 4 true) : BITS 4.
  Check [set: 'I_4] : FSET 4.

  Definition all_true {n} := nseq_tuple n true.
  Lemma all_true_repr {n} : repr all_true [set: 'I_n].
  Proof.
    apply/setP => i.
    rewrite !inE.
    Check (tnth_nth false (nseq_tuple n true) i) :
      tnth (nseq_tuple n true) i = nth false (nseq_tuple n true) i.
    rewrite (tnth_nth false).        (* nth の default は指定する。 *)

    Check nth_nseq.
    Check nth_nseq (nseq_tuple n true).
    rewrite nth_nseq.

    (* Goal : (if i < n then true else false) == true *)
    Check ltn_ord i.
    rewrite ltn_ord.
    done.
  Qed.

  (* 全 false *)
  Definition all_false {n} := nseq_tuple n false.
  Lemma all_false_repr {n} : repr (@all_false n) set0.
  Proof.
    apply/setP => i.
    by rewrite !inE (tnth_nth false) nth_nseq ltn_ord.
  Qed.

  (* **** *)
  (* inv  *)
  (* **** *)
  Check fun x => negb x.
  Definition binv {n} (s : BITS n) :=
    map_tuple (fun x => negb x) s.
  Lemma binvP_repr {n} (bs : BITS n) (fs : FSET n) :
    repr bs fs -> repr (binv bs) (~: fs).
  Proof.
    move/setP => H1.
    apply/setP => i.
    move: (H1 i) => {H1} H1.
    rewrite !inE !(tnth_nth false) in H1.
    rewrite !inE !(tnth_nth false) /binv.
    rewrite (@nth_map bool false bool false).
    - by rewrite H1.                        (* rewrite in_setC *)
    - by rewrite size_tuple.
  Qed.

  (* ****** *)
  (* and/or *)
  (* ****** *)
  Check fun x => andb x.1 x.2.
  Definition band {n} (s t : BITS n) :=
    map_tuple (fun x => andb x.1 x.2) (zip_tuple s t).
  Lemma bandP_repr {n} (bs bt : BITS n) (fs ft : FSET n) :
    repr bs fs -> repr bt ft -> repr (band bs bt) (fs :&: ft).
  Proof.
    move/setP => H1.
    move/setP => H2.
    apply/setP => i.

    move: (H1 i) => {H1} H1.
    move: (H2 i) => {H2} H2.

    rewrite inE (tnth_nth false) in H1.
    rewrite inE (tnth_nth false) in H2.
    rewrite inE (tnth_nth false) /band.     (* and *)
    rewrite (@nth_map (bool * bool) (false, false) bool false).

    - rewrite !nth_zip.
      + by rewrite in_setI -H1 -H2.         (* setI *)
      + by rewrite !size_tuple.
    - by rewrite size_tuple ltn_ord.
  Qed.

  Definition bor {n} (s t : BITS n) :=
    map_tuple (fun x => orb x.1 x.2) (zip_tuple s t).
  Lemma borP_repr {n} (bs bt : BITS n) (fs ft : FSET n) :
    repr bs fs -> repr bt ft -> repr (bor bs bt) (fs :|: ft).
  Proof.
    move/setP => H1.
    move/setP => H2.
    apply/setP => i.

    move: (H1 i) => {H1} H1.
    move: (H2 i) => {H2} H2.

    rewrite inE (tnth_nth false) in H1.
    rewrite inE (tnth_nth false) in H2.
    rewrite inE (tnth_nth false) /bor.      (* or *)
    rewrite (@nth_map (bool * bool) (false, false) bool false).

    - rewrite !nth_zip.
      + by rewrite in_setU -H1 -H2.         (* setU *)
      + by rewrite !size_tuple.
    - by rewrite size_tuple ltn_ord.
  Qed.

  (* ****** *)
  (* シフト *)
  (* ****** *)

  Check prednK : forall n : nat, 0 < n -> n.-1.+1 = n.
  (* H : 0 < n |- prednK H : n.=1.+1 = n *)

  (* 左シフト *)

  Compute rcons (behead [:: 0;1;2;3]) 9.    (* [:: 1;2;3;9] *)
  Compute behead (rcons [:: 0;1;2;3] 9).    (* [:: 1;2;3;9] *)

  (* tuple型の関数を組み合わせる場合  *)
  Definition shl1' {n} (bs : BITS n) : BITS n :=
    behead_tuple (rcons_tuple bs false).

  (* seq型の関数をtupleに適用できるようにする。 *)
  Lemma shl1P {n} (t : BITS n) : size (behead (rcons t false)) == n.
  Proof.
    by rewrite size_behead size_rcons -pred_Sn size_tuple.
  Qed.
  Canonical shl1 {n} t := Tuple (@shl1P n t).
  Check shl1 : BITS 4 -> BITS 4.

  (* 1 が 0 に移ること。 *)
  (* n.+1 が n に移ること。 *)
  (* coq-bitset/src/ops/shift.v 参照 *)

  Definition fset_shl1 {n} (fs : FSET n) (H : n.-1.+1 = n) : FSET n :=
    [set i : 'I_n | i < n.-1 & cast_ord H (@inord n.-1 i.+1) \in fs].
  (* シフトした後の、0〜n.-2 は、シフト前の 1〜n.-1 である。 *)
  (* シフトで追加される、シフト後の最右(bitn.-1)の値は、とりあえず不問とする。 *)

  Lemma shl1_repr n (bs : BITS n) (fs : FSET n) :
    forall (H : 0 < n), repr bs fs ->
                        repr (shl1 bs) (fset_shl1 fs (prednK H)).
  Proof.
    move=> H.
    move/setP => H1.
    apply/setP => i.
    move: (H1 i) => {H1} H1'.
    rewrite inE (tnth_nth false) in H1'.
    rewrite inE (tnth_nth false) /shl1.
    case H2 : (i < n.-1).
    - admit.
    - admit.
  Admitted.

  (* 右シフト *)

  Compute belast 9 [:: 0;1;2;3].            (* [:: 9;0;1;2] *)
  Definition shr1 {n} : BITS n -> BITS n := belast_tuple false.
  Check shr1 : BITS 4 -> BITS 4.

(*
  Compute belast 9 [:: 0;1;2;3].            (* [:: 9;0;1;2] *)
  Compute 9 :: belast 0 [:: 1;2;3].
  Lemma test (x0 x : bool) s (i : nat) :
    nth false (belast x0 (x :: s)) i == nth false (x0 :: belast x s) i.
  Proof.
    done.
  Qed.
*)
  (* おまけ *)
  Lemma nth_cat (s1 s2 : seq bool) (x0 : bool) (n : nat) :
    n < size s1 -> nth x0 (s1 ++ s2) n = nth x0 s1 n.
  Proof. by elim: s1 n => [|x s1 IHs] []. Qed.

  Lemma nth_cat' (s1 s2 : seq bool) (x0 : bool) (n : nat) :
    n >= size s1 -> nth x0 (s1 ++ s2) n = nth x0 s2 (n - size s1).
  Proof. by elim: s1 n => [|x s1 IHs] []. Qed.

  Lemma nth_cons (T : Type) (x0 : T) (a : T) (s : seq T) (i : nat) :
    0 < i -> nth x0 (a :: s) i = nth x0 s i.-1.
  Proof.
    by elim: s i => [|x s IHs]; case.
  Qed.

  Lemma nth_belast_nil (x0 : bool) (i : nat) :
    0 < i -> nth false (belast x0 [::]) i = nth false [::] i.-1.
  Proof.
    move=> H.
    by rewrite /belast !nth_nil.
  Qed.

  Lemma nth_belast_cons (x0 x : bool) s (i : nat) :
    0 < i -> nth false (belast x0 (x :: s)) i = nth false (belast x s) i.-1.
  Proof.
    by elim: s i => [| a s IHs]; case.
  Qed.

  (* i : 'I_n の半端ものの証明に使いそうである。 *)
  Lemma not_0lt__0 (i : nat) : (0 < i) = false -> i = 0.
  Proof.
    move=> H.
    rewrite lt0n in H.
    by move/eqP in H.
  Qed.

  Lemma p0lt__not_1lt__1 i : 0 < i -> 0 < i.-1 = false -> i = 1.
    elim: i.
    + done.
    + move=> i IHi H1 H2.
      Check @not_0lt__0 i.+1.-1.
      apply (@not_0lt__0 i.+1.-1) in H2.
      rewrite PeanoNat.Nat.pred_succ in H2.
      by rewrite H2.
  Qed.

  (* 右シフトで追加される最左(bit0)は、falseである。 *)
  Lemma nth_belast2 (s : seq bool) (i : nat) :
    i = 0 -> nth false (belast false s) i = false.
  Proof.
    move=> ->.
      by elim: s.
  Qed.

  (* これは正しくない。 XXXXXX *)
  Lemma nth_belast2' (x0 : bool) (s : seq bool) (i : nat) :
    i = 0 -> nth false (belast x0 s) i = x0.
  Proof.
  Admitted.

  (* これは使えない。使っていない。 *)
  Lemma nth_belast2'' (x0 : bool) (s : seq bool) (i : nat) :
    i = 0 -> nth x0 (belast x0 s) i = x0.
  Proof.
    move=> ->.
      by elim: s.
  Qed.

  Lemma nth_belast1 (x0 : bool) (s : seq bool) (i : nat) :
    0 < i -> nth false (belast x0 s) i = nth false s i.-1.
  Proof.
    elim: s i x0.
    - move=> i x0 H.
      by apply: nth_belast_nil.

    - move=> a s IHs i x0 H.
      case Hi : (0 < i.-1).
      + Check nth_belast_cons false false s.
        rewrite nth_belast_cons.
        *  Check @nth_cons bool false a s i.
           rewrite nth_cons.
           ** Check (IHs i.-1 a).
              by rewrite -(IHs i.-1 a).
           ** done.
        * done.
      + have H1 : i = 1 by apply p0lt__not_1lt__1.
        rewrite H1.
        rewrite nth_belast_cons.
        * rewrite [1.-1]/=.
          rewrite [nth false (a :: s) 0]/=.
            by rewrite nth_belast2'.        (* 正しくない定理 *)
        * by rewrite -{2}H1.                   (* 0 < 1 *)
  Qed.

  Definition fset_shr1 {n} (fs : FSET n) (H : n.-1.+1 = n) : FSET n :=
    [set i : 'I_n | 0 < i & cast_ord H (@inord n.-1 i.-1) \in fs].
  (* シフトした後の、1〜n.-1 は、シフト前の 0〜n.-2 である。 *)
  (* シフトで追加される、シフト後の最左(bit0)の値は、とりあえず不問とする。 *)

  Lemma shr1_repr n (bs : BITS n) (fs : FSET n) :
    forall (H : 0 < n), repr bs fs ->
                        repr (shr1 bs) (fset_shr1 fs (prednK H)).
  Proof.
    move=> H.
    move/setP => H1.
    apply/setP => i.

(*  move: (H1 (cast_ord (prednK H) (@inord n.-1 i.-1))) => {H1} H1'. *)
    move: (H1 (cast_ord (prednK H) (inord i.-1))) => {H1} H1'.

    rewrite !inE (tnth_nth false) in H1'.
    rewrite !inE (tnth_nth false) /shr1 /fset_shr1.

    (* i < n から i < n.-1.+1 。 +1になるのは inordの定義による。 *)
    (* i : 'I_n に値を足しても引いても、'I_n.-1.+1 型になる。 *)
    Check inord i : 'I_n.-1.+1.
    Check @inord n.-1 i : 'I_n.-1.+1.
    (* n を指定すればよいが、cast_ord できないので代入できない。 *)
    Check @inord n i.-1 : 'I_n.+1.
    Check @inord n.+1 i : 'I_n.+1.+1.

    case Hi : (0 < i).
    - rewrite nth_belast1 /=.
      + rewrite -H1' /=.
        Check inordK.
        rewrite inordK.
        * done.
        * (* 普通は i < n なのだが、i.-1 を与えるので、i <= n になってしまう。 *)
          (* i.-1 < n.-1.+1 *)
          (* i.-1.+1 <= n.-1.+1 *)
          Check prednK.
          rewrite !prednK.
          ** apply ltnW.                    (* i < n -> i <= n *)
             by apply ltn_ord.              (* i : 'I_n -> i < n *)
          ** done.
          ** done.
      + done.
    - rewrite nth_belast2 /=.
      + done.
      + by apply: not_0lt__0.
  Qed.

  (* cons してから外す例。 *)
  (* n.+1.-1 は n と判断してくれる。 *)
  Compute behead (cons false [:: true; false]).
  Definition test' {n} (bs : BITS n) : BITS n :=
    behead_tuple (cons_tuple false bs).

  (* drop はかならず 1 とは限らないため、tcast が必要になる。 *)
  Lemma n1_1_n n : n.+1 - 1 = n.
  Proof.
    by rewrite subn1 -pred_Sn.
  Qed.
  Check behead_tuple.

  Compute drop 1 (cons false [:: true; false]).
  Definition test {n} (bs : BITS n) : BITS n :=
    tcast (n1_1_n n)
      (@drop_tuple n.+1 1 bool (cons_tuple false bs)).
End Repr.

(* END *)


Set Implicit Arguments.
Require Import List.
Import ListNotations.
(*Require Import Omega.*)

(* Bit *)

Inductive B : Type :=
  | O : B
  | I : B.

Definition And (x y : B) : B :=
match x with
  | O => O
  | I => y
end.

Definition Or (x y : B) : B :=
match x with
  | O => y
  | I => I
end.

Definition Not (x : B) : B :=
match x with
  | O => I
  | I => O
end.

Definition Add (x y c : B) : B :=
match x, y with
  | O, O => c
  | I, I => c
  | _, _ => Not c
end.

Definition Rem (x y c : B) : B :=
match x, y with
  | O, O => O
  | I, I => I
  | _, _ => c
end.

(* List *)

Fixpoint AndL (x y : list B) : list B :=
match x, y with
| [], _ => []
| _, [] => []
| x :: xs, y :: ys => And x y :: AndL xs ys
end.

Fixpoint OrL (x y : list B) : list B :=
match x, y with
| [], _ => []
| _, [] => []
| x :: xs, y :: ys => Or x y :: OrL xs ys
end.

Fixpoint NotL (x : list B) : list B :=
match x with
  | [] => []
  | x :: xs => Not x :: NotL xs
end.

Fixpoint AddLr (x y : list B) (c : B) : list B :=
match x, y with
| [], _ => []
| _, [] => []
| x :: xs, y :: ys => Add x y c :: AddLr xs ys (Rem x y c)
end.

Definition AddL (x y : list B) : list B := rev (AddLr (rev x) (rev y) O).

Fixpoint IncLr (x : list B) (c : B) : list B :=
match x with
| [] => []
| x :: xs => Add x I c :: IncLr xs (Rem x I c)
end.

Definition IncL (x : list B) : list B := rev (IncLr (rev x) O).

(* ALU *)

Definition flag_zx (f : B) (x : list B) : list B :=
match f with
| I => repeat O (length x)
| O => x
end.

Definition flag_nx (f : B) (x : list B) : list B :=
match f with
| I => NotL x
| O => x
end.

Definition flag_f (f : B) (x y : list B) : list B :=
match f with
| I => AddL x y
| O => AndL x y
end.

Definition ALU (x y : list B) (zx nx zy ny f no : B) : list B :=
  flag_nx no (flag_f f (flag_nx nx (flag_zx zx x)) (flag_nx ny (flag_zx zy y))).

(* Teoremi *)

Lemma ALU_zero (x y : list B) :
  length x = length y -> ALU x y I O I O I O = repeat O (length x).
Proof.
  intros. induction x. simpl. reflexivity.
  simpl.
Abort.

Lemma ALU_minus_one (x y : list B) :
  length x = length y -> ALU x y I I I O I O = repeat I (length x).
Proof.
  intros. induction x. simpl. reflexivity. simpl.
 Abort.

Lemma ALU_x (x y : list B) :
  length x = length y -> ALU x y O O I I O O = x.
Proof.
  intros. induction x. simpl. reflexivity. simpl.
 Abort.

Lemma ALU_y (x y : list B) :
  length x = length y -> ALU x y I I O O O O = y.
Proof.
intros. induction x. simpl.
 Abort.

Lemma ALU_Not_x (x y : list B) :
  length x = length y -> ALU x y O O I I O I = NotL x.
Proof.
intros. induction x. simpl. reflexivity. simpl.
 Abort.

Lemma ALU_Not_y (x y : list B) :
  length x = length y -> ALU x y I I O O O I = NotL y.
Proof.
intros. induction x. simpl.
Abort.

Lemma ALU_Add (x y : list B) :
  length x = length y -> ALU x y O O O O I O = AddL x y.
Proof.
intros. induction x. simpl. reflexivity. simpl. Abort.

(* DZ *)

Lemma ALU_And (x y : list B) :
  length x = length y -> ALU x y O O O O O O = AndL x y.
Proof.
intros. induction x. simpl. reflexivity. simpl. Admitted.

Lemma ALU_Or (x y : list B) :
  length x = length y -> ALU x y O I O I O I = OrL x y.
Proof.
intros. induction x. simpl. reflexivity. simpl. Admitted.

Lemma ALU_One (n : nat) (x y : list B) :
  length x = n /\ length y = n /\ n <> 0 -> ALU x y I I I I I I = repeat O (pred n) ++ [I].
Proof.
intros. induction x. simpl. Admitted.


(** Semántica y verificación 22-1

  Árboles de Braun

  Los árboles de Braun sirven como una estructura de datos
  donde las consultas, eliminaciones y extensiones pueden ser
  bastante rápidas. Los árboles de Braun son árboles
  binarios balanceados.
  En este script con se plantea la definición de un árbol de Braun
  y algunas de sus propiedades básicas. Dado que se requiere
  que los árboles sean balanceados, requerimos plantear propiedades
  respecto a tamaños de árboles. Requerimos que el tamaño
  de todo subárbol hermano difiera en a lo más una unidad. Esto impone
  descripciones de los tamaños referirá mucho dividir un natural en dos.
  La descripción usual mediante sucesores es incómoda para constantes
  divisiones entre dos, por lo que se usa su representación binaria
  al esta ser mucho más amena a lo requerido.

  Este script fue basado de los cursos de Favio Ezquiel
  Miranda Perea y modificado en ciertos aspectos.

  Edición por Luis Felipe Benítez Lluis

  Contenido:
    1 Definición de función de tamaño
    2 Propiedad de balance de árboles de Braun
    3 Propiedades de tamaño

    Para acceder rápidamente a la sección deseada
    buscar la cadena ">n" donde "n" es el número de
    sección. *)
From Proyecto02Base Require Import binnat.
From Proyecto02Base Require Import order_binnat.
From Proyecto02Base Require Import bintree.
Require Import Coq.Arith.PeanoNat.

(** >1 Definición de función de tamaño*)

(* Función de tamaño de un árbol como número binario*)
Fixpoint bsize (t:BTree): BN :=
 match t with
  E => Z
 |N x s t =>  sucBN ((bsize s) +_(bsize t))
 end.

Check bsize.

(** >E Rellenar este problema. Dificultad 2*)
Lemma bsize_Z: forall (t:BTree), bsize t = Z -> t = E.
Proof.
Admitted.

Lemma bsize_nonZ: forall (t:BTree), t <> E <-> bsize t <> Z.
Proof.
intros.
split.
intro.
contradict H.
apply bsize_Z.
trivial.
intro.
intro.
contradict H.
rewrite H0.
simpl.
reflexivity.
Qed.

Lemma btNonE: forall (t:BTree) (b:BN), t <> E ->
                       exists (b:BN), bsize t = U b \/ bsize t = D b.
Proof.
intros.
apply bsize_nonZ in H.
apply (bnNonZ (bsize t)) in H.
trivial.
Qed.

(** >2 Propiedad de balance de árboles de Braun*)
(* Prop para decir que una árbol está balanceado *)
Inductive bbal : BTree -> Prop:=
 |bbalE : bbal E (*El árbol vacio está balanceado*)
 |bbalN : forall (a: A) (s t: BTree), (* tomamos s t los hijos y a:A*)
          bbal s -> bbal t -> (* si los árboles hijos están balanceados*)
            (bsize t) <=BN (bsize s) ->  (*El tamaño t supera a s*)
            (bsize s) <=BN (sucBN (bsize t)) -> (* Pero lo supera en a lo mas uno*)
                                      bbal (N a s t).
(*Con estas reglas la diferencia entre tamaños de los hijos es a lo más
1*)

Check bbal_ind.

(*Como todas las propiedades en adelante se harán sobre árboles que cumplan
ser de Braun, se asumirá que son balanceados, y por tanto añadimos
tal afirmación global*)
Parameter (allBal: forall (t:BTree), bbal t).

(** >3 Propiedades de tamaño*)

Lemma prop_0_U :
  forall (a:A) (s t:BTree) (b:BN),
         bbal (N a s t) ->
         bsize(N a s t) = U b ->
                  bsize s = b /\ bsize t = b.
Proof.
intros.
simpl in H0.
assert (H0b:=H0).
rewrite <- plus_U in H0.
apply SucBNinj in H0.
inversion H.
destruct(bbalCond_eqs (bsize s) (bsize t)).
trivial.
trivial.
rewrite <- H8 in H0.
apply plus_a_a in H0.
rewrite <- H8.
intuition.
rewrite H8 in H0b.
rewrite plus_D in H0b.
inversion H0b.
Qed.

Lemma prop_0_D :
  forall (a:A) (s t:BTree) (b:BN),
    bbal (N a s t) ->
    bsize(N a s t) = D b ->
        bsize s = sucBN b /\ bsize t = b.
Proof.
intros.
simpl in H0.
assert (H0b:=H0).
rewrite <- plus_D in H0.
apply SucBNinj in H0.
inversion H.
destruct(bbalCond_eqs (bsize s) (bsize t)).
trivial.
trivial.
rewrite <- H8 in H0b.
rewrite plus_U in H0b.
inversion H0b.
rewrite H8 in H0.
apply plus_SucBNa_a in H0.
rewrite <- H0.
intuition.
Qed.

Corollary size_caseU:
  forall (a:A) (l r:BTree) (b:BN),
    bsize (N a l r) = U b ->
        bsize l = bsize r.
Proof.
intros.
assert (HBal := allBal (N a l r)).
apply (prop_0_U a l r b) in H.
intuition.
rewrite <- H1 in H0.
intuition. intuition.
Qed.

Corollary size_caseD:
    forall (a:A) (l r:BTree) (b:BN),
        bsize (N a l r) = D b ->
            bsize l = sucBN (bsize r).
Proof.
intros.
assert (HBal := allBal (N a l r)).
apply (prop_0_D a l r b) in H.
intuition.
rewrite <- H1 in H0.
intuition. intuition.
Qed.

Corollary bbal_size_r:
    forall (a:A) (l r:BTree),
        bsize (N a l r) = U (bsize r) \/
                 bsize (N a l r) = D (bsize r).
Proof.
intros.
assert (HBal:=allBal (N a l r)).
destruct (bnNonZ (bsize (N a l r))).
simpl.
assert (Z <> sucBN (bsize l +_bsize r)).
apply ZnotSucBN.
intuition.
destruct H.
apply prop_0_U in H.
simpl.
destruct H.
rewrite H.
rewrite H0.
rewrite plus_U.
intuition.
trivial.
apply prop_0_D in H.
destruct H.
simpl.
rewrite H.
rewrite H0.
rewrite plus_D.
intuition.
trivial.
Qed.

Theorem bbal_size_r2:
  forall (a:A) (l r:BTree),
      (bsize (N a l r)) <=BN (D (bsize r)).
Proof.
intros a l r.
destruct (bbal_size_r a l r).
constructor.
rewrite H.
constructor.
rewrite H.
constructor.
Qed.

Theorem bbal_size_l:
  forall (a:A) (l r:BTree),
      (bsize (N a l r)) <=BN (U (bsize l)).
Proof.
intros.
assert (HBal:=allBal (N a l r)).
destruct (bnNonZ (bsize (N a l r))).
- simpl.
  assert (Z <> sucBN (bsize l +_bsize r)).
  apply ZnotSucBN.
  intuition.
- destruct H.
  + apply prop_0_U in H.
    * simpl.
      destruct H.
      subst.
      rewrite H0.
      rewrite plus_U.
      constructor.
    * assumption.
  +  apply prop_0_D in H.
    * simpl.
      destruct H.
rewrite H.
rewrite H0.
rewrite plus_D.
constructor.
constructor.
apply lts.
* trivial.
Qed.

Lemma lt_U_bsize: forall (b:BN) (a:A) (t1 t2:BTree),
    (U b) <BN (bsize (N a t1 t2)) -> b <BN (bsize t1).
Proof.
intros b a t1 t2 H.
assert ((bsize (N a t1 t2)) <=BN (U (bsize t1))).
apply bbal_size_l.
assert ((U b) <BN (U (bsize t1))).
eapply lt_lteqBN_trans.
eexact H.
trivial.
inversion H1.
trivial.
Qed.

Theorem rightE: forall (a:A) (t1 t2:BTree),
    bbal(N a t1 t2) -> t2 = E ->
        (t1 = E \/ exists (aa:A), t1 = (N aa E E)).
Proof.
intros.
inversion H.
destruct (bbalCond_eqs (bsize t1) (bsize t2)).
trivial.
trivial.
rewrite H0 in H8.
simpl in H8.
apply bsize_Z in H8.
intuition.
rewrite H0 in H8.
right.
destruct t1.
simpl in H8.
inversion H8.
simpl in H8.
replace (U Z) with (sucBN Z) in H8.
apply SucBNinj in H8.
apply plusBN_Z_Z in H8.
destruct H8.
apply bsize_Z in H8.
apply bsize_Z in H9.
exists a1.
rewrite H8.
rewrite H9.
trivial.
intuition.
Qed.

Lemma lt_D_bsize: forall (b:BN) (a:A) (t1 t2:BTree),
      (D b) <BN (bsize (N a t1 t2)) ->
          b <BN (bsize t2).
Proof.
intros b a t1 t2 H.
assert ((bsize (N a t1 t2)) <=BN (D (bsize t2))).
apply bbal_size_r2.
assert ((D b) <BN (D (bsize t2))).
eapply lt_lteqBN_trans.
eexact H.
trivial.
inversion H1.
trivial.
Qed.

(** >E Rellenar este problema. Dificultad 1*)
Lemma bbal_leaf: forall (a:A), bbal (N a E E).
Proof.
Admitted.

Theorem leftE_leaf: forall (t1 t2:BTree) (a:A),
    bbal (N a t1 t2) ->
    t1 = E ->
        t2 = E.
Proof.
intros t1 t2 c HBal H.
inversion HBal.
rewrite H in H5.
simpl in H5.
inversion H5.
apply bsize_Z in H9.
trivial.
inversion H7.
Qed.

(** >E ¿Te atreves a resolver este? Dificultad ??
      (no obligatorio)*)
Lemma bbal_inv:
    forall (t:BTree), t <> E ->
        (exists (z:A), t = N z E E)  \/
            exists (z:A) (r1 r2:BTree),
                  bbal r1 /\ bbal r2 /\ r1 <> E /\ t = N z r1 r2.
Proof.
Admitted.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id$ *)

(** * FSetFullAVL : some complements to FSetAVL

   - Functor [AvlProofs] proves that trees of [FSetAVL] are not only
   binary search trees, but moreover well-balanced ones. This is done
   by proving that all operations preserve the balancing.

   - Functor [OcamlOps] contains variants of [union], [subset],
   [compare] and [equal] that are faithful to the original ocaml codes,
   while the versions in FSetAVL have been adapted to perform only
   structural recursive code.

   - Finally, we pack the previous elements in a [Make] functor
   similar to the one of [FSetAVL], but richer.
*)

Require Import Recdef FSetInterface FSetList0 ZArith Int FSetAVL0 ROmega.

Set Implicit Arguments.
Unset Strict Implicit.

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

Ltac omega_max := i2z_refl; romega with Z.

(** * AVL trees *)

(** [avl s] : [s] is a properly balanced AVL tree,
    i.e. for any node the heights of the two children
    differ by at most 2 *)

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

(** * Automation and dedicated tactics *)

Hint Constructors avl.

(** A tactic for cleaning hypothesis after use of functional induction. *)

Ltac clearf :=
 match goal with
  | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf
  | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf
  | _ => idtac
 end.

(** Tactics about [avl] *)

Lemma height_non_negative : forall s : tree, avl s -> height s >= 0.
Proof.
 induction s; simpl; intros; auto with zarith.
 inv avl; intuition; omega_max.
Qed.
Implicit Arguments height_non_negative.

(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *)

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.

(* Repeat the previous tactic.
   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)

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

(** Results about [height] *)

Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf.
Proof.
 destruct 1; intuition; simpl in *.
 avl_nns; simpl in *; exfalso; omega_max.
Qed.

(** * Results about [avl] *)

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

(** empty *)

Lemma empty_avl : avl empty.
Proof.
 auto.
Qed.

(** singleton *)

Lemma singleton_avl : forall x : elt, avl (singleton x).
Proof.
 unfold singleton; intro.
 constructor; auto; try red; simpl; omega_max.
Qed.

(** create *)

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

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

(** bal *)

Lemma bal_avl : forall l x r, avl l -> avl r ->
 -(3) <= height l - height r <= 3 -> avl (bal l x r).
Proof.
 intros l x r; functional induction bal l x 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 r, avl l -> avl r ->
 -(3) <= height l - height r <= 3 ->
 0 <= height (bal l x r) - max (height l) (height r) <= 1.
Proof.
 intros l x r; functional induction bal l x r; intros; clearf;
 inv avl; avl_nns; simpl in *; omega_max.
Qed.

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

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

(** add *)

Lemma add_avl_1 :  forall s x, avl s ->
 avl (add x s) /\ 0 <= height (add x s) - height s <= 1.
Proof.
 intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *.
 intuition; try constructor; simpl; auto; try omega_max.
 (* LT *)
 destruct IHt; auto.
 split.
 apply bal_avl; auto; omega_max.
 omega_bal.
 (* EQ *)
 intuition; omega_max.
 (* GT *)
 destruct IHt; auto.
 split.
 apply bal_avl; auto; omega_max.
 omega_bal.
Qed.

Lemma add_avl : forall s x, avl s -> avl (add x s).
Proof.
 intros; destruct (add_avl_1 x H); auto.
Qed.
Hint Resolve add_avl.

(** join *)

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

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

 inversion_clear H.
 assert (height (Node rl rx rr rh) = rh); auto.
 set (r := Node rl rx rr rh) in *; clearbody r.
 destruct (Hlr x r H2 H0); clear Hrl Hlr.
 set (j := join lr x 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 lr lh) = lh); auto.
 set (l' := Node ll lx lr lh) in *; clearbody l'.
 destruct (Hrl H H1); clear Hrl Hlr.
 set (j := join l' x 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 lr lh) = lh); auto.
 assert (height (Node rl rx rr rh) = rh); auto.
 set (l' := Node ll lx lr lh) in *; clearbody l'.
 set (r := Node rl rx 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 r, avl l -> avl r -> avl (join l x r).
Proof.
 intros; destruct (join_avl_1 x H H0); auto.
Qed.
Hint Resolve join_avl.

(** remove_min *)

Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) ->
 avl (remove_min l x r)#1 /\
 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 1.
Proof.
 intros l x r; functional induction (remove_min l x r); subst;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 r h, avl (Node l x r h) ->
    avl (remove_min l x r)#1.
Proof.
 intros; destruct (remove_min_avl_1 H); auto.
Qed.

(** merge *)

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

Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 ->
  -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2).
Proof.
 intros; destruct (merge_avl_1 H H0 H1); auto.
Qed.

(** remove *)

Lemma remove_avl_1 : forall s x, avl s ->
 avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1.
Proof.
 intros s x; functional induction (remove x s); intros.
 intuition; omega_max.
 (* LT *)
 inv avl.
 destruct (IHt H0).
 split.
 apply bal_avl; auto.
 omega_max.
 omega_bal.
 (* EQ *)
 inv avl.
 generalize (merge_avl_1 H0 H1 H2).
 intuition omega_max.
 (* GT *)
 inv avl.
 destruct (IHt H1).
 split.
 apply bal_avl; auto.
 omega_max.
 omega_bal.
Qed.

Lemma remove_avl : forall s x, avl s -> avl (remove x s).
Proof.
 intros; destruct (remove_avl_1 x H); auto.
Qed.
Hint Resolve remove_avl.

(** concat *)

Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
Proof.
 intros s1 s2; functional induction (concat s1 s2); auto.
 intros; apply join_avl; auto.
 generalize (remove_min_avl H0); rewrite e1; simpl; auto.
Qed.
Hint Resolve concat_avl.

(** split *)

Lemma split_avl : forall s x, avl s ->
  avl (split x s)#l /\ avl (split x s)#r.
Proof.
 intros s x; functional induction (split x s); 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.

(** inter *)

Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2).
Proof.
 intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2;
 generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1;
 inv avl; auto.
Qed.

(** diff *)

Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2).
Proof.
 intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2;
 generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1;
 inv avl; auto.
Qed.

(** union *)

Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2).
Proof.
 intros s1 s2; functional induction union s1 s2; auto; intros A1 A2;
 generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1;
 inv avl; auto.
Qed.

(** filter *)

Lemma filter_acc_avl : forall f s acc, avl s -> avl acc ->
 avl (filter_acc f acc s).
Proof.
 induction s; simpl; auto.
 intros.
 inv avl.
 destruct (f t); auto.
Qed.
Hint Resolve filter_acc_avl.

Lemma filter_avl : forall f s, avl s -> avl (filter f s).
Proof.
 unfold filter; intros; apply filter_acc_avl; auto.
Qed.

(** partition *)

Lemma partition_acc_avl_1 : forall f s acc, avl s ->
 avl acc#1 -> avl (partition_acc f acc s)#1.
Proof.
 induction s; simpl; auto.
 destruct acc as [acct accf]; simpl in *.
 intros.
 inv avl.
 apply IHs2; auto.
 apply IHs1; auto.
 destruct (f t); simpl; auto.
Qed.

Lemma partition_acc_avl_2 : forall f s acc, avl s ->
 avl acc#2 -> avl (partition_acc f acc s)#2.
Proof.
 induction s; simpl; auto.
 destruct acc as [acct accf]; simpl in *.
 intros.
 inv avl.
 apply IHs2; auto.
 apply IHs1; auto.
 destruct (f t); simpl; auto.
Qed.

Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1.
Proof.
 unfold partition; intros; apply partition_acc_avl_1; auto.
Qed.

Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2.
Proof.
 unfold partition; intros; apply partition_acc_avl_2; auto.
Qed.

End AvlProofs.

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

(** Properties of cardinal *)

Lemma bal_cardinal : forall l x r,
 cardinal (bal l x r) = S (cardinal l + cardinal r).
Proof.
 intros l x r; functional induction bal l x r; intros; clearf;
 simpl; auto with arith; romega with *.
Qed.

Lemma add_cardinal : forall x s,
 cardinal (add x s) <= S (cardinal s).
Proof.
 intros; functional induction add x s; simpl; auto with arith;
 rewrite bal_cardinal; romega with *.
Qed.

Lemma join_cardinal : forall l x r,
 cardinal (join l x r) <= S (cardinal l + cardinal r).
Proof.
 join_tac; auto with arith.
 simpl; apply add_cardinal.
 simpl; destruct X.compare; simpl; auto with arith.
 generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll);
  romega with *.
 generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr);
  romega with *.
 generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh)))
  (Hlr x (Node rl rx rr rh)); simpl; romega with *.
 simpl (S _) in *; generalize (bal_cardinal (join (Node ll lx lr lh) x rl) rx rr).
 romega with *.
Qed.

Lemma split_cardinal_1 : forall x s,
 (cardinal (split x s)#l <= cardinal s)%nat.
Proof.
 intros x s; functional induction split x s; simpl; auto.
 rewrite e1 in IHt; simpl in *.
 romega with *.
 romega with *.
 rewrite e1 in IHt; simpl in *.
 generalize (@join_cardinal l y rl); romega with *.
Qed.

Lemma split_cardinal_2 : forall x s,
 (cardinal (split x s)#r <= cardinal s)%nat.
Proof.
 intros x s; functional induction split x s; simpl; auto.
 rewrite e1 in IHt; simpl in *.
 generalize (@join_cardinal rl y r); romega with *.
 romega with *.
 rewrite e1 in IHt; simpl in *; romega with *.
Qed.

(** * [ocaml_union], an union faithful to the original ocaml code *)

Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat.

Ltac ocaml_union_tac :=
 intros; unfold cardinal2; simpl @fst in *; simpl @snd in *;
 match goal with H: split ?x ?s = _ |- _ =>
  generalize (split_cardinal_1 x s) (split_cardinal_2 x s);
  rewrite H; simpl; romega with *
 end.

Function ocaml_union (s : t * t) { measure cardinal2 s } : t  :=
 match s with
  | (Leaf, Leaf) => s#2
  | (Leaf, Node _ _ _ _) => s#2
  | (Node _ _ _ _, Leaf) => s#1
  | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) =>
        if ge_lt_dec h1 h2 then
          if eq_dec h2 1%I then add x2 s#1 else
          let (l2',_,r2') := split x1 s#2 in
             join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2'))
        else
          if eq_dec h1 1%I then add x1 s#2 else
          let (l1',_,r1') := split x2 s#1 in
             join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2))
 end.
Proof.
abstract ocaml_union_tac.
abstract ocaml_union_tac.
abstract ocaml_union_tac.
abstract ocaml_union_tac.
Defined.

Lemma ocaml_union_in : forall s y,
 bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 ->
 (In y (ocaml_union s) <-> In y s#1 \/ In y s#2).
Proof.
 intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2;
  simpl @fst in *; simpl @snd in *; try clear e0 e1.
 intuition_in.
 intuition_in.
 intuition_in.
 (* add x2 s#1 *)
 inv avl.
 rewrite (height_0 H); [ | avl_nn l2; omega_max].
 rewrite (height_0 H0); [ | avl_nn r2; omega_max].
 rewrite add_in; intuition_in.
 (* join (union (l1,l2')) x1 (union (r1,r2')) *)
 generalize
  (split_avl x1 A2) (split_bst x1 B2)
  (split_in_1 x1 y B2) (split_in_2 x1 y B2).
 rewrite e2; simpl.
 destruct 1; destruct 1; inv avl; inv bst.
 rewrite join_in, IHt, IHt0; auto.
 do 2 (intro Eq; rewrite Eq; clear Eq).
 case (X.compare y x1); intuition_in.
 (* add x1 s#2 *)
 inv avl.
 rewrite (height_0 H3); [ | avl_nn l1; omega_max].
 rewrite (height_0 H4); [ | avl_nn r1; omega_max].
 rewrite add_in; auto; intuition_in.
 (* join (union (l1',l2)) x1 (union (r1',r2)) *)
 generalize
  (split_avl x2 A1) (split_bst x2 B1)
  (split_in_1 x2 y B1) (split_in_2 x2 y B1).
 rewrite e2; simpl.
 destruct 1; destruct 1; inv avl; inv bst.
 rewrite join_in, IHt, IHt0; auto.
 do 2 (intro Eq; rewrite Eq; clear Eq).
 case (X.compare y x2); intuition_in.
Qed.

Lemma ocaml_union_bst : forall s,
 bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s).
Proof.
 intros s; functional induction ocaml_union s; intros B1 A1 B2 A2;
  simpl @fst in *; simpl @snd in *; try clear e0 e1;
  try apply add_bst; auto.
 (* join (union (l1,l2')) x1 (union (r1,r2')) *)
 clear _x _x0; factornode l2 x2 r2 h2 as s2.
 generalize (split_avl x1 A2) (split_bst x1 B2)
  (@split_in_1 s2 x1)(@split_in_2 s2 x1).
 rewrite e2; simpl.
 destruct 1; destruct 1; intros.
 inv bst; inv avl.
 apply join_bst; auto.
 intro y; rewrite ocaml_union_in, H3; intuition_in.
 intro y; rewrite ocaml_union_in, H4; intuition_in.
 (* join (union (l1',l2)) x1 (union (r1',r2)) *)
 clear _x _x0; factornode l1 x1 r1 h1 as s1.
 generalize (split_avl x2 A1) (split_bst x2 B1)
  (@split_in_1 s1 x2)(@split_in_2 s1 x2).
 rewrite e2; simpl.
 destruct 1; destruct 1; intros.
 inv bst; inv avl.
 apply join_bst; auto.
 intro y; rewrite ocaml_union_in, H3; intuition_in.
 intro y; rewrite ocaml_union_in, H4; intuition_in.
Qed.

Lemma ocaml_union_avl : forall s,
 avl s#1 -> avl s#2 -> avl (ocaml_union s).
Proof.
 intros s; functional induction ocaml_union s;
  simpl @fst in *; simpl @snd in *; auto.
 intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl.
 inv avl; destruct 1; auto.
 intros A1 A2; generalize (split_avl x2 A1); rewrite e2; simpl.
 inv avl; destruct 1; auto.
Qed.

Lemma ocaml_union_alt : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 ->
 Equal (ocaml_union s) (union s#1 s#2).
Proof.
 red; intros; rewrite ocaml_union_in, union_in; simpl; intuition.
Qed.

(** * [ocaml_subset], a subset faithful to the original ocaml code *)

Function ocaml_subset (s:t*t) { measure cardinal2 s } : bool :=
 match s with
  | (Leaf, _) => true
  | (Node _ _ _ _, Leaf) => false
  | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) =>
     match X.compare x1 x2 with
      | EQ _ => ocaml_subset (l1,l2) && ocaml_subset (r1,r2)
      | LT _ => ocaml_subset (Node l1 x1 Leaf 0%I, l2) && ocaml_subset (r1,s#2)
      | GT _ => ocaml_subset (Node Leaf x1 r1 0%I, r2) && ocaml_subset (l1,s#2)
     end
 end.

Proof.
 intros; unfold cardinal2; simpl; abstract romega with *.
 intros; unfold cardinal2; simpl; abstract romega with *.
 intros; unfold cardinal2; simpl; abstract romega with *.
 intros; unfold cardinal2; simpl; abstract romega with *.
 intros; unfold cardinal2; simpl; abstract romega with *.
 intros; unfold cardinal2; simpl; abstract romega with *.
Defined.

Lemma ocaml_subset_12 : forall s,
 bst s#1 -> bst s#2 ->
 (ocaml_subset s = true <-> Subset s#1 s#2).
Proof.
 intros s; functional induction ocaml_subset s; simpl;
  intros B1 B2; try clear e0.
 intuition.
 red; auto; inversion 1.
 split; intros; try discriminate.
 assert (H': In _x0 Leaf) by auto; inversion H'.
 (**)
 simpl in *; inv bst.
 rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
 unfold Subset; intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 (**)
 simpl in *; inv bst.
 rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
 unfold Subset; intuition_in.
 assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 (**)
 simpl in *; inv bst.
 rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0.
 unfold Subset; intuition_in.
 assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
 assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
Qed.

Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 ->
 ocaml_subset s = subset s#1 s#2.
Proof.
 intros.
 generalize (ocaml_subset_12 H H0); rewrite <-subset_12 by auto.
 destruct ocaml_subset; destruct subset; intuition.
Qed.

(** [ocaml_compare], a compare faithful to the original ocaml code *)

(** termination of [compare_aux] *)

Fixpoint cardinal_e e := match e with
  | End => 0
  | More _ s r => S (cardinal s + cardinal_e r)
 end.

Lemma cons_cardinal_e : forall s e,
 cardinal_e (cons s e) = cardinal s + cardinal_e e.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1; simpl; rewrite <- plus_n_Sm; auto with arith.
Qed.

Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2.

Function ocaml_compare_aux
 (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison :=
 match e with
 | (End,End) => Eq
 | (End,More _ _ _) => Lt
 | (More _ _ _, End) => Gt
 | (More x1 r1 e1, More x2 r2 e2) =>
       match X.compare x1 x2 with
        | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2)
        | LT _ => Lt
        | GT _ => Gt
       end
 end.

Proof.
intros; unfold cardinal_e_2; simpl;
abstract (do 2 rewrite cons_cardinal_e; romega with *).
Defined.

Definition ocaml_compare s1 s2 :=
 ocaml_compare_aux (cons s1 End, cons s2 End).

Lemma ocaml_compare_aux_Cmp : forall e,
 Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2).
Proof.
 intros e; functional induction ocaml_compare_aux e; simpl; intros;
  auto; try discriminate.
 apply L.eq_refl.
 simpl in *.
 apply cons_Cmp; auto.
 rewrite <- 2 cons_1; auto.
Qed.

Lemma ocaml_compare_Cmp : forall s1 s2,
 Cmp (ocaml_compare s1 s2) (elements s1) (elements s2).
Proof.
 unfold ocaml_compare; intros.
 assert (H1:=cons_1 s1 End).
 assert (H2:=cons_1 s2 End).
 simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2.
 apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)).
Qed.

Import Proofs. (* Hidden by some Function devilry *)

Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 ->
 ocaml_compare s1 s2 = compare s1 s2.
Proof.
 intros s1 s2 B1 B2.
 generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2).
 unfold Cmp.
 destruct ocaml_compare; destruct compare; auto; intros; exfalso.
 elim (lt_not_eq B1 B2 H0); auto.
 elim (lt_not_eq B2 B1 H0); auto.
  apply eq_sym; auto.
 elim (lt_not_eq B1 B2 H); auto.
  elim (lt_not_eq B1 B1).
  red; eapply L.lt_trans; eauto.
  apply eq_refl.
 elim (lt_not_eq B2 B1 H); auto.
  apply eq_sym; auto.
 elim (lt_not_eq B1 B2 H0); auto.
  elim (lt_not_eq B1 B1).
  red; eapply L.lt_trans; eauto.
  apply eq_refl.
Qed.

(** * Equality test *)

Definition ocaml_equal s1 s2 : bool :=
 match ocaml_compare s1 s2 with
  | Eq => true
  | _ => false
 end.

Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 ->
 Equal s1 s2 -> ocaml_equal s1 s2 = true.
Proof.
unfold ocaml_equal; intros s1 s2 B1 B2 E.
generalize (ocaml_compare_Cmp s1 s2).
destruct (ocaml_compare s1 s2); auto; intros.
elim (lt_not_eq B1 B2 H E); auto.
elim (lt_not_eq B2 B1 H (eq_sym E)); auto.
Qed.

Lemma ocaml_equal_2 : forall s1 s2,
 ocaml_equal s1 s2 = true -> Equal s1 s2.
Proof.
unfold ocaml_equal; intros s1 s2 E.
generalize (ocaml_compare_Cmp s1 s2);
 destruct ocaml_compare; auto; discriminate.
Qed.

Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 ->
 ocaml_equal s1 s2 = equal s1 s2.
Proof.
intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto.
Qed.

End OcamlOps.

(** * Encapsulation

   We can implement [S] with balanced binary search trees.
   When compared to [FSetAVL], we maintain here two invariants
   (bst and avl) instead of only bst, which is enough for fulfilling
   the FSet interface.

   This encapsulation propose the non-structural variants
   [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal].
*)

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

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

 Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}.
 Definition t := bbst.
 Definition elt := E.t.

 Definition In (x : elt) (s : t) : Prop := In x s.
 Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
 Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
 Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
 Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x.
 Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x.

 Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s.
 Proof. intro s; exact (@In_1 s). Qed.

 Definition mem (x:elt)(s:t) : bool := mem x s.

 Definition empty : t := Bbst empty_bst empty_avl.
 Definition is_empty (s:t) : bool := is_empty s.
 Definition singleton (x:elt) : t :=
   Bbst (singleton_bst x) (singleton_avl x).
 Definition add (x:elt)(s:t) : t :=
   Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)).
 Definition remove (x:elt)(s:t) : t :=
   Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)).
 Definition inter (s s':t) : t :=
   Bbst (inter_bst (is_bst s) (is_bst s'))
        (inter_avl (is_avl s) (is_avl s')).
 Definition union (s s':t) : t :=
   Bbst (union_bst (is_bst s) (is_bst s'))
        (union_avl (is_avl s) (is_avl s')).
 Definition ocaml_union (s s':t) : t :=
   Bbst (@ocaml_union_bst (s.(this),s'.(this))
          (is_bst s) (is_avl s) (is_bst s') (is_avl s'))
        (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')).
 Definition diff (s s':t) : t :=
   Bbst (diff_bst (is_bst s) (is_bst s'))
        (diff_avl (is_avl s) (is_avl s')).
 Definition elements (s:t) : list elt := elements s.
 Definition min_elt (s:t) : option elt := min_elt s.
 Definition max_elt (s:t) : option elt := max_elt s.
 Definition choose (s:t) : option elt := choose s.
 Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s.
 Definition cardinal (s:t) : nat := cardinal s.
 Definition filter (f : elt -> bool) (s:t) : t :=
   Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)).
 Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s.
 Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s.
 Definition partition (f : elt -> bool) (s:t) : t * t :=
   let p := partition f s in
   (@Bbst (fst p) (partition_bst_1 f (is_bst s))
                 (partition_avl_1 f (is_avl s)),
    @Bbst (snd p) (partition_bst_2 f (is_bst s))
                 (partition_avl_2 f (is_avl s))).

 Definition equal (s s':t) : bool := equal s s'.
 Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'.
 Definition subset (s s':t) : bool := subset s s'.
 Definition ocaml_subset (s s':t) : bool :=
  ocaml_subset (s.(this),s'.(this)).

 Definition eq (s s':t) : Prop := Equal s s'.
 Definition lt (s s':t) : Prop := lt s s'.

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

 Definition ocaml_compare (s s':t) : Compare lt eq s s'.
 Proof.
  destruct s as (s,b,a), s' as (s',b',a').
  generalize (ocaml_compare_Cmp s s').
  destruct ocaml_compare; intros; [apply EQ|apply LT|apply GT]; red; auto.
  change (Raw.Equal s s'); auto.
 Defined.

 Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }.
 Proof.
  destruct s as (s,b,a), s' as (s',b',a'); unfold eq; simpl.
  case_eq (Raw.equal s s'); intro H; [left|right].
  apply equal_2; auto.
  intro H'; rewrite equal_1 in H; auto; discriminate.
 Defined.

 (* specs *)
 Section Specs.
 Variable s s' s'': t.
 Variable x y : elt.

 Hint Resolve is_bst is_avl.

 Lemma mem_1 : In x s -> mem x s = true.
 Proof. exact (mem_1 (is_bst s)). Qed.
 Lemma mem_2 : mem x s = true -> In x s.
 Proof. exact (@mem_2 s x). Qed.

 Lemma equal_1 : Equal s s' -> equal s s' = true.
 Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed.
 Lemma equal_2 : equal s s' = true -> Equal s s'.
 Proof. exact (@equal_2 s s'). Qed.

 Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'.
 Proof.
  destruct s; destruct s'; unfold ocaml_equal, equal; simpl.
  apply ocaml_equal_alt; auto.
 Qed.

 Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true.
 Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed.
 Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'.
 Proof. exact (@ocaml_equal_2 s s'). Qed.

 Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition.

 Lemma subset_1 : Subset s s' -> subset s s' = true.
 Proof. wrap subset subset_12. Qed.
 Lemma subset_2 : subset s s' = true -> Subset s s'.
 Proof. wrap subset subset_12. Qed.

 Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'.
 Proof.
  destruct s; destruct s'; unfold ocaml_subset, subset; simpl.
  rewrite ocaml_subset_alt; auto.
 Qed.

 Lemma ocaml_subset_1 : Subset s s' -> ocaml_subset s s' = true.
 Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed.
 Lemma ocaml_subset_2 : ocaml_subset s s' = true -> Subset s s'.
 Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed.

 Lemma empty_1 : Empty empty.
 Proof. exact empty_1. Qed.

 Lemma is_empty_1 : Empty s -> is_empty s = true.
 Proof. exact (@is_empty_1 s). Qed.
 Lemma is_empty_2 : is_empty s = true -> Empty s.
 Proof. exact (@is_empty_2 s). Qed.

 Lemma add_1 : E.eq x y -> In y (add x s).
 Proof. wrap add add_in. Qed.
 Lemma add_2 : In y s -> In y (add x s).
 Proof. wrap add add_in. Qed.
 Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
 Proof. wrap add add_in. elim H; auto. Qed.

 Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
 Proof. wrap remove remove_in. Qed.
 Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
 Proof. wrap remove remove_in. Qed.
 Lemma remove_3 : In y (remove x s) -> In y s.
 Proof. wrap remove remove_in. Qed.

 Lemma singleton_1 : In y (singleton x) -> E.eq x y.
 Proof. exact (@singleton_1 x y). Qed.
 Lemma singleton_2 : E.eq x y -> In y (singleton x).
 Proof. exact (@singleton_2 x y). Qed.

 Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
 Proof. wrap union union_in. Qed.
 Lemma union_2 : In x s -> In x (union s s').
 Proof. wrap union union_in. Qed.
 Lemma union_3 : In x s' -> In x (union s s').
 Proof. wrap union union_in. Qed.

 Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s').
 Proof.
  unfold ocaml_union, union, Equal, In.
  destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl.
  exact (@ocaml_union_alt (s0,s0') b a b' a').
 Qed.

 Lemma ocaml_union_1 : In x (ocaml_union s s') -> In x s \/ In x s'.
 Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
 Lemma ocaml_union_2 : In x s -> In x (ocaml_union s s').
 Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.
 Lemma ocaml_union_3 : In x s' -> In x (ocaml_union s s').
 Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed.

 Lemma inter_1 : In x (inter s s') -> In x s.
 Proof. wrap inter inter_in. Qed.
 Lemma inter_2 : In x (inter s s') -> In x s'.
 Proof. wrap inter inter_in. Qed.
 Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
 Proof. wrap inter inter_in. Qed.

 Lemma diff_1 : In x (diff s s') -> In x s.
 Proof. wrap diff diff_in. Qed.
 Lemma diff_2 : In x (diff s s') -> ~ In x s'.
 Proof. wrap diff diff_in. Qed.
 Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
 Proof. wrap diff diff_in. Qed.

 Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
      fold f s i = fold_left (fun a e => f e a) (elements s) i.
 Proof.
 unfold fold, elements; intros; apply fold_1; auto.
 Qed.

 Lemma cardinal_1 : cardinal s = length (elements s).
 Proof.
 unfold cardinal, elements; intros; apply elements_cardinal; auto.
 Qed.

 Section Filter.
 Variable f : elt -> bool.

 Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s.
 Proof. intro. wrap filter filter_in. Qed.
 Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true.
 Proof. intro. wrap filter filter_in. Qed.
 Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
 Proof. intro. wrap filter filter_in. Qed.

 Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true.
 Proof. exact (@for_all_1 f s). Qed.
 Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s.
 Proof. exact (@for_all_2 f s). Qed.

 Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
 Proof. exact (@exists_1 f s). Qed.
 Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
 Proof. exact (@exists_2 f s). Qed.

 Lemma partition_1 : compat_bool E.eq f ->
  Equal (fst (partition f s)) (filter f s).
 Proof.
 unfold partition, filter, Equal, In; simpl ;intros H a.
 rewrite partition_in_1, filter_in; intuition.
 Qed.

 Lemma partition_2 : compat_bool E.eq f ->
  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
 Proof.
 unfold partition, filter, Equal, In; simpl ;intros H a.
 rewrite partition_in_2, filter_in; intuition.
 rewrite H2; auto.
 destruct (f a); auto.
 repeat red; intros; f_equal.
 rewrite (H _ _ H0); auto.
 Qed.

 End Filter.

 Lemma elements_1 : In x s -> InA E.eq x (elements s).
 Proof. wrap elements elements_in. Qed.
 Lemma elements_2 : InA E.eq x (elements s) -> In x s.
 Proof. wrap elements elements_in. Qed.
 Lemma elements_3 : sort E.lt (elements s).
 Proof. exact (elements_sort (is_bst s)). Qed.
 Lemma elements_3w : NoDupA E.eq (elements s).
 Proof. exact (elements_nodup (is_bst s)). Qed.

 Lemma min_elt_1 : min_elt s = Some x -> In x s.
 Proof. exact (@min_elt_1 s x). Qed.
 Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
 Proof. exact (@min_elt_2 s x y (is_bst s)). Qed.
 Lemma min_elt_3 : min_elt s = None -> Empty s.
 Proof. exact (@min_elt_3 s). Qed.

 Lemma max_elt_1 : max_elt s = Some x -> In x s.
 Proof. exact (@max_elt_1 s x). Qed.
 Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
 Proof. exact (@max_elt_2 s x y (is_bst s)). Qed.
 Lemma max_elt_3 : max_elt s = None -> Empty s.
 Proof. exact (@max_elt_3 s). Qed.

 Lemma choose_1 : choose s = Some x -> In x s.
 Proof. exact (@choose_1 s x). Qed.
 Lemma choose_2 : choose s = None -> Empty s.
 Proof. exact (@choose_2 s). Qed.
 Lemma choose_3 : choose s = Some x -> choose s' = Some y ->
  Equal s s' -> E.eq x y.
 Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed.

 Lemma eq_refl : eq s s.
 Proof. exact (eq_refl s). Qed.
 Lemma eq_sym : eq s s' -> eq s' s.
 Proof. exact (@eq_sym s s'). Qed.
 Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
 Proof. exact (@eq_trans s s' s''). Qed.

 Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
 Proof. exact (@lt_trans s s' s''). Qed.
 Lemma lt_not_eq : lt s s' -> ~eq s s'.
 Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed.

 End Specs.
End IntMake.

(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)

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


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_s_incirc_centre.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_localextension.
Require Import ProofCheckingEuclid.lemma_s_oncirc_radius.
Require Import ProofCheckingEuclid.lemma_s_outcirc_beyond_perimeter.
Require Import ProofCheckingEuclid.lemma_partnotequalwhole.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma proposition_01 :
	forall A B,
	neq A B ->
	exists X, equilateral A B X /\ Triangle A B X .
Proof.
	intros A B.
	intros neq_A_B.
	apply lemma_inequalitysymmetric in neq_A_B as neq_B_A.

	pose proof (postulate_Euclid3 A B neq_A_B) as (J & CI_J_A_AB).
	pose proof (postulate_Euclid3 B A neq_B_A) as (K & CI_K_B_BA).

	pose proof (lemma_localextension _ _ _ neq_B_A neq_A_B) as (D & BetS_B_A_D & Cong_AD_AB).

	assert (Cong B A B A) as Cong_BA_BA by (apply cn_congruencereflexive).

	pose proof (
		lemma_s_outcirc_beyond_perimeter _ _ _ _ _ _ CI_K_B_BA BetS_B_A_D Cong_BA_BA
	) as OutCirc_D_K.

	pose proof (lemma_s_incirc_centre _ _ _ _ CI_K_B_BA) as InCirc_B_K.
	pose proof (lemma_s_incirc_centre _ _ _ _ CI_J_A_AB) as InCirc_A_J.

	assert (Cong A B A B) as Cong_AB_AB by (apply cn_congruencereflexive).

	pose proof (lemma_s_oncirc_radius _ _ _ _ _ CI_J_A_AB Cong_AB_AB) as OnCirc_B_J.
	pose proof (lemma_s_oncirc_radius _ _ _ _ _ CI_J_A_AB Cong_AD_AB) as OnCirc_D_J.

	pose proof (
		postulate_circle_circle
		B A
		A B
		K J
		B D
		B A
		CI_K_B_BA
		InCirc_B_K
		OutCirc_D_K
		CI_J_A_AB
		OnCirc_B_J
		OnCirc_D_J
	) as (C & OnCirc_C_K & OnCirc_C_J).

	exists C.

	pose proof (
		axiom_circle_center_radius
		B B A K C
		CI_K_B_BA
		OnCirc_C_K
	) as Cong_BC_BA.
	apply (lemma_congruencesymmetric) in Cong_BC_BA as Cong_BA_BC.
	apply (lemma_congruenceflip) in Cong_BA_BC as (Cong_AB_CB & Cong_AB_BC & Cong_BC_CB).

	pose proof (
		axiom_circle_center_radius
		A A B J C
		CI_J_A_AB
		OnCirc_C_J
	) as Cong_AC_AB.
	apply (lemma_congruenceflip) in Cong_AC_AB as (Cong_CA_BA & Cong_CA_AB & Cong_AC_BA).
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_CA_AB Cong_AB_BC) as Cong_CA_BC.
	apply (lemma_congruencesymmetric) in Cong_CA_BC as Cong_BC_CA.

	split.
	unfold equilateral.
	split.
	exact Cong_AB_BC.
	exact Cong_BC_CA.
	(* equilateral A B X is now proven *)

	apply (lemma_congruencesymmetric) in Cong_CA_AB as Cong_AB_CA.
	apply (lemma_congruenceflip) in Cong_AB_CA as (Cong_BA_AC & Cong_BA_CA & Cong_AB_AC).
	pose proof (axiom_nocollapse A B A C neq_A_B Cong_AB_AC) as neq_A_C.
	pose proof (axiom_nocollapse A B B C neq_A_B Cong_AB_BC) as neq_B_C.

	assert (~ BetS A C B) as nBetS_A_C_B.
	{
		intro BetS_A_C_B.

		pose proof (lemma_partnotequalwhole _ _ _ BetS_A_C_B) as nCong_AC_AB.
		pose proof (cn_congruencereverse C A) as Cong_CA_AC.
		pose proof (cn_congruencereverse A C) as Cong_AC_CA.
		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_AC_CA Cong_CA_AB) as Cong_AC_AB.

		contradict Cong_AC_AB.
		exact nCong_AC_AB.
	}
	assert (~ BetS A B C) as nBetS_A_B_C.
	{
		intro BetS_A_B_C.

		pose proof (lemma_partnotequalwhole _ _ _ BetS_A_B_C) as nCong_AB_AC.

		contradict Cong_AB_AC.
		exact nCong_AB_AC.
	}
	assert (~ BetS B A C) as nBetS_B_A_C.
	{
		intro BetS_B_A_C.

		pose proof (lemma_partnotequalwhole _ _ _ BetS_B_A_C) as nCong_BA_BC.
		apply lemma_congruencesymmetric in Cong_BC_BA as Cong_BA_BC.

		contradict Cong_BA_BC.
		exact nCong_BA_BC.
	}

	unfold Triangle.
	unfold nCol.
	repeat split.
	exact neq_A_B.
	exact neq_A_C.
	exact neq_B_C.
	exact nBetS_A_B_C.
	exact nBetS_A_C_B.
	exact nBetS_B_A_C.
Qed.

End Euclid.


From Coqprime Require Import PocklingtonRefl.
From mathcomp Require Import ssreflect ssrbool prime.
From Tweetnacl.High Require Export prime_cert prime_ssrprime.
Local Open Scope positive_scope.

Require Import Znat.
Require Import ZArith.Zpow_facts.

Lemma inj_pow : forall n m : nat, Z.of_nat (n ^ m) = (Z.of_nat n ^ Z.of_nat m)%Z.
Proof.
  intros. induction m.
  + reflexivity.
  + rewrite Nat.pow_succ_r; [|apply Nat.le_0_l].
    rewrite Nat2Z.inj_mul.
    rewrite IHm.
    rewrite Nat2Z.inj_succ.
    rewrite Z.pow_succ_r; [|apply Nat2Z.is_nonneg].
    reflexivity.
Qed.

Lemma Zof_nat_25519 : Z.of_nat (2^255 - 19) = 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z.
Proof.
  rewrite Nat2Z.inj_sub.
  + rewrite inj_pow. reflexivity.
  + assert (19 <= 2^5)%nat. apply Nat.leb_le. reflexivity.
    eapply Nat.le_trans. exact H.
    apply Nat.pow_le_mono_r. discriminate. apply Nat.leb_le. reflexivity.
Qed.

Lemma curve25519_prime : prime (2^255 - 19).
Proof. apply: prime_ssrprime ; rewrite Zof_nat_25519; exact: primo. Qed.

Lemma curve25519_numtheory_prime : Znumtheory.prime (2^255 - 19).
Proof. change (2^255 - 19)%Z with 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z. exact: primo. Qed.

Lemma ZmodP_mod2_eq_1: BinInt.Z.modulo (2^255 - 19) 2 = 1%Z.
Proof. done. Qed.

Lemma legendre_compute:
(-1 mod (2 ^ 255 - 19))%Z = 236839902240 ^ ((locked (2 ^ 255 - 19)%Z - 1) / 2) mod locked (2 ^ 255 - 19)%Z.
Proof.
rewrite -Zpow_mod_correct -lock ; vm_compute ; congruence.
Qed.

Lemma legendre_compute2:
(-1 mod (2 ^ 255 - 19))%Z = (2 mod (2 ^ 255 - 19)) ^ ((locked (2 ^ 255 - 19)%Z - 1) / 2) mod locked (2 ^ 255 - 19)%Z.
Proof.
rewrite -Zpow_mod_correct -lock ; vm_compute ; congruence.
Qed.

Lemma legendre_compute28948022309329048855892746252171976963317496166410141009864396001978282409975:
(-1 mod (2 ^ 255 - 19))%Z = (28948022309329048855892746252171976963317496166410141009864396001978282409975 mod (2 ^ 255 - 19)) ^ ((locked (2 ^ 255 - 19)%Z - 1) / 2) mod locked (2 ^ 255 - 19)%Z.
Proof.
rewrite -Zpow_mod_correct -lock ; vm_compute ; congruence.
Qed.


Require Import Coq.ZArith.Zpower Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil.
Require Import Crypto.ModularArithmetic.PrimeFieldTheorems.
Require Import Crypto.Tactics.VerdiTactics.
Require Import Crypto.ModularArithmetic.Pow2Base.
Require Import Crypto.ModularArithmetic.Pow2BaseProofs.
Require Import Crypto.BaseSystemProofs.
Require Crypto.BaseSystem.
Local Open Scope Z_scope.

Section ExtendedBaseVector.
  Context (limb_widths : list Z)
          (limb_widths_nonnegative : forall x, In x limb_widths -> 0 <= x).
  Local Notation k := (sum_firstn limb_widths (length limb_widths)).
  Local Notation base := (base_from_limb_widths limb_widths).

  (* This section defines a new BaseVector that has double the length of the BaseVector
  * used to construct [params]. The coefficients of the new vector are as follows:
  *
  * ext_base[i] = if (i < length base) then base[i] else 2^k * base[i]
  *
  * The purpose of this construction is that it allows us to multiply numbers expressed
  * using [base], obtaining a number expressed using [ext_base]. (Numbers are "expressed" as
  * vectors of digits; the value of a digit vector is obtained by doing a dot product with
  * the base vector.) So if x, y are digit vectors:
  *
  * (x \dot base) * (y \dot base) = (z \dot ext_base)
  *
  * Then we can separate z into its first and second halves:
  *
  * (z \dot ext_base) = (z1 \dot base) + (2 ^ k) * (z2 \dot base)
  *
  * Now, if we want to reduce the product modulo 2 ^ k - c:
  *
  * (z \dot ext_base) mod (2^k-c)= (z1 \dot base) + (2 ^ k) * (z2 \dot base) mod (2^k-c)
  * (z \dot ext_base) mod (2^k-c)= (z1 \dot base) + c * (z2 \dot base) mod (2^k-c)
  *
  * This sum may be short enough to express using base; if not, we can reduce again.
  *)
  Definition ext_limb_widths := limb_widths ++ limb_widths.
  Definition ext_base := base_from_limb_widths ext_limb_widths.
  Lemma ext_base_alt : ext_base = base ++ (map (Z.mul (2^k)) base).
  Proof.
    unfold ext_base, ext_limb_widths.
    rewrite base_from_limb_widths_app by auto.
    rewrite two_p_equiv.
    reflexivity.
  Qed.

  Lemma ext_base_positive : forall b, In b ext_base -> b > 0.
  Proof.
    apply base_positive; unfold ext_limb_widths.
    intros ? H. apply in_app_or in H; destruct H; auto.
  Qed.

  Lemma b0_1 : forall x, nth_default x base 0 = 1 -> nth_default x ext_base 0 = 1.
  Proof.
    intros. rewrite ext_base_alt, nth_default_app.
    destruct base; assumption.
  Qed.

  Lemma map_nth_default_base_high : forall n, (n < (length base))%nat ->
    nth_default 0 (map (Z.mul (2 ^ k)) base) n =
    (2 ^ k) * (nth_default 0 base n).
  Proof.
    intros.
    erewrite map_nth_default; auto.
  Qed.

  Lemma ext_limb_widths_nonneg
        (limb_widths_nonneg : forall w : Z, In w limb_widths -> 0 <= w)
    : forall w : Z, In w ext_limb_widths -> 0 <= w.
  Proof.
    unfold ext_limb_widths; setoid_rewrite in_app_iff.
    intros ? [?|?]; auto.
  Qed.

  Lemma ext_limb_widths_upper_bound
    : upper_bound ext_limb_widths = upper_bound limb_widths * upper_bound limb_widths.
  Proof.
    unfold ext_limb_widths.
    autorewrite with push_upper_bound; reflexivity.
  Qed.

  Section base_good.
    Context (two_k_nonzero : 2^k <> 0)
            (base_good : forall i j, (i+j < length base)%nat ->
                                     let b := nth_default 0 base in
                                     let r := (b i * b j) / b (i+j)%nat in
                                     b i * b j = r * b (i+j)%nat)
            (limb_widths_match_modulus : forall i j,
                (i < length limb_widths)%nat ->
                (j < length limb_widths)%nat ->
                (i + j >= length limb_widths)%nat ->
                let w_sum := sum_firstn limb_widths in
                k + w_sum (i + j - length limb_widths)%nat <= w_sum i + w_sum j).

    Lemma base_good_over_boundary
      : forall (i : nat)
               (l : (i < length base)%nat)
               (j' : nat)
               (Hj': (i + j' < length base)%nat),
        2 ^ k * (nth_default 0 base i * nth_default 0 base j') =
        (2 ^ k * (nth_default 0 base i * nth_default 0 base j'))
          / (2 ^ k * nth_default 0 base (i + j')) *
        (2 ^ k * nth_default 0 base (i + j')).
    Proof.
      clear limb_widths_match_modulus.
      intros.
      remember (nth_default 0 base) as b.
      rewrite Zdiv_mult_cancel_l by (exact two_k_nonzero).
      replace (b i * b j' / b (i + j')%nat * (2 ^ k * b (i + j')%nat))
      with  ((2 ^ k * (b (i + j')%nat * (b i * b j' / b (i + j')%nat)))) by ring.
      rewrite Z.mul_cancel_l by (exact two_k_nonzero).
      replace (b (i + j')%nat * (b i * b j' / b (i + j')%nat))
      with ((b i * b j' / b (i + j')%nat) * b (i + j')%nat) by ring.
      subst b.
      apply (base_good i j'); omega.
    Qed.

    Lemma ext_base_good :
      forall i j, (i+j < length ext_base)%nat ->
                  let b := nth_default 0 ext_base in
                  let r := (b i * b j) / b (i+j)%nat in
                  b i * b j = r * b (i+j)%nat.
    Proof.
      intros.
      subst b. subst r.
      rewrite ext_base_alt in *.
      rewrite app_length in H; rewrite map_length in H.
      repeat rewrite nth_default_app.
      repeat break_if; try omega.
      { (* i < length base, j < length base, i + j < length base *)
        auto using BaseSystem.base_good.
      } { (* i < length base, j < length base, i + j >= length base *)
        rewrite (map_nth_default _ _ _ _ 0) by omega.
        apply base_matches_modulus; auto using limb_widths_nonnegative, limb_widths_match_modulus;
        distr_length.
        assumption.
      } { (* i < length base, j >= length base, i + j >= length base *)
        do 2 rewrite map_nth_default_base_high by omega.
        remember (j - length base)%nat as j'.
        replace (i + j - length base)%nat with (i + j')%nat by omega.
        replace (nth_default 0 base i * (2 ^ k * nth_default 0 base j'))
        with (2 ^ k * (nth_default 0 base i * nth_default 0 base j'))
          by ring.
        eapply base_good_over_boundary; eauto; omega.
      } { (* i >= length base, j < length base, i + j >= length base *)
        do 2 rewrite map_nth_default_base_high by omega.
        remember (i - length base)%nat as i'.
        replace (i + j - length base)%nat with (j + i')%nat by omega.
        replace (2 ^ k * nth_default 0 base i' * nth_default 0 base j)
        with (2 ^ k * (nth_default 0 base j * nth_default 0 base i'))
          by ring.
        eapply base_good_over_boundary; eauto; omega.
      }
    Qed.
  End base_good.

  Lemma extended_base_length:
      length ext_base = (length base + length base)%nat.
  Proof.
    clear limb_widths_nonnegative.
    unfold ext_base, ext_limb_widths; autorewrite with distr_length; reflexivity.
  Qed.

  Lemma firstn_us_base_ext_base : forall (us : BaseSystem.digits),
      (length us <= length base)%nat
      -> firstn (length us) base = firstn (length us) ext_base.
  Proof.
    rewrite ext_base_alt; intros.
    rewrite firstn_app_inleft; auto; omega.
  Qed.

  Lemma decode_short : forall (us : BaseSystem.digits),
    (length us <= length base)%nat ->
    BaseSystem.decode base us = BaseSystem.decode ext_base us.
  Proof. auto using decode_short_initial, firstn_us_base_ext_base. Qed.

  Section BaseVector.
    Context {bv : BaseSystem.BaseVector base}
            (limb_widths_match_modulus : forall i j,
                (i < length limb_widths)%nat ->
                (j < length limb_widths)%nat ->
                (i + j >= length limb_widths)%nat ->
                let w_sum := sum_firstn limb_widths in
                k + w_sum (i + j - length limb_widths)%nat <= w_sum i + w_sum j).

    Instance ExtBaseVector : BaseSystem.BaseVector ext_base :=
      { base_positive := ext_base_positive;
        b0_1 x := b0_1 x (BaseSystem.b0_1 _);
        base_good := ext_base_good (two_sum_firstn_limb_widths_nonzero limb_widths_nonnegative _) BaseSystem.base_good limb_widths_match_modulus }.
  End BaseVector.
End ExtendedBaseVector.

Hint Rewrite @extended_base_length : distr_length.
Hint Resolve ext_limb_widths_nonneg : znonzero.
Hint Rewrite @ext_limb_widths_upper_bound using solve [ eauto with znonzero ] : push_upper_bound.
Hint Rewrite <- @ext_limb_widths_upper_bound using solve [ eauto with znonzero ] : pull_upper_bound.


Theorem leb_iff : forall n m,
  n <=? m = true <-> n <= m.
Proof.
  intros.
  split.
  - apply leb_complete.
  - apply leb_correct.
Qed.


From Coq Require Import
  ZArith.
From DEZ.Has Require Export
  GroupOperation.

Import Pos.

Definition popr {A : Type} {has_opr : HasOpr A} (n : positive) (x : A) : A :=
  iter_op opr n x.


Lemma eqSet (X:Type) (A B:X->Prop) :
  (forall x, B x <-> False) <->
  (forall x, ((A x /\ ~ B x) \/ (B x /\ ~ A x)) <-> A x).
Proof.
  split.
  - intros H x. split.
    + intros [[]|[]].
      * exact H0.
      * destruct(H x).
        destruct (H2 H0).
    + intros H0.
      assert(~B x).
      {
        intros H1. destruct (H x).
        now apply H2.
      }
      left.
      now split.
  - intros H x.
    split;intros H0.
    + specialize (H x).
      assert(~A x).
      {
        intros H1.
        destruct H.
        specialize (H2 H1) as [[]|[]].
        - now apply H3.
        - now apply H3.
      }
      apply H1.
      apply H.
      right. now split.
    + destruct H0.
Qed.

Goal forall (X:Type) (A:X->Prop) (f:X->X->X),
    (forall x y, exists z, f x z = y) -> forall x y, exists z, f x (f y z)=x.
Proof.
  intros.
  destruct (H x x) as [].
  destruct (H y x0) as [].
  exists x1.
  now rewrite H1, H0.
Qed.


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

Require Export Cring.

(* Definition of integral domains: commutative ring without zero divisor *)

Class Integral_domain {R : Type}`{Rcr:Cring R} := {
 integral_domain_product:
   forall x y, x * y == 0 -> x == 0 \/ y == 0;
 integral_domain_one_zero: not (1 == 0)}.

Section integral_domain.

Context {R:Type}`{Rid:Integral_domain R}.

Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0.
red;intro. apply integral_domain_one_zero.
assert (0 == - (0:R)). cring.
rewrite H0. rewrite <- H. cring.
Qed.

Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N.of_nat n).

Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0.
induction n. unfold pow; simpl. intros. absurd (1 == 0).
simpl. apply integral_domain_one_zero.
 trivial. setoid_replace (pow p (S n)) with (p * (pow p n)).
intros.
case (integral_domain_product p (pow p n) H). trivial. trivial.
unfold pow; simpl.
clear IHn. induction n; simpl; try cring.
 rewrite Ring_theory.pow_pos_succ. cring. apply ring_setoid.
apply ring_mult_comp.
apply ring_mul_assoc.
Qed.

Lemma Rintegral_domain_pow:
  forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0.
intros. case (integral_domain_product c (pow p r) H0). intros; absurd (c == ring0); auto.
intros. apply pow_not_zero with r. trivial. Qed.

End integral_domain.