(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Max.

From Undecidability.Shared.Libs.DLW
  Require Import utils pos vec subcode sss.

From Undecidability.MinskyMachines
  Require Import env mm_defs mme_defs mme_utils.

From Undecidability.MuRec.Util
  Require Import recalg ra_mm_env.

Set Implicit Arguments.

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "i /e/ s '-1>' t" := (mm_sss_env eq_nat_dec i s t)  (at level 70, no associativity).
Local Notation "P /e/ s ->> t" := (sss_compute (mm_sss_env eq_nat_dec) P s t) (at level 70, no associativity).
Local Notation "P /e/ s ~~> t" := (sss_output (mm_sss_env eq_nat_dec) P s t) (at level 70, no associativity).
Local Notation "P /e/ s -[ k ]-> t" := (sss_steps (mm_sss_env eq_nat_dec) P k s t) (at level 70, no associativity).
Local Notation "P /e/ s ↓" := (sss_terminates (mm_sss_env eq_nat_dec) P s) (at level 70, no associativity).

Local Notation "i /v/ s '-1>' t" := (@mm_sss _ i s t)  (at level 70, no associativity).
Local Notation "P /v/ s ->> t" := (sss_compute (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P /v/ s ~~> t" := (sss_output (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P /v/ s -[ k ]-> t" := (sss_steps (@mm_sss _) P k s t) (at level 70, no associativity).
Local Notation "P /v/ s ↓" := (sss_terminates (@mm_sss _) P s) (at level 70, no associativity).

Local Notation " e ⇢ x " := (@get_env _ _ e x).
Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ eq_nat_dec e x v).

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Section mm_nat_pos.

  Definition mm_var_map (X Y : Set) (f : X -> Y) (i : mm_instr X) :=
    match i with
      | INC x   => INC (f x)
      | DEC x p => DEC (f x) p
    end.

  Definition mm_instr_var X (i : mm_instr X) :=
    match i with
      | INC x => x
      | DEC x _ => x
    end.

  Definition mm_linstr_vars X := map (@mm_instr_var X).

  Definition mm_pos_nat n := map (mm_var_map (@pos2nat n)).

  Definition mm_nat_pos_full n l : Forall (fun x => x < n) (mm_linstr_vars l) -> { m | l = @mm_pos_nat n m }.
  Proof.
    induction l as [ | [ x | x p ] l IHl ]; simpl; intros H.
    { exists nil; auto. }
    1,2: rewrite Forall_cons_inv in H; destruct H as [ H1 H2 ];
         destruct (IHl H2) as (m & Hm).
    + exists (INC (nat2pos H1) :: m); simpl; f_equal; auto; f_equal.
      rewrite pos2nat_nat2pos; auto.
    + exists (DEC (nat2pos H1) p :: m); simpl; f_equal; auto; f_equal.
      rewrite pos2nat_nat2pos; auto.
  Qed.

  Definition mm_nat_bound l := S (lmax (mm_linstr_vars l)).

  Fact mm_nat_bound_spec l : Forall (fun x => x < mm_nat_bound l) (mm_linstr_vars l).
  Proof.
    cut (Forall (fun x => x <= lmax (mm_linstr_vars l)) (mm_linstr_vars l)).
    + apply Forall_impl; intros; unfold mm_nat_bound; lia.
    + apply lmax_spec; auto.
  Qed.

  Definition mm_nat_pos n l : mm_nat_bound l <= n -> { m | l = @mm_pos_nat n m }.
  Proof.
    intros H; apply mm_nat_pos_full.
    generalize (mm_nat_bound_spec l).
    apply Forall_impl; intros; lia.
  Qed.

End mm_nat_pos.

Section mm_pos_nat_sem.

  Variable (n : nat).

  Implicit Types (e : nat -> nat) (v : vec nat n).

  Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew env.

  Notation "v '⋈' e" := (forall p, vec_pos v p = e⇢pos2nat p) (at level 70, no associativity).

  Fact sss_mm_pos_nat rho st1 st2 e1 :
            snd st1 ⋈ e1
         -> rho /v/ st1 -1> st2
         -> exists e2, snd st2 ⋈ e2
                    /\ mm_var_map (@pos2nat n) rho /e/ (fst st1,e1) -1> (fst st2,e2).
  Proof.
    revert st1 st2; intros (j1,v1) (j2,v2); simpl.
    intros H1 H2.
    destruct rho as [ x | x p ]; simpl in *;
      [ | case_eq (vec_pos v1 x); [ intros He1 | intros q Hq ] ].
    - exists (e1⦃pos2nat x ⇠ S (e1⇢pos2nat x)⦄).
      apply mm_sss_INC_inv in H2.
      destruct H2 as (? & ?); subst; split.
      2: constructor.
      intros p.
      destruct (pos_eq_dec x p) as [ -> | C ]; rew vec; rew env.
      rewrite H1; assert (pos2nat x <> pos2nat p); rew env.
      contradict C; revert C; apply pos2nat_inj.
    - exists e1.
      apply mm_sss_DEC0_inv in H2; destruct H2; subst; auto.
      split; auto; constructor; rewrite <- H1; auto.
    - exists (e1⦃pos2nat x ⇠ q⦄).
      apply mm_sss_DEC1_inv with (1 := Hq) in H2.
      destruct H2; subst; split.
      2: constructor; rewrite <- H1; auto.
      intros j.
      destruct (pos_eq_dec x j) as [ -> | C ]; rew vec; rew env.
      rewrite H1; assert (pos2nat x <> pos2nat j); rew env.
      contradict C; revert C; apply pos2nat_inj.
  Qed.

  Fact sss_mm_pos_nat_inv rho st1 st2 v1 :
            v1 ⋈ snd st1
         -> mm_var_map (@pos2nat n) rho /e/ st1 -1> st2
         -> exists v2, v2 ⋈ snd (st2)
                    /\ rho /v/ (fst st1,v1) -1> (fst st2,v2).
  Proof.
    revert st1 st2; intros (j1,e1) (j2,e2); simpl.
    intros H1 H2.
    destruct rho as [ x | x p ]; simpl in *;
      [ | case_eq (e1⇢pos2nat x); [ intros He1 | intros q Hq ] ].
    - exists (vec_change v1 x (S (vec_pos v1 x))).
      apply mm_sss_env_INC_inv in H2.
      destruct H2 as (? & ?); subst; split.
      2: constructor.
      intros p.
      destruct (pos_eq_dec x p) as [ -> | C ]; rew vec; rew env.
      rewrite H1; assert (pos2nat x <> pos2nat p); rew env.
      contradict C; revert C; apply pos2nat_inj.
    - exists v1.
      apply mm_sss_env_DEC0_inv in H2; destruct H2; subst; auto.
      split; auto; constructor; rewrite H1; auto.
    - exists (vec_change v1 x q).
      apply mm_sss_env_DEC1_inv with (1 := Hq) in H2.
      destruct H2; subst; split.
      2: constructor; rewrite H1; auto.
      intros j.
      destruct (pos_eq_dec x j) as [ -> | C ]; rew vec; rew env.
      rewrite H1; assert (pos2nat x <> pos2nat j); rew env.
      contradict C; revert C; apply pos2nat_inj.
  Qed.

  Fact sss_steps_mm_pos_nat i P k st1 st2 e1 :
            snd st1 ⋈ e1
         -> (i,P) /v/ st1 -[k]-> st2
         -> exists e2, snd st2 ⋈ e2
                    /\ (i,@mm_pos_nat n P) /e/ (fst st1,e1) -[k]-> (fst st2,e2).
  Proof.
    intros H1 H2; revert H2 e1 H1.
    induction 1 as [ (j,v) | k (j1,v1) (j2,v2) (j3,v3) H1 H2 IH2 ];
      simpl; intros e1 H3.
    + exists e1; split; auto; constructor.
    + destruct H1 as (q & l & rho & r & e & [= <- G2] & [= -> <-] & G3).
      destruct sss_mm_pos_nat with (2 := G3) (1 := H3) as (e2 & G4 & G5); simpl in *.
      destruct IH2 with (1 := G4) as (e3 & G6 & G7).
      exists e3; split; auto.
      constructor 2 with (st2 := (j2,e2)); auto.
      exists i, (mm_pos_nat l), (mm_var_map (@pos2nat _) rho), (mm_pos_nat r), e1; msplit 2; auto.
      * f_equal; subst P; unfold mm_pos_nat; repeat (rewrite map_app; simpl); auto.
      * unfold mm_pos_nat; rew length; auto.
  Qed.

  Fact sss_steps_mm_pos_nat_inv i P k st1 st2 v1 :
            v1 ⋈ snd st1
         -> (i,@mm_pos_nat n P) /e/ st1 -[k]-> st2
         -> exists v2, v2 ⋈ snd (st2)
                    /\ (i,P) /v/ (fst st1,v1) -[k]-> (fst st2,v2).
  Proof.
    intros H1 H2; revert H2 v1 H1.
    induction 1 as [ (j,e) | k (j1,e1) (j2,e2) (j3,e3) H1 H2 IH2 ];
      simpl; intros v1 H3.
    + exists v1; split; auto; constructor.
    + destruct H1 as (q & l & rho & r & e & [= <- G2] & [= -> <-] & G3).
      unfold mm_pos_nat in G2; apply map_middle_inv in G2.
      destruct G2 as (l' & rho' & r' & G2 & G4 & G5 & G6).
      subst rho l r.
      destruct sss_mm_pos_nat_inv with (2 := G3) (1 := H3) as (v2 & G7 & G8); simpl in *.
      destruct IH2 with (1 := G7) as (v3 & G9 & G10).
      exists v3; split; auto.
      constructor 2 with (st2 := (j2,v2)); auto.
      exists i, l', rho', r', v1; msplit 2; subst; auto; rew length; auto.
  Qed.

End mm_pos_nat_sem.

Section ra_mm_comp.

  Theorem ra_mm_compiler (n : nat) (f : recalg n) :
      { m & { P : list (mm_instr (pos (n+S m)))
            |  (forall x v, ⟦f⟧ v x -> (1,P) /v/ (1,vec_app v vec_zero) ->> (1+length P,vec_app v (x##vec_zero)))
            /\ (forall v, (1,P) /v/ (1,vec_app v vec_zero) ↓ -> ex (⟦f⟧ v)) } }.
  Proof.
    destruct ra_mm_env_simulator with (f := f) as (P & HP).
    set (k := Nat.max (S n) (mm_nat_bound P)).
    assert (S n <= k) as H3 by apply Nat.le_max_l.
    assert { m | k = n+S m } as H4.
    { exists (k-S n); lia. }
    clear H3.
    destruct H4 as (m & Hm).
    exists m.
    destruct mm_nat_pos with (n := k) (l := P) as (Q & HQ).
    + apply Nat.le_max_r.
    + revert Q HQ; rewrite Hm; clear k Hm; intros Q HQ.
      exists Q; split.
      * intros x v H.
        destruct (HP v (fun j => match le_lt_dec n j with left _ => 0 | right Hj => vec_pos v (nat2pos Hj) end))
          as [ H1 _ ].
        - intros p; generalize (pos2nat_prop p); intros H0; unfold get_env.
          destruct (le_lt_dec n (pos2nat p)); try lia.
          f_equal; apply nat2pos_pos2nat.
        - intros j Hj; unfold get_env.
          destruct (le_lt_dec n j); lia.
        - destruct (H1 _ H) as (e' & G1 & k & G2); auto.
          exists k.
          rewrite HQ in G2 at 1.
          apply sss_steps_mm_pos_nat_inv with (v1 := vec_app v vec_zero) in G2.
          ++ destruct G2 as (v2 & G2 & G3); simpl in G3.
             eq goal G3; do 2 f_equal.
             { rewrite HQ; unfold mm_pos_nat; rewrite map_length; auto. }
             apply vec_pos_ext, pos_left_right_rect.
             ** intros p; rewrite G2, vec_pos_app_left, G1; simpl.
                rewrite pos2nat_left.
                generalize (pos2nat_prop p); intros G4.
                rewrite get_set_env_neq; try lia.
                unfold get_env.
                destruct (le_lt_dec n (pos2nat p)); try lia.
                f_equal; apply nat2pos_pos2nat.
             ** intros p.
                rewrite vec_pos_app_right, G2, pos2nat_right; simpl snd.
                rewrite Nat.add_comm.
                analyse pos p.
                -- rewrite pos2nat_fst; simpl.
                   rewrite G1; rew env.
                -- rewrite pos2nat_nxt; simpl.
                   unfold vec_zero; rewrite vec_pos_set.
                   rewrite G1, get_set_env_neq; try lia.
                   unfold get_env; simpl.
                   destruct (le_lt_dec n (S (pos2nat p+n))); lia.
          ++ simpl; apply pos_left_right_rect.
             ** intros p; rewrite vec_pos_app_left, pos2nat_left.
                unfold get_env.
                generalize (pos2nat_prop p); intros.
                destruct (le_lt_dec n (pos2nat p)); try lia; f_equal.
                rewrite nat2pos_pos2nat; auto.
             ** intros p; rewrite vec_pos_app_right, pos2nat_right.
                unfold vec_zero; rewrite vec_pos_set.
                unfold get_env.
                destruct (le_lt_dec n (n+pos2nat p)); try lia.
      * intros v ((j,w) & (k & G1) & G2); simpl in G2.
        set (e1 := fun j => match le_lt_dec n j with left _ => 0 | right Hj => vec_pos v (nat2pos Hj) end).
        apply sss_steps_mm_pos_nat with (e1 := e1) in G1.
        destruct G1 as (e2 & G1 & G3); simpl in G3.
        apply HP with e1.
        - intros p; unfold e1, get_env.
          generalize (pos2nat_prop p); intros.
          destruct (le_lt_dec n (pos2nat p)); try lia.
          rewrite nat2pos_pos2nat; auto.
        - intros p Hp.
          unfold e1, get_env.
          destruct (le_lt_dec n p); lia.
        - rewrite HQ; exists (j,e2); split.
          ++ exists k; auto.
          ++ simpl; unfold mm_pos_nat; rew length; auto.
        - simpl; apply pos_left_right_rect.
          ++ intros p; rewrite vec_pos_app_left, pos2nat_left.
             unfold e1, get_env.
             generalize (pos2nat_prop p); intros.
             destruct (le_lt_dec n (pos2nat p)); try lia.
             rewrite nat2pos_pos2nat; auto.
          ++ intros p; rewrite vec_pos_app_right, pos2nat_right, vec_zero_spec.
             unfold e1, get_env.
             destruct (le_lt_dec n (n+pos2nat p)); try lia.
  Qed.

End ra_mm_comp.


Require Export Coq.Unicode.Utf8.
Require Export F.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _  => True
    | tabs _   => True
    | _        => False
  end.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | tapptabs {T2 t11} :
      red (tapp (tabs t11) T2) (tsubstTm X0 T2 t11)
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tapp t1 T2) (tapp t1' T2).


(* Version: 23.04. *)

(** * Preliminaries by Autosubst *)

(** ** Axiomatic Assumptions
    For our development, we have to extend Coq with _functional extensionality_.
*)

(* ** Functional Extensionality
    We import the axiom from the Coq Standard Library and derive a utility tactic to make the assumption practically usable.
*)
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Program.Tactics.

Tactic Notation "nointr" tactic(t) :=
  let m := fresh "marker" in
  pose (m := tt);
  t; revert_until m; clear m.

Ltac fext := nointr repeat (
  match goal with
    [ |- ?x = ?y ] =>
    (refine (@functional_extensionality_dep _ _ _ _ _) ||
     refine (@forall_extensionality _ _ _ _) ||
     refine (@forall_extensionalityP _ _ _ _) ||
     refine (@forall_extensionalityS _ _ _ _)); intro
  end).

(* ** Propositional Extensionality
    We state the axiom of _propositional extensionality_ directly and use it to prove _proof irrelevance_.
*)
Axiom pext : forall P Q : Prop, (P <-> Q) -> (P = Q).

Lemma pi {P : Prop} (p q : P) : p = q.
Proof.
  assert (P = True) by (apply pext; tauto). subst. now destruct p,q.
Qed.

(* **** Functor Instances *)

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

(* **** Vector Instance *)
Require Export Vector.

Definition vec_ext {A B n} {f g : A -> B} :
  (forall x, f x = g x) -> forall xs : Vector.t A n, Vector.map f xs = Vector.map g xs.
  intros H. induction xs. reflexivity.
  cbn. f_equal. apply H. apply IHxs.
Defined.

Definition vec_id {A n} { f : A -> A} :
  (forall x, f x = x) -> forall xs : Vector.t A n, Vector.map f xs = xs.
Proof.
  intros H. induction xs. reflexivity.
  cbn. rewrite H. rewrite IHxs; eauto.
Defined.

Definition vec_comp {A B C n} {f: A -> B} {g: B -> C} {h} :
  (forall x, (funcomp  g f) x = h x) -> forall xs : Vector.t A n, map g (map f xs) = map h xs.
Proof.
  induction xs. reflexivity.
  cbn. rewrite <- H. f_equal. apply IHxs.
Defined.

(* **** List Instance *)
Require Export List.

Definition list_ext {A B} {f g : A -> B} :
  (forall x, f x = g x) -> forall xs,  map f xs = map g xs.
  intros H. induction xs. reflexivity.
  cbn. f_equal. apply H. apply IHxs.
Defined.

Definition list_id {A}  { f : A -> A} :
  (forall x, f x = x) -> forall xs, List.map f xs = xs.
Proof.
  intros H. induction xs. reflexivity.
  cbn. rewrite H. rewrite IHxs; eauto.
Defined.

Definition list_comp {A B C} {f: A -> B} {g: B -> C} {h} :
  (forall x, (funcomp  g f) x = h x) -> forall xs, map g (map f xs) = map h xs.
Proof.
  induction xs. reflexivity.
  cbn. rewrite <- H. f_equal. apply IHxs.
Defined.

(* **** Prod Instance *)

Definition prod_map {A B C D} (f : A -> C) (g : B -> D) (p : A * B) :
  C * D.
Proof.
  destruct p. split. auto. auto.
Defined.

Definition prod_id {A B} {f : A -> A} {g : B -> B} :
  (forall x, f x = x) -> (forall x, g x = x) -> forall p, prod_map f g p = p.
Proof.
  intros. destruct p. cbn. f_equal; auto.
Defined.

Definition prod_ext {A B C D} {f f' : A -> C} {g g': B -> D} :
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> forall p, prod_map f g p = prod_map f' g' p.
Proof.
  intros. destruct p. cbn. f_equal; auto.
Defined.

Definition prod_comp {A B C D E F} {f1 : A -> C} {g1 : C -> E} { h1} {f2: B -> D} {g2: D -> F} {h2}:
  (forall x, (funcomp  g1 f1) x = h1 x) -> (forall x, (funcomp g2 f2) x = h2 x) -> forall p, prod_map g1 g2 (prod_map f1 f2 p) = prod_map h1 h2 p.
Proof.
  intros. destruct p. cbn. f_equal; auto.
  now rewrite <- H. now rewrite <- H0.
Defined.

(* **** Function Instance *)

Definition cod X A:  Type :=  X -> A.

Definition cod_map {X} {A B} (f : A -> B) (p : X -> A) :
  X -> B.
Proof. eauto. Defined.

(* Requires functional extensionality. *)
Definition cod_id {X} {A} {f : A -> A} :
  (forall x, f x = x) -> forall (p: X -> A), cod_map f p = p.
Proof. intros H p. unfold cod_map. fext. congruence. Defined.

Definition cod_ext {X} {A B} {f f' : A -> B} :
  (forall x, f x = f' x) -> forall (p: X -> A), cod_map f p = cod_map f' p.
Proof. intros H p. unfold cod_map. fext. congruence. Defined.

Definition cod_ext' {X} {A B} {f f' : A -> B} (p : X -> A) :
  (forall x, f (p x) = f' (p x)) -> cod_map f p = cod_map f' p.
Proof. intros H. unfold cod_map. fext. congruence. Defined.

Definition cod_comp {X} {A B C} {f : A -> B} {g : B -> C} {h} :
  (forall x, (funcomp g f) x =  h x) -> forall (p: X -> _), cod_map g (cod_map f p) = cod_map h p.
Proof. intros H p. unfold cod_map. fext. intros x. now rewrite <- H. Defined.

Hint Rewrite in_map_iff : FunctorInstances.


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

(** * MSetGenTree : sets via generic trees

    This module factorizes common parts in implementations
    of finite sets as AVL trees and as Red-Black trees. The nodes
    of the trees defined here include an generic information
    parameter, that will be the heigth in AVL trees and the color
    in Red-Black trees. Without more details here about these
    information parameters, trees here are not known to be
    well-balanced, but simply binary-search-trees.

    The operations we could define and prove correct here are the
    one that do not build non-empty trees, but only analyze them :

     - empty is_empty
     - mem
     - compare equal subset
     - fold cardinal elements
     - for_all exists_
     - min_elt max_elt choose
*)

Require Import Orders OrdersFacts MSetInterface NPeano.
Local Open Scope list_scope.
Local Open Scope lazy_bool_scope.

(* For nicer extraction, we create induction principles
   only when needed *)
Local Unset Elimination Schemes.

Module Type InfoTyp.
 Parameter t : Set.
End InfoTyp.

(** * Ops : the pure functions *)

Module Type Ops (X:OrderedType)(Info:InfoTyp).

Definition elt := X.t.
Hint Transparent elt.

Inductive tree  : Type :=
| Leaf : tree
| Node : Info.t -> tree -> X.t -> tree -> tree.

(** ** The empty set and emptyness test *)

Definition empty := Leaf.

Definition is_empty t :=
 match t with
 | Leaf => true
 | _ => false
 end.

(** ** Membership test *)

(** The [mem] function is deciding membership. It exploits the
    binary search tree invariant to achieve logarithmic complexity. *)

Fixpoint mem x t :=
 match t with
 | Leaf => false
 | Node _ l k r =>
   match X.compare x k with
     | Lt => mem x l
     | Eq => true
     | Gt => mem x r
   end
 end.

(** ** Minimal, maximal, arbitrary elements *)

Fixpoint min_elt (t : tree) : option elt :=
 match t with
 | Leaf => None
 | Node _ Leaf x r => Some x
 | Node _ l x r => min_elt l
 end.

Fixpoint max_elt (t : tree) : option elt :=
  match t with
  | Leaf => None
  | Node _ l x Leaf => Some x
  | Node _ l x r => max_elt r
  end.

Definition choose := min_elt.

(** ** Iteration on elements *)

Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A :=
  match t with
  | Leaf => base
  | Node _ l x r => fold f r (f x (fold f l base))
 end.

Fixpoint elements_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x r => elements_aux (x :: elements_aux acc r) l
  end.

Definition elements := elements_aux nil.

Fixpoint rev_elements_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r
  end.

Definition rev_elements := rev_elements_aux nil.

Fixpoint cardinal (s : tree) : nat :=
  match s with
   | Leaf => 0
   | Node _ l _ r => S (cardinal l + cardinal r)
  end.

Fixpoint maxdepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ r => S (max (maxdepth l) (maxdepth r))
 end.

Fixpoint mindepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ r => S (min (mindepth l) (mindepth r))
 end.

(** ** Testing universal or existential properties. *)

(** We do not use the standard boolean operators of Coq,
    but lazy ones. *)

Fixpoint for_all (f:elt->bool) s := match s with
  | Leaf => true
  | Node _ l x r => f x &&& for_all f l &&& for_all f r
end.

Fixpoint exists_ (f:elt->bool) s := match s with
  | Leaf => false
  | Node _ l x r => f x ||| exists_ f l ||| exists_ f r
end.

(** ** Comparison of trees *)

(** The algorithm here has been suggested by Xavier Leroy,
    and transformed into c.p.s. by Benjamin Grégoire.
    The original ocaml code (with non-structural recursive calls)
    has also been formalized (thanks to Function+measure), see
    [ocaml_compare] in [MSetFullAVL]. The following code with
    continuations computes dramatically faster in Coq, and
    should be almost as efficient after extraction.
*)

(** Enumeration of the elements of a tree. This corresponds
    to the "samefringe" notion in the litterature. *)

Inductive enumeration :=
 | End : enumeration
 | More : elt -> tree -> enumeration -> enumeration.

(** [cons t e] adds the elements of tree [t] on the head of
    enumeration [e]. *)

Fixpoint cons s e : enumeration :=
 match s with
  | Leaf => e
  | Node _ l x r => cons l (More x r e)
 end.

(** One step of comparison of elements *)

Definition compare_more x1 (cont:enumeration->comparison) e2 :=
 match e2 with
 | End => Gt
 | More x2 r2 e2 =>
     match X.compare x1 x2 with
      | Eq => cont (cons r2 e2)
      | Lt => Lt
      | Gt => Gt
     end
 end.

(** Comparison of left tree, middle element, then right tree *)

Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
 match s1 with
  | Leaf => cont e2
  | Node _ l1 x1 r1 =>
     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
  end.

(** Initial continuation *)

Definition compare_end e2 :=
 match e2 with End => Eq | _ => Lt end.

(** The complete comparison *)

Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).

Definition equal s1 s2 :=
 match compare s1 s2 with Eq => true | _ => false end.

(** ** Subset test *)

(** In ocaml, recursive calls are made on "half-trees" such as
   (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these
   non-structural calls, we propose here two specialized functions
   for these situations. This version should be almost as efficient
   as the one of ocaml (closures as arguments may slow things a bit),
   it is simply less compact. The exact ocaml version has also been
   formalized (thanks to Function+measure), see [ocaml_subset] in
   [MSetFullAVL].
*)

Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool :=
 match s2 with
  | Leaf => false
  | Node _ l2 x2 r2 =>
     match X.compare x1 x2 with
      | Eq => subset_l1 l2
      | Lt => subsetl subset_l1 x1 l2
      | Gt => mem x1 r2 &&& subset_l1 s2
     end
 end.

Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool :=
 match s2 with
  | Leaf => false
  | Node _ l2 x2 r2 =>
     match X.compare x1 x2 with
      | Eq => subset_r1 r2
      | Lt => mem x1 l2 &&& subset_r1 s2
      | Gt => subsetr subset_r1 x1 r2
     end
 end.

Fixpoint subset s1 s2 : bool := match s1, s2 with
  | Leaf, _ => true
  | Node _ _ _ _, Leaf => false
  | Node _ l1 x1 r1, Node _ l2 x2 r2 =>
     match X.compare x1 x2 with
      | Eq => subset l1 l2 &&& subset r1 r2
      | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
      | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
     end
 end.

End Ops.

(** * Props : correctness proofs of these generic operations *)

Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info).

(** ** Occurrence in a tree *)

Inductive InT (x : elt) : tree -> Prop :=
  | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r)
  | InLeft : forall c l r y, InT x l -> InT x (Node c l y r)
  | InRight : forall c l r y, InT x r -> InT x (Node c l y r).

Definition In := InT.

(** ** Some shortcuts *)

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

(** ** Binary search trees *)

(** [lt_tree x s]: all elements in [s] are smaller than [x]
   (resp. greater for [gt_tree]) *)

Definition lt_tree x s := forall y, InT y s -> X.lt y x.
Definition gt_tree x s := forall y, InT y s -> X.lt x y.

(** [bst t] : [t] is a binary search tree *)

Inductive bst : tree -> Prop :=
  | BSLeaf : bst Leaf
  | BSNode : forall c x l r, bst l -> bst r ->
     lt_tree x l -> gt_tree x r -> bst (Node c l x r).

(** [bst] is the (decidable) invariant our trees will have to satisfy. *)

Definition IsOk := bst.

Class Ok (s:tree) : Prop := ok : bst s.

Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.

Fixpoint ltb_tree x s :=
 match s with
  | Leaf => true
  | Node _ l y r =>
     match X.compare x y with
      | Gt => ltb_tree x l && ltb_tree x r
      | _ => false
     end
 end.

Fixpoint gtb_tree x s :=
 match s with
  | Leaf => true
  | Node _ l y r =>
     match X.compare x y with
      | Lt => gtb_tree x l && gtb_tree x r
      | _ => false
     end
 end.

Fixpoint isok s :=
 match s with
  | Leaf => true
  | Node _  l x r => isok l && isok r && ltb_tree x l && gtb_tree x r
 end.

(** ** Known facts about ordered types *)

Module Import MX := OrderedTypeFacts X.

(** ** Automation and dedicated tactics *)

Scheme tree_ind := Induction for tree Sort Prop.
Scheme bst_ind := Induction for bst Sort Prop.

Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok.
Local Hint Immediate MX.eq_sym.
Local Hint Unfold In lt_tree gt_tree.
Local Hint Constructors InT bst.
Local Hint Unfold Ok.

(** Automatic treatment of [Ok] hypothesis *)

Ltac clear_inversion H := inversion H; clear H; subst.

Ltac inv_ok := match goal with
 | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok
 | H:Ok Leaf |- _ => clear H; inv_ok
 | H:bst ?x |- _ => change (Ok x) in H; inv_ok
 | _ => idtac
end.

(** A tactic to repeat [inversion_clear] on all hyps of the
    form [(f (Node _ _ _ _))] *)

Ltac is_tree_constr c :=
  match c with
   | Leaf => idtac
   | Node _ _ _ _ => idtac
   | _ => fail
  end.

Ltac invtree f :=
  match goal with
     | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
     | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
     | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
     | _ => idtac
  end.

Ltac inv := inv_ok; invtree InT.

Ltac intuition_in := repeat (intuition; inv).

(** Helper tactic concerning order of elements. *)

Ltac order := match goal with
 | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
 | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
 | _ => MX.order
end.

(** [isok] is indeed a decision procedure for [Ok] *)

Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
Proof.
 induction s as [|c l IHl y r IHr]; simpl.
 unfold lt_tree; intuition_in.
 elim_compare x y.
 split; intros; try discriminate. assert (X.lt y x) by auto. order.
 split; intros; try discriminate. assert (X.lt y x) by auto. order.
 rewrite !andb_true_iff, <-IHl, <-IHr.
  unfold lt_tree; intuition_in; order.
Qed.

Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
Proof.
 induction s as [|c l IHl y r IHr]; simpl.
 unfold gt_tree; intuition_in.
 elim_compare x y.
 split; intros; try discriminate. assert (X.lt x y) by auto. order.
 rewrite !andb_true_iff, <-IHl, <-IHr.
  unfold gt_tree; intuition_in; order.
 split; intros; try discriminate. assert (X.lt x y) by auto. order.
Qed.

Lemma isok_iff : forall s, Ok s <-> isok s = true.
Proof.
 induction s as [|c l IHl y r IHr]; simpl.
 intuition_in.
 rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
 intuition_in.
Qed.

Instance isok_Ok s : isok s = true -> Ok s | 10.
Proof. intros; apply <- isok_iff; auto. Qed.

(** ** Basic results about [In] *)

Lemma In_1 :
 forall s x y, X.eq x y -> InT x s -> InT y s.
Proof.
 induction s; simpl; intuition_in; eauto.
Qed.
Local Hint Immediate In_1.

Instance In_compat : Proper (X.eq==>eq==>iff) InT.
Proof.
apply proper_sym_impl_iff_2; auto with *.
repeat red; intros; subst. apply In_1 with x; auto.
Qed.

Lemma In_node_iff :
 forall c l x r y,
  InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r.
Proof.
 intuition_in.
Qed.

Lemma In_leaf_iff : forall x, InT x Leaf <-> False.
Proof.
 intuition_in.
Qed.

(** Results about [lt_tree] and [gt_tree] *)

Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
Proof.
 red; inversion 1.
Qed.

Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
Proof.
 red; inversion 1.
Qed.

Lemma lt_tree_node :
 forall (x y : elt) (l r : tree) (i : Info.t),
 lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r).
Proof.
 unfold lt_tree; intuition_in; order.
Qed.

Lemma gt_tree_node :
 forall (x y : elt) (l r : tree) (i : Info.t),
 gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r).
Proof.
 unfold gt_tree; intuition_in; order.
Qed.

Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.

Lemma lt_tree_not_in :
 forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
Proof.
 intros; intro; order.
Qed.

Lemma lt_tree_trans :
 forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
Proof.
 eauto.
Qed.

Lemma gt_tree_not_in :
 forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
Proof.
 intros; intro; order.
Qed.

Lemma gt_tree_trans :
 forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
Proof.
 eauto.
Qed.

Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree.
Proof.
 apply proper_sym_impl_iff_2; auto.
 intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
Qed.

Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree.
Proof.
 apply proper_sym_impl_iff_2; auto.
 intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
Qed.

Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.

Ltac induct s x :=
 induction s as [|i l IHl x' r IHr]; simpl; intros;
 [|elim_compare x x'; intros; inv].

Ltac auto_tc := auto with typeclass_instances.

Ltac ok :=
 inv; change bst with Ok in *;
 match goal with
   | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok
   | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok
   | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok
   | _ => eauto with typeclass_instances
 end.

(** ** Empty set *)

Lemma empty_spec : Empty empty.
Proof.
 intros x H. inversion H.
Qed.

Instance empty_ok : Ok empty.
Proof.
 auto.
Qed.

(** ** Emptyness test *)

Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
Proof.
 destruct s as [|c r x l]; simpl; auto.
 - split; auto. intros _ x H. inv.
 - split; auto. try discriminate. intro H; elim (H x); auto.
Qed.

(** ** Membership *)

Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
Proof.
 split.
 - induct s x; now auto.
 - induct s x; intuition_in; order.
Qed.

(** ** Minimal and maximal elements *)

Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.

Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s.
Proof.
 functional induction (min_elt s); auto; inversion 1; auto.
Qed.

Lemma min_elt_spec2 s x y `{Ok s} :
 min_elt s = Some x -> InT y s -> ~ X.lt y x.
Proof.
 revert y.
 functional induction (min_elt s);
 try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
 - discriminate.
 - intros y V W.
   inversion V; clear V; subst.
   inv; order.
 - intros; inv; auto.
   * assert (X.lt x x0) by (apply H8; apply min_elt_spec1; auto).
     order.
   * assert (X.lt x1 x0) by auto.
     assert (~X.lt x1 x) by auto.
     order.
Qed.

Lemma min_elt_spec3 s : min_elt s = None -> Empty s.
Proof.
 functional induction (min_elt s).
 red; red; inversion 2.
 inversion 1.
 intro H0.
 destruct (IHo H0 _x3); auto.
Qed.

Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s.
Proof.
 functional induction (max_elt s); auto; inversion 1; auto.
Qed.

Lemma max_elt_spec2 s x y `{Ok s} :
 max_elt s = Some x -> InT y s -> ~ X.lt x y.
Proof.
 revert y.
 functional induction (max_elt s);
 try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
 - discriminate.
 - intros y V W.
   inversion V; clear V; subst.
   inv; order.
 - intros; inv; auto.
   * assert (X.lt x0 x) by (apply H9; apply max_elt_spec1; auto).
     order.
   * assert (X.lt x0 x1) by auto.
     assert (~X.lt x x1) by auto.
     order.
Qed.

Lemma max_elt_spec3 s : max_elt s = None -> Empty s.
Proof.
 functional induction (max_elt s).
 red; red; inversion 2.
 inversion 1.
 intro H0.
 destruct (IHo H0 _x3); auto.
Qed.

Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
Proof.
 exact min_elt_spec1.
Qed.

Lemma choose_spec2 : forall s, choose s = None -> Empty s.
Proof.
 exact min_elt_spec3.
Qed.

Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
  choose s = Some x -> choose s' = Some x' ->
  Equal s s' -> X.eq x x'.
Proof.
 unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
 assert (~X.lt x x').
  apply min_elt_spec2 with s'; auto.
  rewrite <-H; auto using min_elt_spec1.
 assert (~X.lt x' x).
  apply min_elt_spec2 with s; auto.
  rewrite H; auto using min_elt_spec1.
 elim_compare x x'; intuition.
Qed.

(** ** Elements *)

Lemma elements_spec1' : forall s acc x,
 InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
Proof.
 induction s as [ | c l Hl x r Hr ]; simpl; auto.
 intuition.
 inversion H0.
 intros.
 rewrite Hl.
 destruct (Hr acc x0); clear Hl Hr.
 intuition; inversion_clear H3; intuition.
Qed.

Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
Proof.
 intros; generalize (elements_spec1' s nil x); intuition.
 inversion_clear H0.
Qed.

Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
 (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
 sort X.lt (elements_aux acc s).
Proof.
 induction s as [ | c l Hl y r Hr]; simpl; intuition.
 inv.
 apply Hl; auto.
 constructor.
 apply Hr; auto.
 eapply InA_InfA; eauto with *.
 intros.
 destruct (elements_spec1' r acc y0); intuition.
 intros.
 inversion_clear H.
 order.
 destruct (elements_spec1' r acc x); intuition eauto.
Qed.

Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
Proof.
 intros; unfold elements; apply elements_spec2'; auto.
 intros; inversion H0.
Qed.
Local Hint Resolve elements_spec2.

Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
Proof.
 intros. eapply SortA_NoDupA; eauto with *.
Qed.

Lemma elements_aux_cardinal :
 forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
Proof.
 simple induction s; simpl; intuition.
 rewrite <- H.
 simpl.
 rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)).
 now rewrite <- Nat.add_succ_r, Nat.add_assoc.
Qed.

Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
Proof.
 exact (fun s => elements_aux_cardinal s nil).
Qed.

Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s.

Lemma elements_app :
 forall s acc, elements_aux acc s = elements s ++ acc.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1, IHs2.
 unfold elements; simpl.
 rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
Qed.

Lemma elements_node c l x r :
 elements (Node c l x r) = elements l ++ x :: elements r.
Proof.
 unfold elements; simpl.
 now rewrite !elements_app, !app_nil_r.
Qed.

Lemma rev_elements_app :
 forall s acc, rev_elements_aux acc s = rev_elements s ++ acc.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1, IHs2.
 unfold rev_elements; simpl.
 rewrite IHs1, 2 IHs2, !app_nil_r, !app_ass; auto.
Qed.

Lemma rev_elements_node c l x r :
 rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l.
Proof.
 unfold rev_elements; simpl.
 now rewrite !rev_elements_app, !app_nil_r.
Qed.

Lemma rev_elements_rev s : rev_elements s = rev (elements s).
Proof.
 induction s as [|c l IHl x r IHr]; trivial.
 rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr.
 simpl. now rewrite !app_ass.
Qed.

(** The converse of [elements_spec2], used in MSetRBT *)

(* TODO: TO MIGRATE ELSEWHERE... *)

Lemma sorted_app_inv l1 l2 :
 sort X.lt (l1++l2) ->
 sort X.lt l1 /\ sort X.lt l2 /\
 forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2.
Proof.
 induction l1 as [|a1 l1 IHl1].
 - simpl; repeat split; auto.
   intros. now rewrite InA_nil in *.
 - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ].
   destruct (IHl1 Hs) as (H1 & H2 & H3).
   repeat split.
   * constructor; auto.
     destruct l1; simpl in *; auto; inversion_clear Hhd; auto.
   * trivial.
   * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1.
     + rewrite H.
       apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc.
       rewrite InA_app_iff; auto_tc.
     + auto.
Qed.

Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s.
Proof.
 induction s as [|c l IHl x r IHr].
 - auto.
 - rewrite elements_node.
   intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3).
   inversion_clear H2.
   constructor; ok.
   * intros y Hy. apply H3.
     + now rewrite elements_spec1.
     + rewrite InA_cons. now left.
   * intros y Hy.
     apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc.
     now rewrite elements_spec1.
Qed.

(** ** [for_all] and [exists] *)

Lemma for_all_spec s f : Proper (X.eq==>eq) f ->
 (for_all f s = true <-> For_all (fun x => f x = true) s).
Proof.
 intros Hf; unfold For_all.
 induction s as [|i l IHl x r IHr]; simpl; auto.
 - split; intros; inv; auto.
 - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr.
   intuition_in. eauto.
Qed.

Lemma exists_spec s f : Proper (X.eq==>eq) f ->
 (exists_ f s = true <-> Exists (fun x => f x = true) s).
Proof.
 intros Hf; unfold Exists.
 induction s as [|i l IHl x r IHr]; simpl; auto.
 - split.
   * discriminate.
   * intros (y,(H,_)); inv.
 - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr.
   split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))].
   * exists x; auto.
   * exists y; auto.
   * exists y; auto.
   * inv; [left;left|left;right|right]; try (exists y); eauto.
Qed.

(** ** Fold *)

Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) :
 fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
Proof.
 revert i acc.
 induction s as [|c l IHl x r IHr]; simpl; intros; auto.
 rewrite IHl.
 simpl. unfold flip at 2.
 apply IHr.
Qed.

Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) :
 fold f s i = fold_left (flip f) (elements s) i.
Proof.
 revert i. unfold elements.
 induction s as [|c l IHl x r IHr]; simpl; intros; auto.
 rewrite fold_spec'.
 rewrite IHr.
 simpl; auto.
Qed.

(** ** Subset *)

Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2
 `{Ok (Node c1 l1 x1 Leaf), Ok s2},
 (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
 (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ).
Proof.
 induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
 unfold Subset; intuition; try discriminate.
 assert (H': InT x1 Leaf) by auto; inversion H'.
 specialize (IHl2 H).
 specialize (IHr2 H).
 inv.
 elim_compare x1 x2.

 rewrite H1 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite IHl2 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
 rewrite mem_spec; auto.
 assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.
Qed.

Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2,
 bst (Node c1 Leaf x1 r1) -> bst s2 ->
 (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
 (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2).
Proof.
 induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
 unfold Subset; intuition; try discriminate.
 assert (H': InT x1 Leaf) by auto; inversion H'.
 specialize (IHl2 H).
 specialize (IHr2 H).
 inv.
 elim_compare x1 x2.

 rewrite H1 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
 rewrite mem_spec; auto.
 assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite IHr2 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
Qed.

Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
 (subset s1 s2 = true <-> Subset s1 s2).
Proof.
 induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros.
 unfold Subset; intuition_in.
 destruct s2 as [|c2 l2 x2 r2]; simpl; intros.
 unfold Subset; intuition_in; try discriminate.
 assert (H': InT x1 Leaf) by auto; inversion H'.
 inv.
 elim_compare x1 x2.

 rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
 clear IHl1 IHr1.
 unfold Subset; intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
 rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto.
 clear IHl1 IHr1.
 unfold Subset; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
 rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto.
 clear IHl1 IHr1.
 unfold Subset; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
Qed.

(** ** Comparison *)

(** Relations [eq] and [lt] over trees *)

Module L := MSetInterface.MakeListOrdering X.

Definition eq := Equal.
Instance eq_equiv : Equivalence eq.
Proof. firstorder. Qed.

Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
Proof.
 unfold eq, Equal, L.eq; intros.
 setoid_rewrite elements_spec1; firstorder.
Qed.

Definition lt (s1 s2 : tree) : Prop :=
 exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
   /\ L.lt (elements s1') (elements s2').

Instance lt_strorder : StrictOrder lt.
Proof.
 split.
 intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
 assert (eqlistA X.eq (elements s1) (elements s2)).
  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
  rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
 rewrite H in L.
 apply (StrictOrder_Irreflexive (elements s2)); auto.
 intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
                 (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
 exists s1', s3'; do 4 (split; trivial).
 assert (eqlistA X.eq (elements s2') (elements s2'')).
  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
  rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
 transitivity (elements s2'); auto.
 rewrite H; auto.
Qed.

Instance lt_compat : Proper (eq==>eq==>iff) lt.
Proof.
 intros s1 s2 E12 s3 s4 E34. split.
 intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
 exists s1', s3'; do 2 (split; trivial).
  split. transitivity s1; auto. symmetry; auto.
  split; auto. transitivity s3; auto. symmetry; auto.
 intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
 exists s1', s3'; do 2 (split; trivial).
  split. transitivity s2; auto.
  split; auto. transitivity s4; auto.
Qed.

(** Proof of the comparison algorithm *)

(** [flatten_e e] returns the list of elements of [e] i.e. the list
    of elements actually compared *)

Fixpoint flatten_e (e : enumeration) : list elt := match e with
  | End => nil
  | More x t r => x :: elements t ++ flatten_e r
 end.

Lemma flatten_e_elements :
 forall l x r c e,
 elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e.
Proof.
 intros; simpl. now rewrite elements_node, app_ass.
Qed.

Lemma cons_1 : forall s e,
  flatten_e (cons s e) = elements s ++ flatten_e e.
Proof.
 induction s; simpl; auto; intros.
 rewrite IHs1; apply flatten_e_elements.
Qed.

(** Correctness of this comparison *)

Definition Cmp c x y := CompSpec L.eq L.lt x y c.

Local Hint Unfold Cmp flip.

Lemma compare_end_Cmp :
 forall e2, Cmp (compare_end e2) nil (flatten_e e2).
Proof.
 destruct e2; simpl; constructor; auto. reflexivity.
Qed.

Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
      (flatten_e (More x2 r2 e2)).
Proof.
 simpl; intros; elim_compare x1 x2; simpl; red; auto.
Qed.

Lemma compare_cont_Cmp : forall s1 cont e2 l,
 (forall e, Cmp (cont e) l (flatten_e e)) ->
 Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
Proof.
 induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; simpl; intros; auto.
 rewrite elements_node, app_ass; simpl.
 apply Hl1; auto. clear e2. intros [|x2 r2 e2].
 simpl; auto.
 apply compare_more_Cmp.
 rewrite <- cons_1; auto.
Qed.

Lemma compare_Cmp : forall s1 s2,
 Cmp (compare s1 s2) (elements s1) (elements s2).
Proof.
 intros; unfold compare.
 rewrite (app_nil_end (elements s1)).
 replace (elements s2) with (flatten_e (cons s2 End)) by
  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
 apply compare_cont_Cmp; auto.
 intros.
 apply compare_end_Cmp; auto.
Qed.

Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
 CompSpec eq lt s1 s2 (compare s1 s2).
Proof.
 intros.
 destruct (compare_Cmp s1 s2); constructor.
 rewrite eq_Leq; auto.
 intros; exists s1, s2; repeat split; auto.
 intros; exists s2, s1; repeat split; auto.
Qed.

(** ** Equality test *)

Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
 equal s1 s2 = true <-> eq s1 s2.
Proof.
unfold equal; intros s1 s2 B1 B2.
destruct (@compare_spec s1 s2 B1 B2) as [H|H|H];
 split; intros H'; auto; try discriminate.
rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
Qed.

(** ** A few results about [mindepth] and [maxdepth] *)

Lemma mindepth_maxdepth s : mindepth s <= maxdepth s.
Proof.
 induction s; simpl; auto.
 rewrite <- Nat.succ_le_mono.
 transitivity (mindepth s1). apply Nat.le_min_l.
 transitivity (maxdepth s1). trivial. apply Nat.le_max_l.
Qed.

Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s).
Proof.
 unfold Peano.lt.
 induction s as [|c l IHl x r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_max_l.
   * apply Nat.le_max_r.
Qed.

Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s).
Proof.
 unfold Peano.lt.
 induction s as [|c l IHl x r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_min_l.
   * apply Nat.le_min_r.
Qed.

Lemma maxdepth_log_cardinal s : s <> Leaf ->
 log2 (cardinal s) < maxdepth s.
Proof.
 intros H.
 apply Nat.log2_lt_pow2. destruct s; simpl; intuition.
 apply maxdepth_cardinal.
Qed.

Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)).
Proof.
 apply Nat.log2_le_pow2. auto with arith.
 apply mindepth_cardinal.
Qed.

End Props.


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

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

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

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

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

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


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

(*i $$ i*)

(**********************************************************************)
(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
(**********************************************************************)

Require Export BinPos BinInt.
Require Import Lt Gt Plus Mult.

Local Open Scope Z_scope.

(***************************)
(** * Comparison on integers *)

Lemma Zcompare_refl : forall n:Z, (n ?= n) = Eq.
Proof.
 destruct n as [|p|p]; simpl; trivial.
 apply Pcompare_refl.
 apply CompOpp_iff, Pcompare_refl.
Qed.

Lemma Zcompare_Eq_eq : forall n m:Z, (n ?= m) = Eq -> n = m.
Proof.
 intros [|x|x] [|y|y] H; simpl in *; try easy; f_equal.
  now apply Pcompare_Eq_eq.
  apply CompOpp_iff in H. now apply Pcompare_Eq_eq.
Qed.

Ltac destr_zcompare :=
 match goal with |- context [Zcompare ?x ?y] =>
  let H := fresh "H" in
  case_eq (Zcompare x y); intro H;
   [generalize (Zcompare_Eq_eq _ _ H); clear H; intro H |
    change (x<y)%Z in H |
    change (x>y)%Z in H ]
 end.

Lemma Zcompare_Eq_iff_eq : forall n m:Z, (n ?= m) = Eq <-> n = m.
Proof.
 intros x y; split; intro E; subst.
 now apply Zcompare_Eq_eq. now apply Zcompare_refl.
Qed.

Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n).
Proof.
 intros [|x|x] [|y|y]; simpl; try easy; f_equal; apply Pcompare_antisym.
Qed.

Lemma Zcompare_spec : forall n m, CompareSpec (n=m) (n<m) (m<n) (n ?= m).
Proof.
 intros.
 destruct (n?=m) as [ ]_eqn:H; constructor; trivial.
 now apply Zcompare_Eq_eq.
 red; now rewrite <- Zcompare_antisym, H.
Qed.

Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt.
Proof.
 intros x y.
 rewrite <- Zcompare_antisym. change Gt with (CompOpp Lt).
 split.
 auto using CompOpp_inj.
 intros; f_equal; auto.
Qed.

(** * Transitivity of comparison *)

Lemma Zcompare_Lt_trans :
  forall n m p:Z, (n ?= m) = Lt -> (m ?= p) = Lt -> (n ?= p) = Lt.
Proof.
 intros n m p; destruct n,m,p; simpl; try discriminate; trivial.
 eapply Plt_trans; eauto.
 rewrite 3 Pcompare_antisym; simpl. intros; eapply Plt_trans; eauto.
Qed.

Lemma Zcompare_Gt_trans :
  forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
Proof.
  intros n m p Hnm Hmp.
  apply <- Zcompare_Gt_Lt_antisym.
  apply -> Zcompare_Gt_Lt_antisym in Hnm.
  apply -> Zcompare_Gt_Lt_antisym in Hmp.
  eapply Zcompare_Lt_trans; eauto.
Qed.

(** * Comparison and opposite *)

Lemma Zcompare_opp : forall n m:Z, (n ?= m) = (- m ?= - n).
Proof.
 destruct n, m; simpl; trivial; intros; now rewrite <- ZC4.
Qed.

(** * Comparison first-order specification *)

Lemma Zcompare_Gt_spec :
  forall n m:Z, (n ?= m) = Gt ->  exists h, n + - m = Zpos h.
Proof.
 intros [|p|p] [|q|q]; simpl; try discriminate.
 now exists q.
 now exists p.
 intros GT. exists (p-q)%positive. now rewrite GT.
 now exists (p+q)%positive.
 intros LT. apply CompOpp_iff in LT. simpl in LT.
 exists (q-p)%positive. now rewrite LT.
Qed.

(** * Comparison and addition *)

Local Hint Resolve Pcompare_refl.

Lemma weak_Zcompare_plus_compat :
  forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m).
Proof.
 intros [|x|x] [|y|y] z; simpl; trivial; try apply ZC2;
  try apply Plt_plus_r.
 case Pcompare_spec; intros E0; trivial; try apply ZC2;
  now apply Pminus_decr.
 apply Pplus_compare_mono_l.
 case Pcompare_spec; intros E0; trivial; try apply ZC2.
  apply Plt_trans with z. now apply Pminus_decr. apply Plt_plus_r.
 case Pcompare_spec; intros E0; trivial; try apply ZC2.
  now apply Pminus_decr.
 case Pcompare_spec; intros E0; trivial; try apply ZC2.
  apply Plt_trans with z. now apply Pminus_decr. apply Plt_plus_r.
 case Pcompare_spec; intros E0; simpl; subst.
  now case Pcompare_spec.
  case Pcompare_spec; intros E1; simpl; subst; trivial.
  now rewrite <- ZC4.
  f_equal.
  apply Pminus_compare_mono_r; trivial.
  rewrite <- ZC4. symmetry. now apply Plt_trans with z.
  case Pcompare_spec; intros E1; simpl; subst; trivial.
  now rewrite E0.
  symmetry. apply CompOpp_iff. now apply Plt_trans with z.
  rewrite <- ZC4.
  apply Pminus_compare_mono_l; trivial.
Qed.

Lemma Zcompare_plus_compat : forall n m p:Z, (p + n ?= p + m) = (n ?= m).
Proof.
 intros x y [|z|z]; trivial.
 apply weak_Zcompare_plus_compat.
 rewrite (Zcompare_opp x y), Zcompare_opp, 2 Zopp_plus_distr, Zopp_neg.
 apply weak_Zcompare_plus_compat.
Qed.

Lemma Zplus_compare_compat :
  forall (r:comparison) (n m p q:Z),
    (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
Proof.
 intros [ | | ] x y z t H H'.
 apply Zcompare_Eq_eq in H. apply Zcompare_Eq_eq in H'. subst.
  apply Zcompare_refl.
 apply Zcompare_Lt_trans with (y+z).
 now rewrite 2 (Zplus_comm _ z), Zcompare_plus_compat.
 now rewrite Zcompare_plus_compat.
 apply Zcompare_Gt_trans with (y+z).
 now rewrite 2 (Zplus_comm _ z), Zcompare_plus_compat.
 now rewrite Zcompare_plus_compat.
Qed.

Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt.
Proof.
 intro x; unfold Zsucc; pattern x at 2; rewrite <- (Zplus_0_r x);
  now rewrite Zcompare_plus_compat.
Qed.

Lemma Zcompare_Gt_not_Lt : forall n m:Z, (n ?= m) = Gt <-> (n ?= m+1) <> Lt.
Proof.
 intros x y; split; intros H.
 (* -> *)
 destruct (Zcompare_Gt_spec _ _ H) as (h,EQ).
 replace x with (y+Zpos h) by (rewrite <- EQ; apply Zplus_minus).
 rewrite Zcompare_plus_compat. apply Plt_1.
 (* <- *)
 assert (H' := Zcompare_succ_Gt y).
 destruct (Zcompare_spec x (y+1)) as [->|LT|GT]; trivial.
  now elim H.
  apply Zcompare_Gt_Lt_antisym in GT.
   apply Zcompare_Gt_trans with (y+1); trivial.
Qed.

(** * Successor and comparison *)

Lemma Zcompare_succ_compat : forall n m:Z, (Zsucc n ?= Zsucc m) = (n ?= m).
Proof.
 intros n m; unfold Zsucc;
  now rewrite 2 (Zplus_comm _ 1), Zcompare_plus_compat.
Qed.

(** * Multiplication and comparison *)

Lemma Zcompare_mult_compat :
  forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m).
Proof.
 intros p [|n|n] [|m|m]; simpl; trivial.
  apply Pmult_compare_mono_l.
  f_equal. apply Pmult_compare_mono_l.
Qed.

(** * Reverting [x ?= y] to trichotomy *)

Lemma Zcompare_elim :
  forall (c1 c2 c3:Prop) (n m:Z),
    (n = m -> c1) ->
    (n < m -> c2) ->
    (n > m -> c3) -> match n ?= m with
                       | Eq => c1
                       | Lt => c2
                       | Gt => c3
                     end.
Proof.
 intros c1 c2 c3 x y EQ LT GT; intros.
 case Zcompare_spec; auto.
 intro H. apply GT. red. now rewrite <- Zcompare_antisym, H.
Qed.

Lemma Zcompare_eq_case :
  forall (c1 c2 c3:Prop) (n m:Z),
    c1 -> n = m -> match n ?= m with
                     | Eq => c1
                     | Lt => c2
                     | Gt => c3
                   end.
Proof.
  intros c1 c2 c3 x y; intros.
  rewrite H0; rewrite Zcompare_refl.
  assumption.
Qed.

(** * Decompose an egality between two [?=] relations into 3 implications *)

Lemma Zcompare_egal_dec :
  forall n m p q:Z,
    (n < m -> p < q) ->
    ((n ?= m) = Eq -> (p ?= q) = Eq) ->
    (n > m -> p > q) -> (n ?= m) = (p ?= q).
Proof.
  intros x1 y1 x2 y2.
  unfold Zgt; unfold Zlt; case (x1 ?= y1); case (x2 ?= y2);
    auto with arith; symmetry; auto with arith.
Qed.

(** * Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *)

Lemma Zle_compare :
  forall n m:Z,
    n <= m -> match n ?= m with
		| Eq => True
		| Lt => True
		| Gt => False
              end.
Proof.
  intros x y; unfold Zle; elim (x ?= y); auto with arith.
Qed.

Lemma Zlt_compare :
  forall n m:Z,
   n < m -> match n ?= m with
              | Eq => False
              | Lt => True
              | Gt => False
            end.
Proof.
  intros x y; unfold Zlt in |- *; elim (x ?= y); intros;
    discriminate || trivial with arith.
Qed.

Lemma Zge_compare :
  forall n m:Z,
    n >= m -> match n ?= m with
		| Eq => True
		| Lt => False
		| Gt => True
              end.
Proof.
  intros x y; unfold Zge; elim (x ?= y); auto.
Qed.

Lemma Zgt_compare :
  forall n m:Z,
    n > m -> match n ?= m with
               | Eq => False
               | Lt => False
               | Gt => True
             end.
Proof.
  intros x y; unfold Zgt; now elim (x ?= y).
Qed.

(*********************)
(** * Other properties *)

Lemma Zmult_compare_compat_l :
  forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m).
Proof.
  intros x y z H; destruct z.
  discriminate H.
  rewrite Zcompare_mult_compat; reflexivity.
  discriminate H.
Qed.

Lemma Zmult_compare_compat_r :
  forall n m p:Z, p > 0 -> (n ?= m) = (n * p ?= m * p).
Proof.
  intros x y z H; rewrite 2 (Zmult_comm _ z);
    apply Zmult_compare_compat_l; assumption.
Qed.

(*************************)
(** * Basic properties of minimum and maximum *)

Lemma Zmax_l : forall x y, y<=x -> Zmax x y = x.
Proof.
 unfold Zle, Zmax. intros x y. rewrite <- (Zcompare_antisym x y).
 destruct (x ?= y); intuition.
Qed.

Lemma Zmax_r : forall x y, x<=y -> Zmax x y = y.
Proof.
 unfold Zle, Zmax. intros x y. generalize (Zcompare_Eq_eq x y).
 destruct (x ?= y); intuition.
Qed.

Lemma Zmin_l : forall x y, x<=y -> Zmin x y = x.
Proof.
 unfold Zle, Zmin. intros x y. generalize (Zcompare_Eq_eq x y).
 destruct (x ?= y); intuition.
Qed.

Lemma Zmin_r : forall x y, y<=x -> Zmin x y = y.
Proof.
 unfold Zle, Zmin. intros x y.
 rewrite <- (Zcompare_antisym x y). generalize (Zcompare_Eq_eq x y).
 destruct (x ?= y); intuition.
Qed.

(**************************)
(** * Basic properties of [Zabs] *)

Lemma Zabs_eq : forall n:Z, 0 <= n -> Zabs n = n.
Proof.
 destruct n; auto. now destruct 1.
Qed.

Lemma Zabs_non_eq : forall n:Z, n <= 0 -> Zabs n = - n.
Proof.
 destruct n; auto. now destruct 1.
Qed.

(**************************)
(** * Basic properties of [Zsign] *)

Lemma Zsgn_0 : forall x, x = 0 -> Zsgn x = 0.
Proof.
 intros. now subst.
Qed.

Lemma Zsgn_1 : forall x, 0 < x -> Zsgn x = 1.
Proof.
 destruct x; auto; discriminate.
Qed.

Lemma Zsgn_m1 : forall x, x < 0 -> Zsgn x = -1.
Proof.
 destruct x; auto; discriminate.
Qed.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rbasic_fun.
Require Import Even.
Require Import Div2.
Require Import ArithRing.

Local Open Scope Z_scope.
Local Open Scope R_scope.

Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
Proof. hammer_hook "ArithProp" "ArithProp.minus_neq_O".
intros; red; intro.
cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
elim (lt_irrefl _ H).
set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
cut
((forall n m:nat, R n m) ->
forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
intro; apply H1.
apply nat_double_ind.
unfold R; intros; inversion H2; reflexivity.
unfold R; intros; simpl in H3; assumption.
unfold R; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
unfold R; intros; apply H1; assumption.
Qed.

Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
Proof. hammer_hook "ArithProp" "ArithProp.le_minusni_n".
set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
cut
((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
intro; apply H.
apply nat_double_ind.
unfold R; intros; simpl; apply le_n.
unfold R; intros; simpl; apply le_n.
unfold R; intros; simpl; apply le_trans with n.
apply H0; apply le_S_n; assumption.
apply le_n_Sn.
unfold R; intros; apply H; assumption.
Qed.

Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
Proof. hammer_hook "ArithProp" "ArithProp.lt_minus_O_lt".
intros n m; pattern n, m; apply nat_double_ind;
[ intros; rewrite <- minus_n_O; assumption
| intros; elim (lt_n_O _ H)
| intros; simpl; apply H; apply lt_S_n; assumption ].
Qed.

Lemma even_odd_cor :
forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
Proof. hammer_hook "ArithProp" "ArithProp.even_odd_cor".
intro.
assert (H := even_or_odd n).
exists (div2 n).
assert (H0 := even_odd_double n).
elim H0; intros.
elim H1; intros H3 _.
elim H2; intros H4 _.
replace (2 * div2 n)%nat with (double (div2 n)).
elim H; intro.
left.
apply H3; assumption.
right.
apply H4; assumption.
unfold double;ring.
Qed.

Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat.
Proof. hammer_hook "ArithProp" "ArithProp.le_double".
intros; apply INR_le.
assert (H1 := le_INR _ _ H).
do 2 rewrite mult_INR in H1.
apply Rmult_le_reg_l with (INR 2).
replace (INR 2) with 2; [ prove_sup0 | reflexivity ].
assumption.
Qed.

Lemma euclidian_division :
forall x y:R,
y <> 0 ->
exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y).
Proof. hammer_hook "ArithProp" "ArithProp.euclidian_division".
intros.
set
(k0 :=
match Rcase_abs y with
| left _ => (1 - up (x / - y))%Z
| right _ => (up (x / y) - 1)%Z
end).
exists k0.
exists (x - IZR k0 * y).
split.
ring.
unfold k0; case (Rcase_abs y) as [Hlt|Hge].
assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl;
unfold Rminus.
replace (- ((1 + - IZR (up (x / - y))) * y)) with
((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
split.
apply Rmult_le_reg_l with (/ - y).
apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact Hlt.
rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
rewrite <- Ropp_inv_permute; [ idtac | assumption ].
rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
rewrite Rplus_0_r; unfold Rdiv; pattern (/ - y) at 4;
rewrite <- Ropp_inv_permute; [ idtac | assumption ].
replace
(IZR (up (x * / - y)) - x * - / y +
(- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1;
[ idtac | ring ].
elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
rewrite (Rabs_left _ Hlt); apply Rmult_lt_reg_l with (/ - y).
apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact Hlt.
rewrite <- Rinv_l_sym.
rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
rewrite <- Ropp_inv_permute; [ idtac | assumption ].
rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
apply Rplus_lt_reg_l with (IZR (up (x / - y)) - 1).
replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
[ idtac | ring ].
replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
with (- (x * / y)); [ idtac | ring ].
rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
unfold Rdiv; intros H1 _; exact H1.
apply Ropp_neq_0_compat; assumption.
assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl;
cut (0 < y).
intro; unfold Rminus;
replace (- ((IZR (up (x / y)) + -(1)) * y)) with ((1 - IZR (up (x / y))) * y);
[ idtac | ring ].
split.
apply Rmult_le_reg_l with (/ y).
apply Rinv_0_lt_compat; assumption.
rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
[ rewrite Rmult_1_r | assumption ];
apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y);
rewrite Rplus_0_r; unfold Rdiv;
replace
(IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2;
exact H2.
rewrite (Rabs_right _ Hge); apply Rmult_lt_reg_l with (/ y).
apply Rinv_0_lt_compat; assumption.
rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
[ rewrite Rmult_1_r | assumption ];
apply Rplus_lt_reg_l with (IZR (up (x / y)) - 1);
replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y)));
[ idtac | ring ];
replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
(x * / y); [ idtac | ring ]; elim H0; unfold Rdiv;
intros H2 _; exact H2.
destruct (total_order_T 0 y) as [[Hlt|Heq]|Hgt].
assumption.
elim H; symmetry ; exact Heq.
apply Rge_le in Hge; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hge Hgt)).
Qed.

Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
Proof. hammer_hook "ArithProp" "ArithProp.tech8".
intros; induction  i as [| i Hreci].
replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
replace (S n + S i)%nat with (S (S n + i)).
apply le_S; assumption.
apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
Qed.


(**  Some simple examples about the use of the library.
 *)

Require Export FLL.Misc.Hybrid.
Require Export FLL.SL.FLLTactics.
Require Export FLL.Misc.Permutations.
Require Import Coq.Init.Nat.

Hint Resolve level_CON level_VAR level_BND level_APP level_ABS : hybrid.
Hint Resolve proper_APP uniform_proper : hybrid.
Hint Unfold proper: hybrid.
Hint Rewrite ext_eq_eta : hybrid.
Hint Resolve uniform_id uniform_con uniform_app : hybrid.
Hint Resolve lbindEq exprInhabited : hybrid.
Hint Constructors seq seqN : core.
Hint Resolve uniform_id : core.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Tactic Notation "ddd"  constr(R) := match goal with
                                        | [ |- seq _ _ _ _ ] =>  eapply @tri_dec1' with (F:= R);solveF;solveLL
                                        | [|- seqN _ _ _ _ _] => eapply @tri_dec1 with (F:= R);solveF;solveLL
                                        end.

Module Example1 .

  (** LL quantification on [nat] *)
  Definition con' := nat .
  Definition uexp := expr con' .

  (** a unique unary predicate *)
  Inductive Atom:Set :=
  | p : uexp -> Atom.

  Definition Var : var -> uexp := (VAR con').
  Definition Bnd : bnd -> uexp := (BND con').

  Inductive uniform_atm' : (uexp -> Atom) -> Prop :=
  | uniform_p: forall FX, uniform FX -> uniform_atm' (fun x:uexp => p (FX x))
  .
  Hint Constructors uniform_atm' : core .

  (** Instance of the LL signature *)
  Instance Signature : OLSig :=
    {|
      con := con';
      atm := Atom;
      uniform_atm := uniform_atm'
    |}.

  Notation " '|--' B ';' L ';' X " := (seq EmptyTheory  B L X) (at level 80).

  Example Test1:  |-- [] ; [] ; >> one ** one .
  Proof with solveLL;eauto.
    tensor (@nil oo) (@nil oo).
  Qed.

  Example Test2: |-- [] ; [] ; > [  F{ fun t => perp (p t)} ; E{ fun t => atom (p t)}  ].
  Proof with solveF.
    solveLL.
    decide1 (E{ fun t  => (atom (p t))}).
    existential x.
  Qed.

  Example Test2': |-- [] ; [] ; > [  perp (p (Var 0)) ; atom (p (Var 0))  ].
  Proof with solveF.
    solveLL.
  Qed.

  Example Test3: |-- [] ; [] ; > [  E{ fun t => perp (p t)} ; E{ fun t => atom (p t)}  ].
  Proof with solveF.
    solveLL.
    decide1 (E{ fun t  => (atom (p t) )}) ...
    existential (VAR con 0) ...
    solveLL.
    decide1 (E{ fun t  => (perp (p t) )}) ...
    existential (VAR con 0).
  Qed.

  Definition Nat (n:nat) := CON n .

  Example Test4: forall n:nat,  |-- [atom (p (Nat n)) ] ; [] ; > [  perp (p (Nat n))  ].
  Proof with solveLL.
    intros...
    decide1 (perp (p (Nat n)))...
  Qed.

End Example1.

Section Example2.

  (** Definition of the natural numbers *)
  Inductive Econ : Set :=
  | z :  Econ (* zero *)
  | suc : Econ. (* successor *)
  Definition uexp : Set := expr Econ.

  Inductive Atom:Set :=
  | p : uexp -> Atom.

  Definition Var : var -> uexp := (VAR Econ).
  Definition Bnd : bnd -> uexp := (BND Econ).

  Inductive uniform_atm' : (uexp -> Atom) -> Prop :=
  | uniform_p: forall FX, uniform FX -> uniform_atm' (fun x:uexp => p (FX x))
  .

  (** More suitable constructors to work with *)
  Definition Z   := (CON z) .
  Definition SUC : uexp -> uexp  := fun N:uexp => (APP (CON suc) N) .

  Hint Constructors uniform_atm'  : core.

  Instance Signature : OLSig :=
    {|
      con := Econ;
      atm := Atom;
      uniform_atm := uniform_atm'
    |}.

  Notation " n '|---' B ';' L ';' X " := (seqN EmptyTheory n B L X) (at level 80).
  Notation " '|--' B ';' L ';' X " := (seq EmptyTheory  B L X) (at level 80).

  Example test1 : |-- [ atom (p Z) ]; [perp (p Z)]; > [].
  Proof with solveLL;solveF.
    decide1 (perp (p Z) ) ...
  Qed.

  Definition step := fun t:uexp => perp (p t) ** atom (p (SUC t)).
  Definition ONE := (SUC  Z) .
  Definition TWO := SUC (SUC  Z) .

  Example test2 : |-- []; []; > [? E{ step}; perp (p Z) -o perp (p (SUC (SUC Z))) ].
  Proof with solveLL.
    simpl...
    decide2 (E{ step}).
    existential Z .
    tensor [atom (p Z)] [perp (p (SUC (SUC Z))) ] .
    decide2 (E{ step}) .
    existential (SUC Z).
    tensor [atom (p (SUC Z)) ] [perp (p (SUC (SUC Z))) ] .
  Qed.

  Definition stepPerp := fun t:uexp => atom (p t) ** perp (p (SUC t)).
  Example test2' : |-- []; []; > [? E{ stepPerp} ; atom (p Z) -o atom (p TWO) ].
  Proof with solveLL.
    simpl...
    decide2 (E{ stepPerp}).
    existential ONE .
    tensor [perp (p Z)] [atom (p TWO) ] .
    decide2 (E{ stepPerp}) .
    existential (Z).
    tensor [perp (p Z) ] [atom (p ONE) ].
  Qed.

  (** This is NOT a theorem ... Note that we cannot do induction on uexp terms *)
  Example test3 : |-- [ atom (p Z) ; E{ step} ]; []; > [F{ fun t => perp ( p t) }].
  Proof with solveLL.
    solveLL.
    induction x.
    (* this will never work *)
  Abort.

  Example test4 : |-- [ ]; []; > [F{ fun t => atom (p t)} ; E{ fun t => perp (p t)}].
  Proof.
    solveLL.
    decide1 (E{ fun t => perp (p t)}).
    existential x.
  Qed.

  Example test4' : forall x, proper x -> |-- [ ]; []; > [atom (p x) ; E{ fun t => perp (p t)}].
  Proof.
    intros.
    solveLL.
    decide1 (E{ fun t => perp (p t)}).
    existential x.
  Qed.
End Example2.


Require Export GeoCoq.Elements.OriginalProofs.lemma_samesidereflexive.
Require Export GeoCoq.Elements.OriginalProofs.lemma_sameside2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_samesidesymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_12.
Require Export GeoCoq.Elements.OriginalProofs.lemma_8_7.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_notperp :
   forall A B C P,
   BetS A C B -> nCol A B P ->
   exists X, nCol A B X /\ OS X P A B /\ ~ Per A C X.
Proof.
intros.
assert (neq C B) by (forward_using lemma_betweennotequal).
assert (neq B C) by (conclude lemma_inequalitysymmetric).
assert (~ eq C P).
 {
 intro.
 assert (nCol A B C) by (conclude cn_equalitysub).
 assert (Col A C B) by (conclude_def Col ).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists Q, (BetS B C Q /\ Cong C Q C P)) by (conclude lemma_extension);destruct Tf as [Q];spliter.
assert (~ eq P Q).
 {
 intro.
 assert (Col B C Q) by (conclude_def Col ).
 assert (Col B C P) by (conclude cn_equalitysub).
 assert (Col A C B) by (conclude_def Col ).
 assert (Col C B A) by (forward_using lemma_collinearorder).
 assert (Col C B P) by (forward_using lemma_collinearorder).
 assert (Col B A P) by (conclude lemma_collinear4).
 assert (Col A B P) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists M, (BetS P M Q /\ Cong M P M Q)) by (conclude proposition_10);destruct Tf as [M];spliter.
assert (Col A C B) by (conclude_def Col ).
assert (Col C B A) by (forward_using lemma_collinearorder).
assert (neq C B) by (forward_using lemma_betweennotequal).
assert (Col C B Q) by (conclude_def Col ).
assert (Col B A Q) by (conclude lemma_collinear4).
assert (Col A B Q) by (forward_using lemma_collinearorder).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (OS P P A B) by (conclude lemma_samesidereflexive).
assert (neq Q P) by (conclude lemma_inequalitysymmetric).
assert (BetS Q M P) by (conclude axiom_betweennesssymmetry).
assert (Out Q P M) by (conclude lemma_ray4).
assert (Col A Q B) by (forward_using lemma_collinearorder).
assert (OS P M A B) by (conclude lemma_sameside2).
assert (OS M P A B) by (forward_using lemma_samesidesymmetric).
assert (~ Col A B M).
 {
 intro.
 assert (Col B M Q) by (conclude lemma_collinear4).
 assert (Col P M Q) by (conclude_def Col ).
 assert (Col M Q P) by (forward_using lemma_collinearorder).
 assert (Col M Q B) by (forward_using lemma_collinearorder).
 assert (neq M Q) by (forward_using lemma_betweennotequal).
 assert (Col Q P B) by (conclude lemma_collinear4).
 assert (Col Q B P) by (forward_using lemma_collinearorder).
 assert (Col Q B A) by (forward_using lemma_collinearorder).
 assert (neq B Q) by (forward_using lemma_betweennotequal).
 assert (neq Q B) by (conclude lemma_inequalitysymmetric).
 assert (Col B P A) by (conclude lemma_collinear4).
 assert (Col A B P) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists R, Perp_at M R A B R) by (conclude proposition_12);destruct Tf as [R];spliter.
let Tf:=fresh in
assert (Tf:exists E, (Col M R R /\ Col A B R /\ Col A B E /\ Per E R M)) by (conclude_def Perp_at );destruct Tf as [E];spliter.
assert (Per M R E) by (conclude lemma_8_2).
assert (~ eq M R).
 {
 intro.
 assert (Col A B M) by (conclude cn_equalitysub).
 contradict.
 }
assert (neq A C) by (forward_using lemma_betweennotequal).
assert (Col A B C) by (forward_using lemma_collinearorder).
assert (~ Per A C M).
 {
 intro.
 assert (~ neq R C).
  {
  intro.
  assert (Col B A C) by (forward_using lemma_collinearorder).
  assert (Col B A R) by (forward_using lemma_collinearorder).
  assert (neq B A) by (conclude lemma_inequalitysymmetric).
  assert (Col A C R) by (conclude lemma_collinear4).
  assert (Per R C M) by (conclude lemma_collinearright).
  assert (~ Per M R C) by (conclude lemma_8_7).
  assert (Per E R M) by (conclude lemma_8_2).
  assert (Col B C R) by (conclude lemma_collinear4).
  assert (Col B C E) by (conclude lemma_collinear4).
  assert (neq C B) by (forward_using lemma_betweennotequal).
  assert (neq B C) by (conclude lemma_inequalitysymmetric).
  assert (Col C R E) by (conclude lemma_collinear4).
  assert (Col E R C) by (forward_using lemma_collinearorder).
  assert (neq C R) by (conclude lemma_inequalitysymmetric).
  assert (Per C R M) by (conclude lemma_collinearright).
  assert (Per M R C) by (conclude lemma_8_2).
  contradict.
  }
 assert (~ eq M C).
  {
  intro.
  assert (Col A B M) by (conclude cn_equalitysub).
  contradict.
  }
 assert (Cong Q C P C) by (forward_using lemma_congruenceflip).
 assert (BetS Q M P) by (conclude axiom_betweennesssymmetry).
 assert (Cong Q M P M) by (forward_using lemma_doublereverse).
 assert (Per Q M C) by (conclude_def Per ).
 assert (neq C Q) by (forward_using lemma_betweennotequal).
 assert (neq Q C) by (conclude lemma_inequalitysymmetric).
 assert (Per E R M) by (conclude lemma_8_2).
 assert (neq Q R) by (conclude cn_equalitysub).
 assert (Col B C Q) by (conclude_def Col ).
 assert (Col C B Q) by (forward_using lemma_collinearorder).
 assert (Col Q B C) by (forward_using lemma_collinearorder).
 assert (Col B E R) by (conclude lemma_collinear4).
 assert (Col B E Q) by (conclude lemma_collinear4).
 assert (~ neq B E).
  {
  intro.
  assert (Col E R Q) by (conclude lemma_collinear4).
  assert (Per Q R M) by (conclude lemma_collinearright).
  assert (Per Q C M) by (conclude cn_equalitysub).
  assert (Per M C Q) by (conclude lemma_8_2).
  assert (~ Per Q M C) by (conclude lemma_8_7).
  contradict.
  }
 assert (Col A E R) by (conclude cn_equalitysub).
 assert (Col A B Q) by (forward_using lemma_collinearorder).
 assert (Col A E Q) by (conclude cn_equalitysub).
 assert (neq A E) by (conclude cn_equalitysub).
 assert (Col E R Q) by (conclude lemma_collinear4).
 assert (Per Q R M) by (conclude lemma_collinearright).
 assert (Per Q C M) by (conclude cn_equalitysub).
 assert (Per M C Q) by (conclude lemma_8_2).
 assert (~ Per Q M C) by (conclude lemma_8_7).
 contradict.
 }
exists M;close.
Qed.

End Euclid.


(* Lemmas about binary sequences (the Cantor space). *)

From set_theory Require Import lib fn set seq.

Definition zeros := const false.
Definition ones := const true.

Notation "'C'" := (nat -> bool).
Notation "n >> α" := (shift n false α) (at level 20, format "n >> α").

Lemma cantor_eqn_union_S m α :
  Eqn m α = Eqn (S m) (pre m α zeros) ∪ Eqn (S m) (pre m α ones).
Proof.
apply incl_eq; intros β.
- intros Hβ. destruct (β m) eqn:B. 1: right. 2: left.
  1,2: apply eqn_S. 1,3: eapply eqn_trans.
  1,3: apply eqn_sym, eqn_pre. 1,2: easy.
  1,2: unfold pre, zeros, ones, const; now rewrite ltb_irrefl.
- intros [Hβ|Hβ]; apply eqn_incl with (m:=m) in Hβ.
  1,3: eapply eqn_trans. 1,3: apply eqn_pre. 1,2: apply Hβ. all: lia.
Qed.

(* A surjective enumeration of all prefixes in C using BinPos. *)
Require Import BinPos Pnat.
Section Enumerate_prefixes.

(* Convert prefix to positive number. *)
Fixpoint pre_encode n α :=
  match n with
  | 0 => xH
  | S m =>
    match α 0 with
    | false => xO (pre_encode m (1<<α))
    | true => xI (pre_encode m (1<<α))
    end
  end.

(* Ignore the last bit (xH). *)
Definition pre_size p := pred (Pos.size_nat p).
Definition pre_bit p i := if i <? pre_size p
  then Pos.testbit_nat p i else false.

(* Decode a natural number as a prefix in the Cantor space. *)
Definition pre_decode (n : nat) : nat * C :=
  let p := Pos.of_nat (S n) in (pre_size p, pre_bit p).

Lemma pre_size_xO p : pre_size (xO p) = S (pre_size p).
Proof. unfold pre_size; now destruct p. Qed.

Lemma pre_size_xI p : pre_size (xI p) = S (pre_size p).
Proof. unfold pre_size; now destruct p. Qed.

Lemma ltb_S m n : (S m <? S n) = (m <? n).
Proof. intros; destruct (m <? n) eqn:E; b_lia. Qed.

Lemma pre_size_S p n :
  Pos.size_nat p = S n -> pre_size p = n.
Proof.
unfold pre_size; destruct p; simpl; intros.
1-2: now apply eq_add_S. lia.
Qed.

Lemma pre_size_encode n α :
  pre_size (pre_encode n α) = n.
Proof.
apply pre_size_S.
revert α; induction n; simpl; intros. easy.
destruct (α 0); simpl. all: apply eq_S, IHn.
Qed.

Lemma eqn_pre_bit_encode m α :
  Eqn m α (pre_bit (pre_encode m α)).
Proof.
revert α; induction m; intros. easy. intros i Hi. destruct i.
- simpl; destruct (α 0); unfold pre_bit.
  now rewrite pre_size_xI. now rewrite pre_size_xO.
- apply succ_lt_mono in Hi; apply IHm with (α:=1<<α) in Hi.
  clear IHm. unfold del in Hi at 1; simpl in Hi.
  unfold pre_bit in *; simpl. destruct (α 0); simpl.
  now rewrite pre_size_xI, ltb_S. now rewrite pre_size_xO, ltb_S.
Qed.

Lemma pre_decode_to_nat p :
  pre_decode (pred (Pos.to_nat p)) = (pre_size p, pre_bit p).
Proof.
assert(H := Pos2Nat.is_pos p). destruct (Pos.to_nat p) eqn:E. easy.
unfold pre_decode; now rewrite ?pred_succ, <-E, Pos2Nat.id.
Qed.

Theorem pre_decode_surj m α :
  ∃n, fst (pre_decode n) = m /\ Eqn m α (snd (pre_decode n)).
Proof.
exists (pred (Pos.to_nat (pre_encode m α))).
rewrite pre_decode_to_nat; simpl; split.
apply pre_size_encode. apply eqn_pre_bit_encode.
Qed.

End Enumerate_prefixes.

(* We can order prefixes of the same length. *)
Section Prefix_order.

(* The prefix (m, α) comes before (m, β). *)
Definition PreLt m α β :=
  ∃i, i < m /\ Eqn i α β /\ α i = false /\ β i = true.

Variable X : P C.

(* (m, α) is the smallest non-empty prefix in X at depth m. *)
Definition MinPre m α := Eqn m α ∩ X ≠ ∅ /\
  ∀β, PreLt m β α -> Eqn m β ∩ X = ∅.

(* We can retract the property MinPre. *)
Lemma min_pre_incl m :
  MinPre (S m) ⊆ MinPre m.
Proof.
intros α [H1 H2]; split.
- apply not_empty in H1 as [β [H1β H2β]]; apply not_empty; exists β; split.
  eapply eqn_incl. 2: apply H1β. lia. easy.
- intros β [i [H1i [H2i H3i]]]; apply NNPP; intros Hneg.
  apply not_empty in Hneg as [γ [H1γ H2γ]].
  eapply PNNP. apply H2 with (β:=γ); exists i; repeat split. lia.
  eapply eqn_trans. apply eqn_sym, eqn_incl with (n:=m). lia.
  apply H1γ. easy. now rewrite <-H1γ. easy. apply not_empty; now exists γ.
Qed.

(* A minimal prefix is unique. *)
Lemma min_pre_unique m α β :
  MinPre m α -> MinPre m β -> Eqn m α β.
Proof.
intros Hα Hβ; apply NNPP; intros H.
apply not_all_ex_not in H as [i Hi]; apply imply_to_and in Hi as [H1i H2i].
apply find_first_split in H2i as [n [H1n [H2n H3n]]]. 2: apply bool_dec.
destruct (α n) eqn:A, (β n) eqn:B; try easy; clear H3n; exfalso.
- apply Hβ, Hα. exists n; repeat split; try easy. lia. now apply eqn_sym.
- apply Hα, Hβ. exists n; repeat split; try easy. lia.
Qed.

(* PreLt successor cases. *)
Lemma pre_lt_S m α β :
  PreLt (S m) α β -> PreLt m α β \/
  (Eqn m α β /\ α m = false /\ β m = true).
Proof.
intros [i [H1i [H2i H3i]]]; apply lt_S in H1i as [H|H].
left; now exists i. subst; now right.
Qed.

(* PreLt on a prefix. *)
Lemma pre_lt_pre m α β γ :
  PreLt m α (pre m β γ) -> PreLt m α β.
Proof.
intros [i [H1i [H2i H3i]]]; unfold pre in H3i.
replace (i <? m) with true in H3i by b_lia.
exists i; repeat split; try easy. eapply eqn_trans. apply H2i.
intros j Hj; unfold pre; now replace (j <? m) with true by b_lia.
Qed.

(* A non-empty set has a smallest prefix at every depth. *)
Lemma min_pre_ex m :
  X ≠ ∅ -> ∃α, MinPre m α.
Proof.
intros HX; induction m.
- exists zeros. apply not_empty in HX as [α Hα]; split.
  apply not_empty; now exists α. now intros β [i [Hi _]].
- destruct IHm as [α [H1α H2α]].
  destruct (classic (MinPre (S m) (pre m α ones))).
  now exists (pre m α ones). exists (pre m α zeros); split.
  + apply not_and_or in H as [H|H]. apply NNPP in H. intros Hneg; apply H1α.
    now rewrite cantor_eqn_union_S, isect_distr_union, H, Hneg, union_empty.
    apply not_all_ex_not in H as [β Hβ];
    apply imply_to_and in Hβ as [H1β H2β];
    apply pre_lt_S in H1β as [H1β|H1β].
    * apply pre_lt_pre in H1β; apply H2α in H1β.
      exfalso; apply H2β. eapply incl_empty. 2: apply H1β.
      apply incl_isect_incl, eqn_incl; lia.
    * assert(Eqn (S m) β (pre m α zeros)). {
        apply eqn_S. eapply eqn_trans. apply H1β.
        intros i Hi; unfold pre; now replace (i <? m) with true by b_lia.
        unfold pre; rewrite ltb_irrefl. easy. }
      apply eqn_eq in H; now rewrite <-H.
  + intros β Hβ; apply pre_lt_S in Hβ as [Hβ|Hβ].
    * apply pre_lt_pre in Hβ; apply H2α in Hβ.
      eapply incl_empty. 2: apply Hβ. apply incl_isect_incl, eqn_incl; lia.
    * unfold pre in Hβ; now rewrite ltb_irrefl in Hβ.
Qed.

End Prefix_order.


(* Topology by James R. Munkres *)

(*** Chapter 1 - Set Theory and Logic ***)

Require Export Coq.Sets.Ensembles.

Variable U : Type.

Theorem ex_1_1_1_a : forall A B C: Ensemble U,
  Intersection U A (Union U B C) = Union U (Intersection U A B) (Intersection U A C).
(* I need to figure out how to make this less messy, since U is obvious yet causes a lot of unnecessary errors due to sheer forgetfulness.*)
Proof.
  intros A B C.
Admitted.

Theorem ex_1_1_1_b : forall A B C: Ensemble U,
  Union U A (Intersection U B C) = Intersection U (Union U A B) (Union U A C).
Proof.
  intros.
Admitted.

Theorem ex_1_1_1_c : forall A B C: Ensemble U,
  Setminus U A (Union U B C) = Intersection U (Setminus U A B) (Setminus U A C).
Proof.
  intros.
  unfold Setminus.

Admitted.

Theorem ex_1_1_1_d : forall A B C: Ensemble U,
  Setminus U A (Intersection U B C) = Union U (Setminus U A B) (Setminus U A C).
Proof.
  intros.
Admitted.


Set Warnings "-notation-overridden".

Require Import Category.Theory.
Require Import Category.Structure.Monoidal.
Require Import Category.Lib.
Require Import Category.Structure.Monoidal.Proofs.

Require Import Enriched.Category.
Require Import Enriched.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Lib.
Context {V0: Category} {V : Monoidal}.

Section Category.

Definition ehom0 {C : EnrichedCategory} x y := I ~> (ehom x y).

Definition ecompose0 {C : EnrichedCategory} {x y z} (f : ehom0 y z) (g : ehom0 x y):= (ecompose ∘ bimap f g ∘ unit_right⁻¹)%morphism.

Definition precompose {C : EnrichedCategory} {x y} (f : ehom0 x y) {z} : ehom y z ~> ehom x z := (ecompose ∘ id ⨂ f ∘ unit_right⁻¹)%morphism.

Definition postcompose {C : EnrichedCategory} {x y} (f : ehom0 x y) {z} : ehom z x ~> ehom z y := (ecompose ∘ f ⨂ id ∘ unit_left⁻¹)%morphism.

Lemma pre_post_commute {C : EnrichedCategory} {x y z w} {f : ehom0 x y} {g : ehom0 z w} : ((postcompose g) ∘ (precompose f) ≈ (precompose f) ∘ (postcompose g))%morphism.
Proof.
  unfold postcompose, precompose.
  rewrite (comp_assoc_sym _ unit_left⁻¹ _)%morphism.
  rewrite <- from_unit_left_natural.
  rewrite (comp_assoc_sym _ unit_right⁻¹ _)%morphism.
  rewrite (comp_assoc unit_right⁻¹ (ecompose ∘ g ⨂ id[ehom y z]))%morphism.
  rewrite <- from_unit_right_natural.
  normal.
  transitivity (ecompose ∘ (id ⨂ ecompose ∘ g ⨂ (id[ehom y z] ⨂ f) ∘ id ⨂ unit_right⁻¹) ∘ unit_left⁻¹)%morphism.
  do 2 rewrite <- bimap_comp.
  normal.
  reflexivity.
  transitivity (ecompose ∘ (ecompose ⨂ id ∘ (g ⨂ id[ehom y z]) ⨂ f) ∘ unit_right⁻¹ ∘ unit_left⁻¹)%morphism.
  Focus 2.
  rewrite <- bimap_comp.
  normal.
  reflexivity.
  repeat rewrite comp_assoc.
  rewrite ecomp_assoc.
  repeat rewrite comp_assoc_sym.
  do 2 f_equiv.
  repeat rewrite comp_assoc.
  f_equiv.
  rewrite <- to_tensor_assoc_natural.
  repeat rewrite comp_assoc_sym.
  f_equiv.
  transitivity (id ⨂ unit_right⁻¹ ∘ (id ⨂ unit_right : I ⨂ (ehom y z ⨂ I) ~> I ⨂ ehom y z) ∘ tensor_assoc ∘ unit_right⁻¹)%morphism.
  transitivity ((id ⨂ unit_right⁻¹ : I ⨂ ehom y z ~> I ⨂ (ehom y z ⨂ I)) ∘ (unit_right ∘ unit_right⁻¹))%morphism.
  rewrite iso_to_from.
  normal.
  reflexivity.
  Focus 2.
  rewrite <- bimap_comp.
  rewrite iso_from_to.
  normal.
  reflexivity.
  rewrite (comp_assoc_sym (id[I] ⨂ unit_right⁻¹) (id[I] ⨂ unit_right)).
  assert (unit_right << (I ⨂ ehom y z) ⨂ I ~~> I ⨂  ehom y z >> id[I] ⨂ unit_right ∘ tensor_assoc)%morphism.
  {
    rewrite triangle_identity_right.
    rewrite comp_assoc_sym.
    rewrite iso_from_to.
    normal.
    reflexivity.
  }
  rewrite X.
  normal.
  reflexivity.
Qed.

(* TODO: give a better name *)
Lemma lib_l1 {x} : (tensor_assoc ∘ unit_right⁻¹ ⨂ id[I] ≈ id[x] ⨂ unit_right⁻¹)%morphism.
Proof.
  transitivity (id[x] ⨂ unit_right⁻¹ ∘ id ⨂ unit_right ∘ tensor_assoc ∘ unit_right⁻¹ ⨂ id[I])%morphism.
  normal.
  rewrite iso_from_to.
  normal.
  reflexivity.
  rewrite (comp_assoc_sym (id ⨂ unit_right⁻¹)).
  rewrite <- bimap_triangle_right.
  rewrite <- id_unit_right.
  normal.
  rewrite iso_to_from.
  reflexivity.
Qed.

Lemma pre_comp {C : EnrichedCategory} {x y z w} {f : ehom0 x y} {g : ehom0 y z} : (precompose (z:=w) (ecompose0 g f) ≈ precompose f ∘ precompose g)%morphism.
Proof.
  unfold precompose, ecompose0.
  rewrite (comp_assoc_sym _ unit_right⁻¹).
  rewrite <- from_unit_right_natural.
  normal.
  assert ((ecompose ∘ id[ehom z w] ⨂ g ∘ unit_right⁻¹) ⨂ f ≈ ecompose ⨂ id ∘ (id[ehom z w] ⨂ g) ⨂ f ∘ unit_right⁻¹ ⨂ id)%morphism.
  {
    normal.
    reflexivity.
  }
  rewrite X;clear X.
  repeat rewrite comp_assoc.
  rewrite ecomp_assoc.
  rewrite (comp_assoc_sym _ tensor_assoc).
  rewrite <- to_tensor_assoc_natural.
  normal.
  rewrite (comp_assoc_sym _ tensor_assoc).
  rewrite lib_l1.
  normal.
  rewrite (comp_assoc_sym _ (id ⨂ ecompose)).
  rewrite <- bimap_comp.
  normal.
  reflexivity.
Qed.

Lemma post_comp {C : EnrichedCategory} {x y z w} {f : ehom0 x y} {g : ehom0 y z} : (postcompose (z:=w) (ecompose0 g f) ≈ postcompose g ∘ postcompose f)%morphism.
Proof.
  unfold postcompose, ecompose0.
  rewrite (comp_assoc_sym _ unit_left⁻¹).
  rewrite <- from_unit_left_natural.
  normal.
  f_equiv.
  assert (g ⨂ (ecompose ∘ f ⨂ id[ehom w x] ∘ unit_left⁻¹) ≈ id ⨂ ecompose ∘ tensor_assoc ∘ (g ⨂ f) ⨂ id ∘ tensor_assoc⁻¹ ∘ id ⨂ unit_left⁻¹)%morphism.
  {
    rewrite (comp_assoc_sym _ tensor_assoc).
    rewrite <- to_tensor_assoc_natural.
    rewrite (comp_assoc_sym _ _ tensor_assoc⁻¹), (comp_assoc_sym _ tensor_assoc).
    rewrite iso_to_from.
    normal.
    reflexivity.
  }
  rewrite X;clear X.
  repeat rewrite comp_assoc.
  rewrite <- ecomp_assoc.
  normal.
  assert (tensor_assoc⁻¹ ∘ id[I] ⨂ unit_left⁻¹ ≈ unit_right⁻¹ ⨂ id[ehom w x])%morphism.
  {
    transitivity (unit_right⁻¹⨂ id[ehom w x] ∘ unit_right ⨂ id ∘ tensor_assoc⁻¹ ∘ id[I] ⨂ unit_left⁻¹)%morphism.
    normal.
    rewrite iso_from_to.
    normal.
    reflexivity.
    rewrite (comp_assoc_sym (unit_right⁻¹ ⨂ id)).
    rewrite <- inverse_triangle_identity.
    rewrite comp_assoc_sym.
    normal.
    rewrite iso_to_from.
    reflexivity.
  }
  rewrite (comp_assoc_sym _ tensor_assoc⁻¹).
  rewrite X.
  normal.
  reflexivity.
Qed.

Lemma pre_id {C : EnrichedCategory} {x y} : precompose eid ≈ id[ehom x y].
Proof.
  unfold precompose.
  rewrite eid_right.
  apply iso_to_from.
Qed.

Lemma post_id {C : EnrichedCategory} {x y} : postcompose eid ≈ id[ehom x y].
Proof.
  unfold postcompose.
  rewrite eid_left.
  apply iso_to_from.
Qed.

Lemma ecomp0_id_left {C : EnrichedCategory} {x y} (f : ehom0 x y) : ecompose0 eid f ≈ f.
Proof.
  unfold ecompose0.
  transitivity (ecompose ∘ eid ⨂ id ∘ id ⨂ f ∘ unit_right⁻¹)%morphism.
  rewrite (comp_assoc_sym _ (eid ⨂ id)).
  rewrite <- bimap_comp.
  normal.
  reflexivity.
  rewrite eid_left.
  rewrite <- to_unit_left_natural.
  rewrite unit_identity.
  rewrite comp_assoc_sym.
  rewrite iso_to_from.
  normal.
  reflexivity.
Qed.

Lemma ecomp0_id_right {C : EnrichedCategory} {x y} (f : ehom0 x y) : ecompose0 f eid ≈ f.
Proof.
  unfold ecompose0.
  transitivity (ecompose ∘ id ⨂ eid ∘ f ⨂ id ∘ unit_right⁻¹)%morphism.
  rewrite (comp_assoc_sym _ (id ⨂ eid)).
  rewrite <- bimap_comp.
  normal.
  reflexivity.
  rewrite eid_right.
  rewrite <- to_unit_right_natural.
  rewrite comp_assoc_sym.
  rewrite iso_to_from.
  normal.
  reflexivity.
Qed.

Lemma ecomp0_assoc {C : EnrichedCategory} {x y z w} {f : ehom0 x y} {g : ehom0 y z} {h : ehom0 z w} : ecompose0 (ecompose0 h g) f ≈ ecompose0 h (ecompose0 g f).
Proof.
  unfold ecompose0.
  f_equiv.
  transitivity (ecompose ∘ ecompose ⨂ id ∘ (h ⨂ g) ⨂ f ∘ unit_right⁻¹ ⨂ id)%morphism.
  normal.
  reflexivity.
  rewrite ecomp_assoc.
  rewrite (comp_assoc_sym _ tensor_assoc).
  rewrite <- to_tensor_assoc_natural.
  repeat rewrite comp_assoc_sym.
  rewrite lib_l1.
  normal.
  reflexivity.
Qed.

Lemma ecompose0_precompose {C : EnrichedCategory} {x y z} {f : ehom0 y z} {g : ehom0 x y} : ecompose0 f g ≈ (precompose g ∘ f)%morphism.
Proof.
  unfold ecompose0, precompose.
  rewrite (comp_assoc_sym _ _ f).
  rewrite <- from_unit_right_natural.
  rewrite comp_assoc.
  rewrite (comp_assoc_sym _ (id ⨂ g)).
  rewrite <- bimap_comp.
  normal.
  reflexivity.
Qed.

Lemma ecompose0_postcompose {C : EnrichedCategory} {x y z} {f : ehom0 y z} {g : ehom0 x y} : ecompose0 f g ≈ (postcompose f ∘ g)%morphism.
Proof.
  unfold ecompose0, postcompose.
  rewrite (comp_assoc_sym _ _ g).
  rewrite <- from_unit_left_natural.
  rewrite comp_assoc.
  rewrite (comp_assoc_sym _ _ (id ⨂ g)).
  rewrite <- bimap_comp.
  normal.
  assert (unit_right⁻¹ ≈ unit_left⁻¹).
  {
    apply (iso_epic unit_left).
    rewrite iso_from_to.
    rewrite unit_identity.
    rewrite iso_from_to.
    reflexivity.
  }
  rewrite X.
  reflexivity.
Qed.

Global Program Definition ecompose0_respects {C : EnrichedCategory} {x y z} :
  Proper (equiv ==> equiv ==> equiv) (@ecompose0 C x y z).
Proof.
  proper.
  unfold ecompose0.
  rewrite X, X0.
  reflexivity.
Qed.

End Category.

Section Functor.

Definition efmap0 {C D : EnrichedCategory} {F : C ⟶ D} (x y : C) (f : ehom0 x y) : ehom0 (F x) (F y) := (efmap ∘ f)%morphism.

Lemma efmap_comp0 {C D : EnrichedCategory} {F : C ⟶ D} (x y z : C) (f : ehom0 y z) (g : ehom0 x y) : efmap0 x z (ecompose0 f g) ≈ ecompose0 (efmap0 y z f) (efmap0 x y g).
Proof.
  unfold efmap0, ecompose0.
  normal.
  rewrite <- efmap_comp.
  normal.
  reflexivity.
Qed.

Lemma efmap_id0 {C D : EnrichedCategory} {F : C ⟶ D} (x : C) : efmap0 x x eid ≈ eid.
Proof.
  unfold efmap0.
  apply efmap_id.
Qed.

End Functor.
End Lib.


Require Import VST.floyd.proofauto.
Require Import CertiGraph.binheap.binary_heap.
Require Import CertiGraph.binheap.binary_heap_model.
Require Import CertiGraph.binheap.binary_heap_Zmodel.
Require Import RelationClasses.
(* Require Import VST.floyd.sublist. *)

Set Nested Proofs Allowed.

(* Relation on heap items. *)
Definition heap_item : Type := (int * int)%type.
Definition cmp (a b : heap_item) : bool :=
  negb (Int.lt (fst b) (fst a)).
Definition cmp_rel (a b : heap_item) : Prop :=
  cmp a b = true.
Lemma cmp_dec: forall a a', {cmp_rel a a'} + {~cmp_rel a a'}.
Proof.
  intros [? ?] [? ?]. unfold cmp_rel, cmp. simpl. case (Int.lt i1 i); simpl; auto.
Qed.
Instance cmp_po: PreOrder cmp_rel.
Proof.
  constructor. intros [? ?]. red. unfold cmp. simpl. case_eq (Int.lt i i); auto; intro. exfalso.
  apply lt_inv in H. lia.
  intros [? ?] [? ?] [? ?]. unfold cmp_rel, cmp. simpl.
  case_eq (Int.lt i3 i); auto.
  case_eq (Int.lt i1 i); auto.
  case_eq (Int.lt i3 i1); auto. simpl.
  intros ? ? ?. exfalso.
  apply lt_inv in H1.
  apply lt_false_inv in H.
  apply lt_false_inv in H0.
  lia.
Qed.
Lemma cmp_linear: forall a b,
  cmp_rel a b \/ cmp_rel b a.
Proof.
  intros [? ?] [? ?]. unfold cmp_rel, cmp; simpl.
  case_eq (Int.lt i1 i); auto. intro.
  right.
  case_eq (Int.lt i i1); auto. intro. exfalso.
  apply lt_inv in H. apply lt_inv in H0.
  lia.
Qed.

(* Not sure if it's a great idea to expose the capacity inside the abstraction boundary. *)
Definition heap : Type := (nat * list heap_item)%type.
Instance heap_inhabitant : Inhabitant heap := (O, []).
Definition heap_capacity (h : heap) : Z := Z.of_nat (fst h).
Definition heap_items (h : heap) : list heap_item := snd h.
Definition heap_size (h : heap) : Z := Zlength (heap_items h).

(*
Definition heap_permutation (h1 h2 : heap) : Prop :=
  heap_capacity h1 = heap_capacity h2 /\ Permutation (heap_items h1) (heap_items h2).
*)

Definition heap_ordered := binary_heap_model.heapOrdered heap_item cmp_rel.
Definition heap_ordered_bounded (L : list heap_item) (b : Z) :=
  binary_heap_model.heapOrdered_bounded heap_item cmp_rel L (Z.to_nat b).
Definition weak_heap_ordered_bottom_up (L : list heap_item) (x : Z) :=
  binary_heap_model.weak_heapOrdered2 heap_item cmp_rel L (Z.to_nat x).
Definition weak_heap_ordered_top_down_bounded (L : list heap_item) (b : Z) (x : Z) :=
  binary_heap_model.weak_heapOrdered_bounded heap_item cmp_rel L (Z.to_nat b) (Z.to_nat x).
Definition swim := binary_heap_model.swim heap_item cmp_rel cmp_dec.
Definition sink L i := binary_heap_model.sink heap_item cmp_rel cmp_dec (L,i).
Definition build_heap_helper L i := binary_heap_model.build_heap_helper heap_item cmp_rel cmp_dec L i.
(* Definition insert := binary_heap_model.insert heap_item cmp_rel cmp_dec. *)
(* Definition remove_min := binary_heap_model.remove_min heap_item cmp_rel cmp_dec. *)

Lemma Zparent_repr: forall i,
  0 < i <= Int.max_unsigned ->
  Int.repr (Zparent i) = Int.divu (Int.repr (i - 1)) (Int.repr 2).
Proof.
  intros. unfold Int.divu. repeat rewrite Int.unsigned_repr.
  2,3: rep_lia. rewrite Zparent_unfold. trivial. lia.
Qed.

(* This may get bundled elsewhere at some point. *)
Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Global Existing Instance CompSpecs.

Definition t_item := Tstruct _structItem noattr.
Definition t_pq := Tstruct _structPQ noattr.

Definition heap_item_rep (i : heap_item) : reptype t_item :=
  (Vint (fst i), Vint (snd i)).

Definition hitem (i : heap_item) : val -> mpred :=
  data_at Tsh t_item (heap_item_rep i).

Definition harray (contents : list heap_item) : val -> mpred :=
  data_at Tsh (tarray t_item (Zlength contents)) (map heap_item_rep contents).

Lemma harray_emp: forall arr,
  harray [] arr |-- emp.
Proof.
  unfold harray. intros. rewrite data_at_isptr. entailer. rewrite data_at_zero_array_eq; auto.
Qed.

Lemma fold_harray': forall L i arr,
  i = Zlength L ->
  data_at Tsh (tarray t_item i) (map heap_item_rep L) arr = harray L arr.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma fold_harray: forall L arr,
  data_at Tsh (tarray t_item (Zlength L)) (map heap_item_rep L) arr = harray L arr.
Proof. reflexivity. Qed.

Lemma harray_split: forall L1 L2 ptr,
  harray (L1 ++ L2) ptr =
  ((harray L1 ptr) *
   (harray L2 (field_address0 (tarray t_item (Zlength (L1 ++ L2))) [ArraySubsc (Zlength L1)] ptr)))%logic.
Proof.
  intros. unfold harray.
  rewrite map_app.
  erewrite split2_data_at_Tarray_app.
  2: rewrite Zlength_map; reflexivity. 2: rewrite Zlength_app, Zlength_map; lia.
  rewrite Zlength_app.
  replace (Zlength L1 + Zlength L2 - Zlength L1) with (Zlength L2) by lia.
  trivial.
Qed.

Definition valid_pq (pq : val) (h: heap): mpred :=
  EX arr : val, EX junk: list heap_item,
    (!! heap_ordered (heap_items h)) && (!! (Zlength ((heap_items h) ++ junk) = heap_capacity h)) &&
    (!! (2 * (heap_capacity h - 1) <= Int.max_unsigned)) &&
    (data_at Tsh t_pq (Vint (Int.repr (heap_capacity h)), (Vint (Int.repr (heap_size h)), arr)) pq *
       harray ((heap_items h) ++ junk) arr).