Require Import List.

Require Import CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Print pred.
Extraction pred.

Lemma zgtz : 0 > 0 -> False.
  crush.
Qed.

Definition pred_strong1 (n : nat) : n > 0 -> nat :=
  match n with
    | O => fun pf : 0 > 0 => match zgtz pf with end
    | S n' => fun _ => n'
  end.

Theorem two_gt0 : 2 > 0.
  crush.
Qed.

Eval compute in pred_strong1 two_gt0.

Definition pred_strong1' (n : nat) : n > 0 -> nat :=
  match n return n > 0 -> nat with
    | O => fun pf : 0 > 0 => match zgtz pf with end
    | S n' => fun _ => n'
  end.

Extraction pred_strong1.

Print sig.

Locate "{ _ : _ | _ }".

Definition pred_strong2 (s : {n : nat | n > 0}) : nat :=
  match s with
    | exist O pf => match zgtz pf with end
    | exist (S n') _ => n'
  end.

Eval compute in pred_strong2 (exist _ 2 two_gt0).

Extraction pred_strong2.

Definition pred_strong3 (s : {n : nat | n > 0}) : {m : nat | proj1_sig s = S m} :=
match s return {m : nat | proj1_sig s = S m} with
  | exist 0 pf => match zgtz pf with end
  | exist (S n') pf => exist _ n' (eq_refl _)
end.

Eval compute in pred_strong3 (exist _ 2 two_gt0).

Extraction pred_strong3.

Definition pred_strong4 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
      | O => fun _ => False_rec _ _
      | S n' => fun _ => exist _ n' _
    end).
  Undo.
  refine (fun n =>
    match n with
      | O => fun _ => False_rec _ _
      | S n' => fun _ => exist _ n' _
    end); crush.
Defined.

Print pred_strong4.

Eval compute in pred_strong4 two_gt0.

Definition pred_strong4' : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
      | O => fun _ => False_rec _ _
      | S n' => fun _ => exist _ n' _
    end); abstract crush.
Defined.

Print pred_strong4'.

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

Definition pred_strong5 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
      | O => fun _ => !
      | S n' => fun _ => [n']
    end); crush.
Defined.

Eval compute in pred_strong5 two_gt0.

Obligation Tactic := crush.

Program Definition pred_strong6 (n : nat) (_ : n > 0) : {m : nat | n = S m} :=
  match n with
    | O => _
    | S n' => n'
  end.

Eval compute in pred_strong6 two_gt0.


(** DEPRECATED?
    \o notation for composition is used in LibFixDemos
*)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Functions                                                               *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibContainer LibSet.
Generalizable Variables A.

(* ********************************************************************** *)
(** ** Indentity function *)

Definition id {A} (x : A) :=
  x.

(* ********************************************************************** *)
(** Constant functions *)

Definition const {A B} (v : B) : A -> B :=
  fun _ => v.
Definition const1 :=
  @const.
Definition const2 {A1 A2 B} (v:B) : A1->A2->B :=
  fun _ _ => v.
Definition const3 {A1 A2 A3 B} (v:B) : A1->A2->A3->B :=
  fun _ _ _ => v.
Definition const4 {A1 A2 A3 A4 B} (v:B) : A1->A2->A3->A4->B :=
  fun _ _ _ _ => v.
Definition const5 {A1 A2 A3 A4 A5 B} (v:B) : A1->A2->A3->A4->A5->B :=
  fun _ _ _ _ _ => v.

(* ********************************************************************** *)
(** Function application *)

Definition apply {A B} (f : A -> B) (x : A) :=
  f x.

Definition apply_to (A : Type) (x : A) (B : Type) (f : A -> B) :=
  f x.

(* ********************************************************************** *)
(** Function composition *)

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

Notation "f1 \o f2" := (compose f1 f2)
  (at level 49, right associativity) : fun_scope.

Section Combinators.
Open Scope fun_scope.
Variables (A B C D : Type).

Lemma compose_id_l : forall (f:A->B),
  id \o f = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_id_r : forall (f:A->B),
  f \o id = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_assoc : forall (f:C->D) (g:B->C) (h:A->B),
  (f \o g) \o h = f \o (g \o h).
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_eq_l : forall (f:B->C) (g1 g2:A->B),
  g1 = g2 -> f \o g1 = f \o g2.
Proof using. intros. subst~. Qed.

Lemma compose_eq_r : forall (f:A->B) (g1 g2:B->C),
  g1 = g2 -> g1 \o f = g2 \o f.
Proof using. intros. subst~. Qed.

(** Composition of [LibList.map] behaves well. **)
(* Could not be put in [LibList] because of circular dependencies. *)
From TLC Require Import LibList.

Lemma list_map_compose : forall A B C (f : A -> B) (g : B -> C) l,
  LibList.map g (LibList.map f l) = LibList.map (g \o f) l.
Proof using.
  introv. induction l.
   reflexivity.
   rew_listx. fequals~.
Qed.

End Combinators.

(** Tactic for simplifying function compositions *)
(* --TODO: not used; might become deprecated *)

Hint Rewrite compose_id_l compose_id_r compose_assoc : rew_compose.
Tactic Notation "rew_compose" :=
  autorewrite with rew_compose.
Tactic Notation "rew_compose" "in" "*" :=
  autorewrite with rew_compose in *.
Tactic Notation "rew_compose" "in" hyp(H) :=
  autorewrite with rew_compose in H.

(* ********************************************************************** *)
(** ** Function update *)

(** [fupdate f a b x] is like [f] except that it returns [b] for input [a] *)

Definition fupdate A B (f : A -> B) (a : A) (b : B) : A -> B :=
  fun x => If (x = a) then b else f x.

Lemma fupdate_eq : forall A B (f:A->B) a b x,
  fupdate f a b x = If (x = a) then b else f x.
Proof using. auto. Qed.

Lemma fupdate_same : forall A B (f:A->B) a b,
  fupdate f a b a = b.
Proof using. intros. unfold fupdate. case_if*. Qed.

Lemma fupdate_neq : forall A B (f:A->B) a b x,
  x <> a ->
  fupdate f a b x = f x.
Proof using. intros. unfold fupdate. case_if*. Qed.

(* Opaque fupdate. -- could be added in the future *)

(* ********************************************************************** *)
(** ** Function image *)

Section FunctionImage.
Open Scope set_scope.
From TLC Require Import LibList.

Definition image A B (f : A -> B) (E : set A) : set B :=
  \set{ y | exists_ x \in E, y = f x }.

Lemma in_image_prove_eq : forall A B x (f : A -> B) (E : set A),
  x \in E -> f x \in image f E.
Proof using. introv N. unfold image. rew_set. exists* x. Qed.

Lemma in_image_prove : forall A B x y (f : A -> B) (E : set A),
  x \in E -> y = f x -> y \in image f E.
Proof using. intros. subst. applys* in_image_prove_eq. Qed.

Lemma in_image_inv : forall A B y (f : A -> B) (E : set A),
  y \in image f E -> exists x, x \in E /\ y = f x.
Proof using. introv N. unfolds image. rew_set in N. auto. Qed.

Lemma finite_image : forall A B (f : A -> B) (E : set A),
  finite E ->
  finite (image f E).
Proof using.
  introv M. lets (L&H): finite_inv_list_covers M.
  applys finite_of_list_covers (LibList.map f L). introv N.
  lets (y&Hy&Ey): in_image_inv (rm N). subst x. applys* mem_map.
Qed.

Lemma image_covariant : forall A B (f : A -> B) (E F : set A),
  E \c F ->
  image f E \c image f F.
Proof using.
  introv. do 2 rewrite incl_in_eq. introv M N.
  lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
Qed.

Lemma image_union : forall A B (f : A -> B) (E F : set A),
  image f (E \u F) = image f E \u image f F.
Proof using.
  Hint Resolve in_image_prove.
  introv. apply in_extens. intros x. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_union_eq in Hy.
     rewrite in_union_eq. destruct* Hy.
    rewrite in_union_eq in N. destruct N as [N|N].
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
Qed.

Lemma image_singleton : forall A B (f : A -> B) (x : A),
  image f \{x} = \{f x}.
Proof using.
  intros. apply in_extens. intros z. rewrite in_single_eq. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_single_eq in Hy. subst~.
    applys* in_image_prove. rewrite~ @in_single_eq. typeclass.
Qed.

End FunctionImage.

Hint Resolve finite_image : finite.

(* ********************************************************************** *)
(** ** Function preimage *)

Section FunctionPreimage.
Open Scope set_scope.

Definition preimage A B (f : A -> B) (E : set B) : set A :=
  \set{ x | exists_ y \in E, y = f x }.

End FunctionPreimage.

(* ********************************************************************** *)
(** ** Function iteration *)

Fixpoint applyn A n (f : A -> A) x :=
  match n with
  | O => x
  | S n' => f (applyn n' f x)
  end.

Lemma applyn_fix : forall A n f (x : A),
  applyn (S n) f x = applyn n f (f x).
Proof using. introv. induction~ n. simpls. rewrite~ IHn. Qed.

Lemma applyn_comp : forall A n m f (x : A),
  applyn n f (applyn m f x) = applyn (n + m) f x.
Proof using.
  introv. gen m; induction n; introv; simpls~.
  rewrite~ IHn.
Qed.

Lemma applyn_nested : forall A n m f (x : A),
  applyn n (applyn m f) x = applyn (n * m) f x.
Proof using.
  introv. gen m. induction n; introv; simpls~.
  rewrite IHn. rewrite~ applyn_comp.
Qed.

Lemma applyn_altern : forall A B (f : A -> B) (g : B -> A) x n,
  applyn n (fun x => f (g x)) (f x) =
    f (applyn n (fun x => g (f x)) x).
Proof using. introv. gen x. induction~ n. introv. repeat rewrite applyn_fix. autos~. Qed.

Lemma applyn_ind : forall A (P : A -> Prop) (f : A -> A) x n,
  (forall x, P x -> P (f x)) ->
  P x ->
  P (applyn n f x).
Proof using. introv I. induction n; introv Hx; autos*. Qed.

(* --TODO: rename applyn to iter *)
(* --TODO: migrate iteration of functionals from LibFix to here *)


(** **** Exercise: 5 stars, standard (linsearch_correct)  *)

(** Prove that [linsearch] is correct. The simpler your
    implementations of [linsearch] and [get], the better.

    Hints: Start by inducting on the input list. The proof is somewhat
    long and requires a lot of [destruct] and [bdestruct] but only the
    one use of [induction]. We leave it to you to discover and factor
    out any helper lemmas you might like. You do not need to write any
    fancy Ltac automation. *)

Theorem linsearch_correct : correct_search linsearch.

(** We repeat the definition of [sorted] from _Software Foundations_:
    *)

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted nil
| sorted_1 : forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
    x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

(** Now we specify what it means to be a correct search function. This
    definition is a formal rendition of the informal specification of
    the correctness of [linsearch] as given above. *)

Definition correct_search f :=
  forall (a : list nat) (v : nat) (k : nat),
    sorted a
    -> f a v = k
    -> (forall i, 1 <= i <= k ->
            forall u, get a i = Some u -> u <= v)
    /\ (forall i, k < i <= length a ->
            forall u, get a i = Some u -> u > v).

Lemma bounds_helper : forall i j,
    1 <= S i <= S j -> i > 0 -> 1 <= i <= j.

Lemma linsearch_helper : forall h t v k,
    v < h
    -> sorted (h :: t)
    -> linsearch (h :: t) v = k
    -> k = 0 /\ linsearch t v = 0.

Lemma sorted_helper : forall h t,
    sorted (h :: t) -> sorted t.


(*|
###############################
How to optimize a search in Coq
###############################

:Link: https://stackoverflow.com/q/19747308
|*)

(*|
Question
********

I have a simple search function for a property that I am interested
in, and a proof that the function is correct. I want to evaluate the
function, and use the correctness proof to get the theorem for the
original property. Unfortunately, evaluation in Coq is very slow. As a
trivial example, consider looking for square roots:
|*)

(* Coq 8.4
   A simple example to demonstrate searching.
   Timings are rough and approximate. *)

Require Import Peano_dec.

Definition SearchSqrtLoop :=
  fix f i n := if eq_nat_dec (i * i) n
               then i
               else match i with
                    | 0 => 0 (* ~ Square n \/ n = 0 *)
                    | S j => f j n
                    end.

Definition SearchSqrt n := SearchSqrtLoop n n.

(* Compute SearchSqrt 484.
   takes about 30 seconds. *)

Theorem sqrt_484a : SearchSqrt 484 = 22.
  apply eq_refl. (* 100 seconds *)
Qed. (* 50 seconds *)

Theorem sqrt_484b : SearchSqrt 484 = 22.
  vm_compute. (* 30 seconds *)
  apply eq_refl.
Qed. (* 30 seconds *)

Theorem sqrt_484c (a : nat) : SearchSqrt 484 = 22.
  apply eq_refl. (* 100 seconds *)
Qed. (* 50 seconds *)

Theorem sqrt_484d (a : nat) : SearchSqrt 484 = 22.
  vm_compute. (* 60 seconds *)
  apply eq_refl.
Qed. (* 60 seconds *)

(*|
Now try the corresponding function in Python:

.. code-block:: python

    def SearchSqrt(n):
      for i in range(n, -1, -1):
        if i * i == n:
          return i
      return 0

or slightly more literally

.. code-block:: python

    def SearchSqrtLoop(i, n):
      if i * i == n:
        return i
      if i == 0:
        return 0
      return SearchSqrtLoop(i - 1, n)

    def SearchSqrt(n):
      return SearchSqrtLoop(n, n)

The function is nearly instant in Python, but takes minutes in Coq,
depending on exactly how you try to call it. Also curious is that
putting an extra variable in makes ``vm_compute`` take twice as long.

I understand that everything is done symbolically in Coq, and thus
slow, but it would be very useful if I could directly evaluate simple
functions. Is there a way to do it? Just using native integers instead
of linked lists would probably help a lot.
|*)

(*|
Answer (user1861759)
********************

You'll get a speedup if you use binary arithmetic instead of unary
arithmetic. Take a look at ``NArith`` and ``ZArith``.

http://coq.inria.fr/library/

You'll also get a speedup if you run your code on OCaml, Haskell, or
Scheme instead.

http://coq.inria.fr/refman/Reference-Manual025.html
|*)

(*|
Answer (Anton Trunov)
*********************

There is a much more efficient function for finding square roots in
the standard library (`sqrt
<https://coq.inria.fr/library/Coq.Init.Nat.html#sqrt>`__):

    The following square root function is linear (and tail-recursive).
    With Peano representation, we can't do better. For faster
    algorithm, see ``Psqrt``/``Zsqrt``/``Nsqrt``...

.. coq::
|*)

Require Import Coq.Init.Nat.

Theorem sqrt_484a_v2 : sqrt 484 = 22.
  Time apply eq_refl.
  Time Qed.

(*|
As ``Time`` tells us it works much faster (around 200 times faster
than ``sqrt_484a``).

The reason for this performance difference lies in the fact that
``SearchSqrt`` squares its first argument on each iteration, which is
an expensive operation.

``sqrt``'s implementation, on the other hand, is based on the `Odd
Number Theorem <http://mathworld.wolfram.com/OddNumberTheorem.html>`__
(``1 + 3 + 5 + ...`` is a square number). One just needs to count the
number of increasing intervals that can be fitted into the input
argument ``n`` and that would be the `integer square root
<https://en.wikipedia.org/wiki/Integer_square_root>`__ of ``n``. E.g.
``22 = (1 + 3 + 5 + 7) + 6``, which means there are 4 intervals (of
lengths ``1``, ``3``, ``5``, and ``7``) in 22, so ``sqrt 22 = 4`` (and
we are not interested in the residual value 6).
|*)


Require Import Nijn.Prelude.Checks.
Require Import Nijn.Prelude.Funext.
Require Import Bool.

(** * Decidable propositions *)

(** A proposition is called decidable if we can either find an element of it or if we can refute it. As such, decidable propositions are those for which the law of excluded middle holds. *)

(** Decidable propositions are those for which we can compute whether they hold or not. We also use this notion to define types with decidable equality, which are types for which we can determine whether two inhabitants are equal. *)
Inductive dec (A : Prop) : Type :=
| Yes : A -> dec A
| No : (A -> False) -> dec A.

Arguments Yes {_} _.
Arguments No {_} _.

(** * Examples of decidable propositions *)
Definition dec_True : dec True := Yes I.

Definition dec_False : dec False := No (fun z => z).

Definition dec_not {A : Prop} (x : dec A) : dec (~A)
  := match x with
     | Yes a => No (fun q => q a)
     | No a => Yes a
     end.

Definition dec_and {A B : Prop} (x : dec A) (y : dec B) : dec (A /\ B)
  := match x , y with
     | Yes p , Yes q => Yes (conj p q)
     | No p , _ => No (fun z => p (proj1 z))
     | _ , No q => No (fun z => q (proj2 z))
     end.

Definition dec_or {A B : Prop} (x : dec A) (y : dec B) : dec (A \/ B)
  := match x , y with
     | No p , No q =>
       No (fun z =>
           match z with
           | or_introl a => p a
           | or_intror b => q b
           end)
     | Yes p , _ => Yes (or_introl p)
     | _ , Yes q => Yes (or_intror q)
     end.

(** * Decidable equality *)

Class decEq (A : Type) :=
  {
    dec_eq : forall (a₁ a₂ : A), dec (a₁ = a₂)
  }.

(** A tactic for proving decidable equality on finite types *)
Ltac decEq_finite :=
  unshelve esplit ;
  (let x := fresh in intro x ; induction x) ;
  (let x := fresh in intro x ; induction x) ;
  try (apply Yes ; abstract (reflexivity)) ;
  try (apply No ; abstract (discriminate)).

Notation "! p" := (eq_sym p) (at level 80).

(** We use the so-called `transport` function at numerous occassions. Our usage is more technical though. *)
Definition transport
           {A : Type}
           (Y : A -> Type)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
  : Y a₁ -> Y a₂
  := match p with
     | eq_refl => fun z => z
     end.

Lemma transport_sym_p
      {A : Type}
      (B : A -> Type)
      {x y : A}
      (p : x = y)
      (b : B x)
  : transport B (eq_sym p) (transport B p b) = b.
Proof.
  subst.
  cbn.
  reflexivity.
Qed.

(** Equality in sigma types *)
Proposition path_in_sigma_fst
            {A : Type}
            {B : A -> Type}
            {x y : {x : A & B x}}
            (p : x = y)
  : projT1 x = projT1 y.
Proof.
  induction p.
  reflexivity.
Defined.

Proposition path_in_sigma_snd
            {A : Type}
            {B : A -> Type}
            {x y : {x : A & B x}}
            (p : x = y)
  : transport B (path_in_sigma_fst p) (projT2 x) = projT2 y.
Proof.
  subst.
  reflexivity.
Defined.

Proposition from_path_in_sigma
            {A : Type}
            (B : A -> Type)
            {a : A}
            {b1 b2 : B a}
            (p : existT _ a b1 = existT _ a b2)
  : b1 = b2.
Proof.
  pose (path_in_sigma_snd p) as q.
  rewrite (UIP (path_in_sigma_fst p) eq_refl) in q.
  exact q.
Defined.

(** * Examples of types with decidable equality *)

(** The unit type has decidable equality *)
Definition dec_eq_unit
           (x y : unit)
  : dec (x = y)
  := match x , y with
     | tt , tt => Yes eq_refl
     end.

Global Instance decEq_unit : decEq unit
  := {| dec_eq := dec_eq_unit |}.

(** The booleans have decidable equality *)
Definition dec_eq_bool
           (x y : bool)
  : dec (x = y)
  := match x , y with
     | true , true => Yes eq_refl
     | false , false => Yes eq_refl
     | true , false => No diff_true_false
     | false , true => No diff_false_true
     end.

Global Instance decEq_bool : decEq bool
  := {| dec_eq := dec_eq_bool |}.

(** The product of types with decidable equality has decidable equality *)
Section ProductDecEq.
  Context {A B : Type}
          `{decEq A}
          `{decEq B}.

  Definition path_pair
             {a₁ a₂ : A}
             {b₁ b₂ : B}
             (p : a₁ = a₂)
             (q : b₁ = b₂)
    : (a₁ , b₁) = (a₂ , b₂)
    := match p , q with
       | eq_refl , eq_refl => eq_refl
       end.

  Definition dec_eq_product
             (x y : A * B)
    : dec (x = y)
    := match x , y with
       | (x1 , x2) , (y1 , y2) =>
         match dec_eq x1 y1 with
         | Yes p =>
           match dec_eq x2 y2 with
           | Yes q => Yes (path_pair p q)
           | No q => No (fun (r : (x1 , x2) = (y1 , y2)) => q (f_equal snd r))
           end
         | No p => No (fun (r : (x1 , x2) = (y1 , y2)) => p (f_equal fst r))
         end
       end.

  Global Instance decEq_product : decEq (A * B)
    := {| dec_eq := dec_eq_product |}.
End ProductDecEq.

(** The sum of types with decidable equality has decidable equality *)
Section SumDecEq.
  Context {A B : Type}
          `{decEq A}
          `{decEq B}.

  Definition inl_inj
             {x y : A}
             (p : (inl x : A + B) = inl y)
    : x = y.
  Proof.
    inversion p.
    reflexivity.
  Qed.

  Definition inr_inj
             {x y : B}
             (p : (inr x : A + B) = inr y)
    : x = y.
  Proof.
    inversion p.
    reflexivity.
  Qed.

  Definition inl_not_inr
             {x : A}
             {y : B}
             (p : inl x = inr y)
    : False.
  Proof.
    discriminate.
  Qed.

  Definition inr_not_inl
             {x : B}
             {y : A}
             (p : inr x = inl y)
    : False.
  Proof.
    discriminate.
  Qed.

  Definition dec_eq_sum
             (x y : A + B)
    : dec (x = y)
    := match x , y with
       | inl x , inl y =>
         match dec_eq x y with
         | Yes p => Yes (f_equal inl p)
         | No p => No (fun q => p (inl_inj q))
         end
       | inl x , inr y => No (fun q => inl_not_inr q)
       | inr x , inl y => No (fun q => inr_not_inl q)
       | inr x , inr y =>
         match dec_eq x y with
         | Yes p => Yes (f_equal inr p)
         | No p => No (fun q => p (inr_inj q))
         end
       end.

  Global Instance decEq_sum : decEq (A + B)
    := {| dec_eq := dec_eq_sum |}.
End SumDecEq.

(** The natural numbers have decidable equality *)
Definition help_fam
           (n : nat)
  : Prop
  := match n with
     | 0 => True
     | S _ => False
     end.

Definition S_inj
           {n m : nat}
           (p : S n = S m)
  : n = m.
Proof.
  inversion p.
  reflexivity.
Qed.

Fixpoint dec_eq_nat
         (n : nat)
  : forall (m : nat), dec (n = m)
  := match n with
     | 0 =>
       fun m =>
         match m with
         | 0 => Yes eq_refl
         | S m => No (fun (q : 0 = S m) => transport help_fam q I)
         end
     | S n =>
       fun m =>
         match m with
         | 0 => No (fun (q : S n = 0) => transport help_fam (!q) I)
         | S m =>
           match dec_eq_nat n m with
           | Yes p => Yes (f_equal S p)
           | No p => No (fun q => p (S_inj q))
           end
         end
     end.

Global Instance decEq_nat : decEq nat
  := {| dec_eq := dec_eq_nat |}.


From mathcomp Require Import all_ssreflect all_algebra.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.
Open Scope ring_scope.

Section CPGE.
(**

*)
Section ex_6_12.
(** -------------------------------------------- *)
(** #
#

* Exercices de mathématiques oraux X-ens Algebre 1

* Exercise 6.12: Endomorphisms u such that Ker u = Im u.

Let E be a vector space (any dimension, but in Coq we reason in finite
dimension).

*)
Variables (F : fieldType) (n' : nat).
Let n := n'.+1.

Section Q1.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Question 1.

Let u be an endomorphism of E, such that Ker u = Im u and S be a
complement of Im u ("supplémentaire" in french), so that E is the
direct sum of S and Im u.

*)
Variable (u : 'M[F]_n) (S : 'M[F]_n).
Hypothesis eq_keru_imu : (kermx u :=: u)%MS.
Hypothesis S_u_direct : (S :&: u)%MS = 0.
Hypothesis S_u_eq1 : (S + u :=: 1)%MS.

Implicit Types (x y z : 'rV[F]_n).
(**

*** Question 1.a.

Show that for all x in E, there is a unique pair (y, z) in S² such
that x = y + u (z), and pose v and z so that y = v(x) and z = w(x).

Instead of defining y and z for each x, we now define explicitly the
matrix that computes y and z from x.

 - A direct consequence of this is that v and w will be morphisms by
  construction, you can thus skip the part of the paper proof that
  deals with this.

 - Every morphism induces an ismorphism between a complement of its
   kernel and its image.  The function #pinvmx# is the
   inverse of this isomporhism, but since the complement of the kernel
   that was used to produce #pinvmx# is arbitrary, we
   must project the result of #pinvmx# on S in order to
   get the specific inverse with image S.
*)
Definition w := locked (proj_mx S u).
Definition v := locked (proj_mx u S * pinvmx u * proj_mx S u).
(**

Note that we used locking in order to protect w and v from expanding
unexpectedly during proofs.

# *)
(** -------------------------------------------- *)
(** #
#

**** Question 1.a.i.

Prove the following lemmas.

*)
Lemma wS x : (x *m w <= S)%MS.
Proof.
unlock w.
(*D*)by rewrite proj_mx_sub.
(*A*)Qed.

Lemma vS x : (x *m v <= S)%MS.
Proof.
unlock v.
(*D*)by rewrite mulmxA proj_mx_sub.
(*A*)Qed.

Lemma w_id x : (x <= S)%MS -> x *m w = x.
Proof.
unlock w => xS.
(*D*)by rewrite proj_mx_id ?S_u_direct.
(*A*)Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

**** Question 1.a.ii.

Reuse and adapt and the proof in the course.

- (hint: use mulmxKpV)

*)
Lemma Su_rect x : x = x *m w + (x *m v) *m u.
Proof.
unlock v w.
(*
remember we had t, z' and z
y := x *m proj_mx S u
t := x *m proj_mx u S
z' := t *m pinvmx u
z := z' *m proj_mx S u.
and x = y + z *m u
    z' *m u = z *m u
    z' *m u = t
*)
(*D*)rewrite -{1}(@add_proj_mx _ _ _ S u x) ?S_u_direct ?S_u_eq1 ?submx1 //.
(*D*)congr (_ + _); apply/eqP.
(*D*)rewrite -[x *m proj_mx u S](@mulmxKpV _ _ _ _ _ u) ?proj_mx_sub //.
(*D*)rewrite 2![x *m _ in X in _ == X]mulmxA -subr_eq0 -mulmxBl.
(*D*)apply/eqP/sub_kermxP.
(*D*)by rewrite eq_keru_imu proj_mx_compl_sub ?S_u_eq1 ?submx1.
(*A*)Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

**** Question 1.a.iii.

From the proof

*)
Lemma Su_dec_eq0 y z : (y <= S)%MS -> (z <= S)%MS ->
  (y + z *m u == 0) = (y == 0) && (z == 0).
Proof.
move=> yS zS; apply/idP/idP; last first.
  by move=> /andP[/eqP -> /eqP ->]; rewrite add0r mul0mx.
rewrite addr_eq0 -mulNmx => /eqP eq_y_Nzu.
have : (y <= S :&: u)%MS by rewrite sub_capmx yS eq_y_Nzu submxMl.
rewrite S_u_direct // submx0 => /eqP y_eq0.
move/eqP: eq_y_Nzu; rewrite y_eq0 eq_sym mulNmx oppr_eq0 eqxx /= => /eqP.
move=> /sub_kermxP; rewrite eq_keru_imu => z_keru.
have : (z <= S :&: u)%MS by rewrite sub_capmx zS.
by rewrite S_u_direct // submx0.
Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

deduce

*)
Lemma Su_dec_uniq y y' z z' : (y <= S)%MS -> (z <= S)%MS ->
                              (y' <= S)%MS -> (z' <= S)%MS ->
  (y + z *m u == y' + z' *m u) = (y == y') && (z == z').
Proof.
(*D*)move=> yS zS y'S z'S; rewrite -subr_eq0 opprD addrACA -mulmxBl.
(*D*)by rewrite Su_dec_eq0 ?addmx_sub ?eqmx_opp // !subr_eq0.
(*A*)Qed.
(**
**** Question 1.a.iii.

Show some simplification lemmas
- the two first are direct
- the two last use Su_dec_uniq.

*)
Lemma u2_eq0 : u *m u = 0.
(*A*)Proof. by apply/sub_kermxP; rewrite eq_keru_imu. Qed.

Lemma u2K m (a : 'M_(m,n)) : a *m u *m u = 0.
(*D*)Proof. by rewrite -mulmxA u2_eq0 mulmx0. Qed.

Lemma v_id x : (x <= S)%MS -> (x *m u) *m v = x.
Proof.
(*D*)move=> xS; have /eqP := Su_rect (x *m u).
(*D*)rewrite -[X in X == _]add0r Su_dec_uniq ?sub0mx ?vS ?wS //.
(*D*)by move=> /andP [_ /eqP <-].
(*A*)Qed.

Lemma w0 x : (x <= S)%MS -> (x *m u) *m w = 0.
Proof.
(*D*)move=> xS; have /eqP := Su_rect (x *m u).
(*D*)rewrite -[X in X == _]add0r Su_dec_uniq ?sub0mx ?vS ?wS //.
(*D*)by move=> /andP [/eqP <-].
(*A*)Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

*** Question 1.b.

- Show that v is linear.
- Show that u o v + v o u = 1.

*)
Lemma add_uv_vu : v *m u + u *m v = 1.
Proof.
(*D*)apply/row_matrixP => i; rewrite !rowE; move: (delta_mx _ _) => x.
(*D*)rewrite mulmx1 mulmxDr !mulmxA {2}[x]Su_rect mulmxDl u2K addr0.
(*D*)by rewrite v_id ?wS // addrC -Su_rect.
(*A*)Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

*** Question 1.c.

- Show that w is linear.
- Show that u o w + w o u = u.

*)
Lemma add_wu_uw : w *m u + u *m w = u.
Proof.
(*D*)apply/row_matrixP => i; rewrite !rowE; move: (delta_mx _ _) => x.
(*D*)rewrite mulmxDr !mulmxA {2}[x]Su_rect mulmxDl u2K addr0 w0 ?wS // addr0.
(*D*)by have /(canLR (addrK _)) <- := Su_rect x; rewrite mulmxBl u2K subr0.
(*A*)Qed.

End Q1.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** State and prove question 2, and then 3...

*)

End ex_6_12.
End CPGE.


Require Import ZArith.
Require Import Omega.

Lemma hoge : forall z : Z, (z ^ 4 - 4 * z ^ 2 + 4 > 0)%Z.
Proof.
  intro.
  replace (z^4-4*z^2+4)%Z with ((z*z-2)*(z*z-2))%Z by ring.
  rewrite <- Z.square_spec.
  assert (forall p, (Z.pos p * Z.pos p - 2)%Z <> 0%Z).
  intros.
  destruct p.
  remember (Z.pos p~1) as m3.
  assert (m3 >= 3)%Z.
  rewrite Heqm3.
  unfold Z.ge.
  simpl.
  unfold Pos.compare, Pos.compare_cont.
  destruct p.
  congruence.
  congruence.
  congruence.
  assert (m3*m3 >= 3*m3)%Z.
  apply Zmult_ge_compat_r.
  assumption.
  omega.
  omega.
  remember (Z.pos p~0) as m2.
  assert (m2 >= 2)%Z.
  rewrite Heqm2.
  unfold Z.ge.
  simpl.
  unfold Pos.compare, Pos.compare_cont.
  destruct p.
  congruence.
  congruence.
  congruence.
  assert (m2*m2 >= 2*m2)%Z.
  apply Zmult_ge_compat_r.
  assumption.
  omega.
  omega.
  omega.
  assert (z*z-2 <> 0)%Z.
  destruct z.
  omega.
  apply H.
  replace (Z.neg p * Z.neg p)%Z with (Z.pos p * Z.pos p)%Z.
  apply H.
  simpl.
  reflexivity.
  remember (z*z-2)%Z as y.
  destruct y.
  congruence.
  simpl.
  unfold Z.gt.
  reflexivity.
  simpl.
  unfold Z.gt.
  reflexivity.
Qed.


Require Import Coq.Arith.PeanoNat.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeMath.
Require Import DschingisKhan.Prelude.PreludeUtil.

Module BasicPosetTheory.

  Import ListNotations MathProps MathNotations MathClasses.

  Lemma leProp_unfold {D : Type} {requiresPoset : isPoset D}
    : forall x : D, forall y : D, x =< y <-> (forall z : D, z =< x -> z =< y).
  Proof. exact (proj1 (PreOrder_iff leProp) (@leProp_PreOrder D requiresPoset)). Qed.

  Definition isMonotonicMap {dom : Type} {cod : Type} {dom_isPoset : isPoset dom} {cod_isPoset : isPoset cod} (f : dom -> cod) : Prop :=
    forall x : dom, forall x' : dom, forall x_le_x' : x =< x', f x =< f x'
  .

  Lemma isMonotonicMap_iff_preserves_leProp1 {dom : Type} {cod : Type} {dom_isPoset : isPoset dom} {cod_isPoset : isPoset cod} (f : dom -> cod)
    : isMonotonicMap f <-> preserves_leProp1 f.
  Proof. reflexivity. Qed.

  Global Notation " f '\monotonic' " := (preserves_leProp1 f)
    (in custom math_form_scope at level 6, f custom math_term_scope at level 1, no associativity).
  Global Notation " '('  X  ')↑' " := (UpperBoundsOf X)
    (in custom math_form_scope at level 0, X custom math_term_scope at level 5).
  Global Notation " sup_X '=' '\sup' X " := (isSupremumOf sup_X X)
    (in custom math_form_scope at level 6, sup_X custom math_term_scope at level 1, X custom math_term_scope at level 5).
  Global Notation " '('  X  ')↓' " := (LowerBoundsOf X)
    (in custom math_form_scope at level 0, X custom math_term_scope at level 5).
  Global Notation " inf_X '=' '\inf' X " := (isInfimumOf inf_X X)
    (in custom math_form_scope at level 6, inf_X custom math_term_scope at level 1, X custom math_term_scope at level 5).
  Global Notation " '\{' '\sup' Y ':' X '∈' Xs '\}' " := (ensemble_bind Xs (fun X => fun sup => isSupremumOf sup Y))
    (in custom math_term_scope at level 0, Xs custom math_term_scope at level 5, X pattern, Y custom math_term_scope at level 1, no associativity).
  Global Notation " '\{' '\inf' Y ':' X '∈' Xs '\}' " := (ensemble_bind Xs (fun X => fun inf => isInfimumOf inf Y))
    (in custom math_term_scope at level 0, Xs custom math_term_scope at level 5, X pattern, Y custom math_term_scope at level 1, no associativity).

  Create HintDb poset_hints.
  Global Hint Unfold REFERENCE_HOLDER member UpperBoundsOf LowerBoundsOf isSupremumOf isInfimumOf isMonotonicMap : poset_hints.
  Global Hint Resolve member_eq_leProp_with_impl member_eq_eqProp_with_iff leProp_lifted1 leProp_unfold : poset_hints.

  Global Add Parametric Morphism {D : Type} (requiresPoset : isPoset D) :
    (UpperBoundsOf (requiresPoset := requiresPoset)) with signature (eqProp ==> eqProp)
    as UpperBoundsOf_compatWith_eqProp_wrtEnsembles.
  Proof with eauto with *.
    intros X Y X_eq_Y z. split; intros H_upper_bound.
    - intros y y_in_Y. eapply H_upper_bound. unnw. rewrite -> X_eq_Y...
    - intros x x_in_X. eapply H_upper_bound. unnw. rewrite <- X_eq_Y...
  Qed.

  Global Add Parametric Morphism {D : Type} (requiresPoset : isPoset D) :
    (LowerBoundsOf (requiresPoset := requiresPoset)) with signature (eqProp ==> eqProp)
    as LowerBoundsOf_compatWith_eqProp_wrtEnsembles.
  Proof with eauto with *.
    intros X Y X_eq_Y z. split; intros H_lower_bound.
    - intros y y_in_Y. eapply H_lower_bound. unnw. rewrite -> X_eq_Y...
    - intros x x_in_X. eapply H_lower_bound. unnw. rewrite <- X_eq_Y...
  Qed.

  Global Hint Resolve UpperBoundsOf_compatWith_eqProp_wrtEnsembles LowerBoundsOf_compatWith_eqProp_wrtEnsembles monotonic_guarantees_leProp_lifted1 monotonic_guarantees_leProp_lifted2 monotonic_guarantees_eqProp_lifted1 monotonic_guarantees_eqProp_lifted2 : poset_hints.

  Section BASIC_FACTS_ON_SUPREMUM.

  Context {D : Type} {requiresPoset : isPoset D}.

  Lemma Supremum_isInfimumOf_itsUpperBounds (X : ensemble D) (q : D)
    (q_isSupremumOf_X : isSupremumOf q X)
    : isInfimumOf q (fun x : D => q =< x).
  Proof with eauto with *.
    intros d. unnw. split.
    - intros d_le_q x q_le_x. rewrite d_le_q...
    - intros d_in. eapply d_in, q_isSupremumOf_X.
      ii; desnw. eapply q_isSupremumOf_X...
  Qed.

  Lemma Supremum_monotonic_wrtEnsembles (X1 : ensemble D) (X2 : ensemble D) (sup_X1 : D) (sup_X2 : D)
    (sup_X1_isSupremumOf_X1 : isSupremumOf sup_X1 X1)
    (sup_X2_isSupremumOf_X2 : isSupremumOf sup_X2 X2)
    (X1_isSubsetOf_X2 : isSubsetOf X1 X2)
    : sup_X1 =< sup_X2.
  Proof.
    eapply sup_X1_isSupremumOf_X1; ii.
    eapply sup_X2_isSupremumOf_X2; eauto with *.
  Qed.

  Local Hint Resolve Supremum_monotonic_wrtEnsembles : poset_hints.

  Lemma Supremum_unique (X1 : ensemble D) (X2 : ensemble D) (sup_X1 : D) (sup_X2 : D)
    (sup_X1_isSupremumOf_X1 : isSupremumOf sup_X1 X1)
    (sup_X2_isSupremumOf_X2 : isSupremumOf sup_X2 X2)
    (X1_eq_X2 : X1 == X2)
    : sup_X1 == sup_X2.
  Proof.
    pose proof (eqProp_implies_leProp X1 X2 X1_eq_X2) as claim1. symmetry in X1_eq_X2.
    pose proof (eqProp_implies_leProp X2 X1 X1_eq_X2) as claim2. eapply leProp_Antisymmetric; eauto with *.
  Qed.

  Local Hint Resolve Supremum_unique : poset_hints.

  Lemma Supremum_congruence (sup_X : D) (sup_Y : D) (X : ensemble D) (Y : ensemble D)
    (sup_X_eq_sup_Y : sup_X == sup_Y)
    (X_eq_Y : X == Y)
    (sup_X_isSupremumOf_X : isSupremumOf sup_X X)
    : isSupremumOf sup_Y Y.
  Proof with eauto with *.
    intros z. unnw. rewrite <- sup_X_eq_sup_Y. split.
    - intros sup_X_le_z. rewrite <- X_eq_Y. eapply sup_X_isSupremumOf_X...
    - intros z_isUpperBoundOf_Y. eapply sup_X_isSupremumOf_X. unnw. rewrite -> X_eq_Y...
  Qed.

  Local Hint Resolve Supremum_congruence : poset_hints.

  Global Add Parametric Morphism :
    (@isSupremumOf D requiresPoset) with signature (eqProp ==> eqProp ==> iff)
    as Supremum_compatWith_eqProp_wrtEnsembles.
  Proof. iis; eauto with *. Qed.

  Definition MapSuprema (Xs : ensemble (ensemble D)) : ensemble D :=
    bind Xs (fun X_i : ensemble D => fun sup_X_i : D => isSupremumOf sup_X_i X_i)
  .

  Lemma in_MapSuprema_iff (Xs : ensemble (ensemble D)) (sup : D)
    : member sup (MapSuprema Xs) <-> (exists X_i : ensemble D, member X_i Xs /\ isSupremumOf sup X_i).
  Proof. reflexivity. Qed.

  Lemma SupremumOfMapSuprema_ge_Suprema (sup : D) (Xs : ensemble (ensemble D)) (sup_X : D) (X : ensemble D)
    (sup_isSupremumOf : isSupremumOf sup (MapSuprema Xs))
    (X_in_Xs : member X Xs)
    (sup_X_isSupremumOf_X : isSupremumOf sup_X X)
    : sup_X =< sup.
  Proof with eauto with *. eapply sup_isSupremumOf... eapply in_MapSuprema_iff... Qed.

  Local Hint Resolve SupremumOfMapSuprema_ge_Suprema : poset_hints.

  Theorem SupremumOfMapSuprema_isSupremumOf_unions (Xs : ensemble (ensemble D)) (sup : D)
    (SUPS_EXIST : forall X : ensemble D, << H_IN : member X Xs >> -> exists sup_X : D, isSupremumOf sup_X X)
    : isSupremumOf sup (MapSuprema Xs) <-> isSupremumOf sup (unions Xs).
  Proof with eauto with *.
    split; intros H_supremum z; split; ii; desnw.
    - apply in_unions_iff in H_IN. destruct H_IN as [X_i [x_in_X_i X_i_in_Xs]].
      pose proof (SUPS_EXIST X_i X_i_in_Xs) as [sup_X_i sup_X_i_isSupremumOf_X_i].
      transitivity (sup_X_i).
      + eapply sup_X_i_isSupremumOf_X_i...
      + transitivity (sup)...
    - eapply H_supremum. intros sup_X_i sup_X_i_in_MapSuprema.
      apply in_MapSuprema_iff in sup_X_i_in_MapSuprema.
      destruct sup_X_i_in_MapSuprema as [X_i [X_i_in_Xs sup_X_i_isSupremumOf_X_i]].
      eapply sup_X_i_isSupremumOf_X_i. ii. desnw. eapply UPPER_BOUND. eapply in_unions_iff...
    - apply in_MapSuprema_iff in H_IN. destruct H_IN as [X [X_in_Xs sup_X_isSupremumOf_X]].
      rename x into sup_X. enough (to_show : sup_X =< sup) by now transitivity (sup).
      eapply sup_X_isSupremumOf_X. ii; desnw. eapply H_supremum... eapply in_unions_iff...
    - eapply H_supremum. ii; desnw. apply in_unions_iff in H_IN.
      destruct H_IN as [X [x_in_X X_in_Xs]]. pose proof (SUPS_EXIST X X_in_Xs) as [sup_X sup_X_isSupremumOf_X].
      transitivity (sup_X).
      + eapply sup_X_isSupremumOf_X...
      + eapply UPPER_BOUND, in_MapSuprema_iff...
  Qed.

  Theorem InfimumOfUpperBounds_isSupremum (sup_X : D) (X : ensemble D)
    : isSupremumOf sup_X X <-> << sup_X_isInfimumOfUpperBounds : isInfimumOf sup_X (UpperBoundsOf X) >>.
  Proof with eauto with *.
    split.
    - intros sup_X_isSupremumOf_X z. split; ii; desnw.
      + rewrite LOWER_BOUND_LE_INFIMUM.
        eapply sup_X_isSupremumOf_X...
      + eapply LOWER_BOUND, sup_X_isSupremumOf_X...
    - intros H_supremum z. split; ii; desnw.
      + rewrite <- SUPREMUM_LE_UPPER_BOUND.
        eapply sup_X_isInfimumOfUpperBounds. unnw.
        intros upper_bound upper_bound_in. unnw.
        exact (upper_bound_in x H_IN).
      + unnw. eapply sup_X_isInfimumOfUpperBounds...
  Qed.

  Theorem SupremumOfLowerBounds_isInfimum (inf_X : D) (X : ensemble D)
    : isInfimumOf inf_X X <-> << inf_X_isSupremumOfLowerBounds : isSupremumOf inf_X (LowerBoundsOf X) >>.
  Proof with eauto with *.
    split.
    - intros inf_X_isInfimumOf_X z. split; ii; desnw.
      + rewrite <- SUPREMUM_LE_UPPER_BOUND.
        eapply inf_X_isInfimumOf_X...
      + eapply UPPER_BOUND, inf_X_isInfimumOf_X...
    - intros H_infimum z. split; ii; desnw.
      + rewrite LOWER_BOUND_LE_INFIMUM.
        eapply inf_X_isSupremumOfLowerBounds. unnw.
        intros lower_bound lower_bound_in. unnw.
        exact (lower_bound_in x H_IN).
      + unnw. eapply inf_X_isSupremumOfLowerBounds...
  Qed.

  Lemma Infimum_monotonic_wrtEnsembles (X1 : ensemble D) (X2 : ensemble D) (inf_X1 : D) (inf_X2 : D)
    (inf_X1_isInfimumOf_X1 : isInfimumOf inf_X1 X1)
    (inf_X2_isInfimumOf_X2 : isInfimumOf inf_X2 X2)
    (X1_isSubsetOf_X2 : isSubsetOf X1 X2)
    : inf_X2 =< inf_X1.
  Proof.
    eapply inf_X1_isInfimumOf_X1; ii.
    eapply inf_X2_isInfimumOf_X2; eauto with *.
  Qed.

  Local Hint Resolve Infimum_monotonic_wrtEnsembles : poset_hints.

  Lemma Infimum_unique (X1 : ensemble D) (X2 : ensemble D) (inf_X1 : D) (inf_X2 : D)
    (inf_X1_isInfimumOf_X1 : isInfimumOf inf_X1 X1)
    (inf_X2_isInfimumOf_X2 : isInfimumOf inf_X2 X2)
    (X1_eq_X2 : X1 == X2)
    : inf_X1 == inf_X2.
  Proof.
    pose proof (eqProp_implies_leProp X1 X2 X1_eq_X2) as claim1. symmetry in X1_eq_X2.
    pose proof (eqProp_implies_leProp X2 X1 X1_eq_X2) as claim2. eapply leProp_Antisymmetric; eauto with *.
  Qed.

  Lemma Infimum_congruence (inf_X : D) (inf_Y : D) (X : ensemble D) (Y : ensemble D)
    (inf_X_eq_inf_Y : inf_X == inf_Y)
    (X_eq_Y : X == Y)
    (inf_X_isInfimumOf_X : isInfimumOf inf_X X)
    : isInfimumOf inf_Y Y.
  Proof with eauto with *.
    intros z. unnw. rewrite <- inf_X_eq_inf_Y. split.
    - intros z_le_inf_X. rewrite <- X_eq_Y. eapply inf_X_isInfimumOf_X...
    - intros z_isLowerBoundOf_Y. eapply inf_X_isInfimumOf_X. unnw. rewrite -> X_eq_Y...
  Qed.

  Local Hint Resolve Infimum_unique Infimum_congruence : core.

  Global Add Parametric Morphism :
    (@isInfimumOf D requiresPoset) with signature (eqProp ==> eqProp ==> iff)
    as Infimum_compatWith_eqProp_wrtEnsembles.
  Proof. iis; eauto with *. Qed.

  Definition isLeastFixedPointOf (lfp : D) (f : D -> D) : Prop :=
    << IS_FIXED_POINT : member lfp (FixedPoints f) >> /\ << LOWER_BOUND_OF_FIXED_POINTS : member lfp (LowerBoundsOf (FixedPoints f)) >>
  .

  Definition isGreatestFixedPointOf (gfp : D) (f : D -> D) : Prop :=
    << IS_FIXED_POINT : member gfp (FixedPoints f) >> /\ << UPPER_BOUND_OF_FIXED_POINTS : member gfp (UpperBoundsOf (FixedPoints f)) >>
  .

  Local Hint Unfold isLeastFixedPointOf isGreatestFixedPointOf : poset_hints.

  Theorem theLeastFixedPointOfMonotonicMap (f : D -> D) (lfp : D)
    (f_isMonotonicMap : isMonotonicMap f)
    (lfp_isInfimumOfPrefixedPoints : isInfimumOf lfp (PrefixedPoints f))
    : isLeastFixedPointOf lfp f.
  Proof with eauto with *.
    assert (claim1 : forall x : D, member x (FixedPoints f) -> lfp =< x).
    { intros x H_IN. transitivity (f x).
      - eapply lfp_isInfimumOfPrefixedPoints... eapply f_isMonotonicMap...
      - eapply eqProp_implies_leProp...
    }
    assert (claim2 : f lfp =< lfp).
    { eapply lfp_isInfimumOfPrefixedPoints. ii; desnw. transitivity (f x); trivial.
      eapply f_isMonotonicMap, lfp_isInfimumOfPrefixedPoints...
    }
    assert (claim3 : lfp =< f lfp).
    { eapply lfp_isInfimumOfPrefixedPoints... eapply f_isMonotonicMap... }
    split... eapply leProp_Antisymmetric...
  Qed.

  Lemma theGreatestFixedPointOfMonotonicMap (f : D -> D) (gfp : D)
    (f_isMonotonicMap : isMonotonicMap f)
    (gfp_isSupremumOfPostfixedPoints : isSupremumOf gfp (PostfixedPoints f))
    : isGreatestFixedPointOf gfp f.
  Proof with eauto with *.
    assert (claim1 : gfp =< f gfp).
    { eapply gfp_isSupremumOfPostfixedPoints... ii; desnw. transitivity (f x); trivial.
      eapply f_isMonotonicMap, gfp_isSupremumOfPostfixedPoints...
    }
    assert (claim2 : f gfp =< gfp).
    { eapply gfp_isSupremumOfPostfixedPoints... eapply f_isMonotonicMap... }
    split.
    - eapply leProp_Antisymmetric...
    - intros fix_f H_in. desnw.
      eapply gfp_isSupremumOfPostfixedPoints...
      eapply eqProp_implies_leProp...
  Qed.

  Definition isSupremumIn (sup : D) (X : ensemble D) (phi : D -> Prop) : Prop :=
    ⟪ IN_SUBSET : phi sup ⟫ /\ ⟪ SUPREMUM_OF_SUBSET : forall upper_bound : @sig D phi, << SUPREMUM_LE_UPPER_BOUND : sup =< (proj1_sig upper_bound) >> <-> << UPPER_BOUND : member (proj1_sig upper_bound) (UpperBoundsOf X) >> ⟫
  .

  Theorem isSupremumIn_iff (phi : D -> Prop) (sup_X : @sig D phi) (X : ensemble (@sig D phi))
    : isSupremumIn (proj1_sig sup_X) (image (@proj1_sig D phi) X) phi <-> isSupremumOf sup_X X.
  Proof with eauto with *.
    split.
    { intros [? ?] z; desnw; split.
      - ii; desnw. eapply SUPREMUM_OF_SUBSET... eapply in_image_iff...
      - ii; desnw. eapply SUPREMUM_OF_SUBSET.
        intros x H_in_image. unnw. eapply in_image_iff in H_in_image.
        destruct H_in_image as [[x' phi_x] [x_eq x_in]]. simpl in x_eq; subst x'.
        change (@exist D phi x phi_x =< z)...
    }
    { intros sup_X_isSupremumOf_X. split.
      - exact (proj2_sig sup_X).
      - split; ii; desnw.
        + eapply in_image_iff in H_IN. destruct H_IN as [[x' phi_x] [x_eq x_in]].
          simpl in x_eq; subst x'. rewrite <- SUPREMUM_LE_UPPER_BOUND.
          change (@exist D phi x phi_x =< sup_X). eapply sup_X_isSupremumOf_X...
        + change (sup_X =< upper_bound). eapply sup_X_isSupremumOf_X.
          intros x x_in. change (proj1_sig x =< proj1_sig upper_bound).
          eapply UPPER_BOUND, in_image_iff...
    }
  Qed.

  End BASIC_FACTS_ON_SUPREMUM.

  Global Hint Resolve Supremum_monotonic_wrtEnsembles Supremum_unique Supremum_congruence Supremum_compatWith_eqProp_wrtEnsembles : poset_hints.

  Class isDecidableTotalOrder (A : Type) {requiresPoset : isPoset A} : Type :=
    { compare (lhs : A) (rhs : A) : comparison
    ; compare_LT_implies (lhs : A) (rhs : A) (H_lt : compare lhs rhs = Lt) : lhs =< rhs /\ ~ lhs == rhs
    ; compare_EQ_implies (lhs : A) (rhs : A) (H_eq : compare lhs rhs = Eq) : lhs == rhs
    ; compare_GT_implies (lhs : A) (rhs : A) (H_gt : compare lhs rhs = Gt) : rhs =< lhs /\ ~ lhs == rhs
    }
  .

  Local Hint Resolve compare_LT_implies compare_EQ_implies compare_GT_implies : poset_hints.

  Section LEXICOGRAPHICAL_ORDER.

  Context {A : Type} {requiresPoset : isPoset A} {requiresDecidableTotalOrder : isDecidableTotalOrder A (requiresPoset := requiresPoset)}.

  Fixpoint lex_compare (xs : list A) (ys : list A) {struct xs} : comparison :=
    match xs, ys with
    | [], [] => Eq
    | [], y :: ys => Lt
    | x :: xs, [] => Gt
    | x :: xs, y :: ys =>
      match compare x y with
      | Lt => Lt
      | Eq => lex_compare xs ys
      | Gt => Gt
      end
    end
  .

  Definition lex_eq (lhs : list A) (rhs : list A) : Prop := lex_compare lhs rhs = Eq.

  Definition lex_le (lhs : list A) (rhs : list A) : Prop := lex_compare lhs rhs = Lt \/ lex_compare lhs rhs = Eq.

  Lemma compare_spec (lhs : A) (rhs : A) :
    match compare lhs rhs with
    | Lt => lhs =< rhs /\ ~ lhs == rhs
    | Eq => lhs == rhs
    | Gt => rhs =< lhs /\ ~ lhs == rhs
    end.
  Proof. destruct (compare lhs rhs) eqn: H_compare_result; eauto with *. Qed.

  Local Instance lex_eq_Equivalence
    : Equivalence lex_eq.
  Proof with discriminate || eauto with *.
    unfold lex_eq. split.
    - intros xs1; induction xs1 as [ | x1 xs1 IH]; simpl...
      pose proof (claim1 := compare_spec x1 x1).
      destruct (compare x1 x1) eqn: H_compare_result1...
      all: contradiction (proj2 claim1)...
    - intros xs1 xs2; revert xs1 xs2; induction xs1 as [ | x1 xs1 IH]; destruct xs2 as [ | x2 xs2]; simpl...
      pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x1).
      destruct (compare x1 x2) eqn: H_compare_result1; destruct (compare x2 x1) eqn: H_compare_result2...
      all: contradiction (proj2 claim2)...
    - intros xs1 xs2 xs3; revert xs1 xs3; induction xs2 as [ | x2 xs2 IH]; destruct xs1 as [ | x1 xs1]; destruct xs3 as [ | x3 xs3]; simpl...
      pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x3); pose proof (claim3 := compare_spec x1 x3).
      destruct (compare x1 x2) eqn: H_compare_result1; destruct (compare x2 x3) eqn: H_compare_result2; destruct (compare x1 x3) eqn: H_compare_result3...
      all: contradiction (proj2 claim3)...
  Qed.

  Local Instance listPointwiseEquivalence : isSetoid (list A) :=
    { eqProp := lex_eq
    ; eqProp_Equivalence := lex_eq_Equivalence
    }
  .

  Local Instance lex_le_PreOrder
    : PreOrder lex_le.
  Proof with discriminate || eauto with *.
    assert (lemma1 : forall x1 : A, forall x2 : A, x1 =< x2 -> x2 =< x1 -> x1 == x2). { ii... }
    assert (lemma2 : forall x1 : A, forall x2 : A, x1 == x2 -> x1 =< x2). { ii... }
    assert (lemma3 : forall x1 : A, forall x2 : A, x1 == x2 -> x2 =< x1). { ii... }
    unfold lex_le. split.
    - intros xs1; right. eapply lex_eq_Equivalence.
    - intros xs1 xs2 xs3; revert xs1 xs3; induction xs2 as [ | x2 xs2 IH]; destruct xs1 as [ | x1 xs1]; destruct xs3 as [ | x3 xs3]; simpl...
      intros [H_false | H_false]...
      pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x3); pose proof (claim3 := compare_spec x1 x3); pose proof (claim4 := IH xs1 xs3).
      destruct (compare x1 x2) eqn: H_compare_result1; destruct (compare x2 x3) eqn: H_compare_result2; destruct (compare x1 x3) eqn: H_compare_result3...
      + contradiction (proj2 claim3)...
      + contradiction (proj2 claim2)...
      + contradiction (proj2 claim3); eapply lemma1; [transitivity x2 | exact (proj1 claim3)]. eapply lemma2... exact (proj1 claim2).
      + contradiction (proj2 claim2)...
      + contradiction (proj2 claim1)...
      + contradiction (proj2 claim3); eapply lemma1; [transitivity x2 | exact (proj1 claim3)]. exact (proj1 claim1). eapply lemma2...
      + contradiction (proj2 claim1); eapply lemma1; [exact (proj1 claim1) | transitivity x3]. exact (proj1 claim2). eapply lemma2...
      + contradiction (proj2 claim1); eapply lemma1; [exact (proj1 claim1) | transitivity x3]. exact (proj1 claim2). exact (proj1 claim3).
      + intros ? [? | ?]...
      + intros [? | ?]...
      + intros [? | ?]...
      + intros [? | ?]...
  Qed.

  Lemma lex_le_flip_spec (lhs : list A) (rhs : list A) :
    match lex_compare lhs rhs with
    | Lt => lex_compare rhs lhs = Gt
    | Eq => lex_compare rhs lhs = Eq
    | Gt => lex_compare rhs lhs = Lt
    end.
  Proof with discriminate || eauto with *.
    revert lhs rhs.
    assert (lemma1 : forall x1 : A, forall x2 : A, x1 =< x2 -> x2 =< x1 -> x1 == x2). { ii... }
    assert (lemma2 : forall x1 : A, forall x2 : A, x1 == x2 -> x1 =< x2). { ii... }
    assert (lemma3 : forall x1 : A, forall x2 : A, x1 == x2 -> x2 =< x1). { ii... }
    assert (lemma4 : forall xs1 : list A, forall xs2 : list A, lex_compare xs1 xs2 = Lt <-> lex_compare xs2 xs1 = Gt).
    { induction xs1 as [ | x1 xs1 IH]; destruct xs2 as [ | x2 xs2]; simpl... split...
      pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x1); pose proof (claim3 := IH xs2).
      destruct (compare x1 x2) eqn: H_compare_result1; destruct (compare x2 x1) eqn: H_compare_result2...
      - contradiction (proj2 claim2)...
      - contradiction (proj2 claim2)...
      - contradiction (proj2 claim1)...
      - contradiction (proj2 claim1). eapply lemma1; [exact (proj1 claim1) | exact (proj1 claim2)].
      - contradiction (proj2 claim1)...
      - contradiction (proj2 claim1). eapply lemma1; [exact (proj1 claim2) | exact (proj1 claim1)].
    }
    assert (lemma5 : forall xs1 : list A, forall xs2 : list A, lex_compare xs1 xs2 = Eq <-> lex_compare xs2 xs1 = Eq).
    { induction xs1 as [ | x1 xs1 IH]; destruct xs2 as [ | x2 xs2]; simpl... split... split...
      pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x1); pose proof (claim3 := IH xs2).
      destruct (compare x1 x2) eqn: H_compare_result1; destruct (compare x2 x1) eqn: H_compare_result2...
      - contradiction (proj2 claim2)...
      - contradiction (proj2 claim2)...
      - contradiction (proj2 claim1)...
      - split...
      - contradiction (proj2 claim1)...
      - split...
    }
    assert (lemma6 : forall xs1 : list A, forall xs2 : list A, lex_compare xs1 xs2 = Gt <-> lex_compare xs2 xs1 = Lt) by firstorder.
    intros lhs rhs; destruct (lex_compare lhs rhs) eqn: H_compare_result; now firstorder.
  Qed.

  Corollary lex_le_flip_iff (lhs : list A) (rhs : list A) (compare_result : comparison) :
    lex_compare lhs rhs = compare_result <->
    match compare_result with
    | Lt => lex_compare rhs lhs = Gt
    | Eq => lex_compare rhs lhs = Eq
    | Gt => lex_compare rhs lhs = Lt
    end.
  Proof.
    split.
    - ii; subst compare_result. exact (lex_le_flip_spec lhs rhs).
    - pose proof (lex_le_flip_spec rhs lhs) as claim1. intros H_eq.
      destruct compare_result eqn: H_compare_result; now rewrite H_eq in claim1.
  Qed.

  Local Instance lex_le_PartialOrder
    : PartialOrder lex_eq lex_le.
  Proof with discriminate || eauto with *.
    intros xs1 xs2; cbn. unfold flip, lex_eq, lex_le.
    pose proof (claim1 := lex_le_flip_spec xs1 xs2).
    destruct (lex_compare xs1 xs2) eqn: H_compare_result.
    - split...
    - split... intros [? [H_false | H_false]].
      all: rewrite H_false in claim1...
    - split... intros [[? | ?] ?]...
  Qed.

  Local Instance listLexicographicalOrder : isPoset (list A) :=
    { leProp := lex_le
    ; Poset_requiresSetoid := listPointwiseEquivalence
    ; leProp_PreOrder := lex_le_PreOrder
    ; leProp_PartialOrder := lex_le_PartialOrder
    }
  .

  Local Obligation Tactic := cbn; unfold lex_le, lex_eq; ii.
  Global Program Instance listLexicographicalOrder_liftsDecidableTotalOrder : isDecidableTotalOrder (list A) := { compare := lex_compare }.
  Next Obligation. rewrite H_lt. split; [now left | congruence]. Qed.
  Next Obligation. exact (H_eq). Qed.
  Next Obligation. exploit (lex_le_flip_spec lhs rhs). rewrite H_gt. intros H_lt. rewrite H_lt. split; [now left | congruence]. Qed.

  End LEXICOGRAPHICAL_ORDER.

  Section NAT_TOSET.

  Local Instance nat_isPoset : isPoset nat :=
    { leProp := le
    ; Poset_requiresSetoid := theFinestSetoidOf nat
    ; leProp_PreOrder := Nat.le_preorder
    ; leProp_PartialOrder := Nat.le_partialorder
    }
  .

  Fixpoint nat_compare (x : nat) (y : nat) {struct x} : comparison :=
    match x, y with
    | O, O => Eq
    | O, S y' => Lt
    | S x', O => Gt
    | S x', S y' => nat_compare x' y'
    end
  .

  Lemma nat_compare_lt (x : nat) (y : nat)
    (hyp_lt : nat_compare x y = Lt)
    : x <= y /\ x <> y.
  Proof with eauto with *.
    revert x y hyp_lt. induction x as [ | x IH], y as [ | y]; simpl; ii.
    - inversion hyp_lt.
    - split.
      { eapply le_intro_0_le_n. }
      { ii; eapply not_S_n_eq_0... }
    - inversion hyp_lt.
    - pose proof (IH y hyp_lt) as [x_le_y x_ne_y]. split.
      { eapply le_intro_S_n_le_S_m... }
      { ii. eapply x_ne_y, suc_n_eq_suc_m_elim... }
  Qed.

  Lemma nat_compare_eq (x : nat) (y : nat)
    (hyp_lt : nat_compare x y = Eq)
    : x = y.
  Proof with eauto with *.
    revert x y hyp_lt. induction x as [ | x IH], y as [ | y]; simpl; ii.
    - reflexivity.
    - inversion hyp_lt.
    - inversion hyp_lt.
    - pose proof (IH y hyp_lt) as x_eq_y.
      exact (eq_congruence suc x y x_eq_y).
  Qed.

  Lemma nat_compare_gt (x : nat) (y : nat)
    (hyp_lt : nat_compare x y = Gt)
    : y <= x /\ x <> y.
  Proof with eauto with *.
    cbn. revert x y hyp_lt. induction x as [ | x IH], y as [ | y]; simpl; ii.
    - inversion hyp_lt.
    - inversion hyp_lt.
    - split.
      { eapply le_intro_0_le_n. }
      { ii; eapply not_S_n_eq_0... }
    - pose proof (IH y hyp_lt) as [y_le_x x_ne_y]. split.
      { eapply le_intro_S_n_le_S_m... }
      { ii. eapply x_ne_y, suc_n_eq_suc_m_elim... }
  Qed.

  Local Instance nat_hasDecidableTotalOrder : isDecidableTotalOrder nat (requiresPoset := nat_isPoset) :=
    { compare := nat_compare
    ; compare_LT_implies := nat_compare_lt
    ; compare_EQ_implies := nat_compare_eq
    ; compare_GT_implies := nat_compare_gt
    }
  .

  End NAT_TOSET.

End BasicPosetTheory.

Module DomainTheoryHelper.

  Import ListNotations BasicPosetTheory.

  Global Reserved Notation " '⟬' X '⟶' Y '⟭' " (X at level 60, Y at level 60, at level 0, no associativity).

  Class isCoLa (D : Type) {requiresPoset : isPoset D} : Type := getSupremumOf_inCoLa (X : ensemble D) : {sup_X : D | isSupremumOf sup_X X}.

  Global Hint Constructors image finite : poset_hints.

  Definition isDirectedOrEmpty {D : Type} {requiresPoset : isPoset D} (X : ensemble D) : Prop :=
    forall x1 : D, << H_IN1 : member x1 X >> ->
    forall x2 : D, << H_IN2 : member x2 X >> ->
    exists x3 : D, << H_IN3 : member x3 X >> /\
    << UPPER_BOUND : x1 =< x3 /\ x2 =< x3 >>
  .

  Definition isDirected {D : Type} {requiresPoset : isPoset D} (X : ensemble D) : Prop :=
    << NONEMPTY : exists x0 : D, member x0 X >> /\ << DIRECTED_OR_EMPTY : isDirectedOrEmpty X >>
  .

  Lemma isDirected_iff {D : Type} {requiresPoset : isPoset D} (X : ensemble D)
    : isDirected X <-> << DIRECTED : forall xs : list D, forall xs_isFiniteSubsetOf : isFiniteSubsetOf xs X, exists y : D, << H_IN : y \in X >> /\ << UPPER_BOUND : forall x : D, In x xs -> x =< y >> >>.
  Proof with eauto with *.
    split; intros DIRECTED.
    - ii. destruct DIRECTED; desnw. induction xs as [ | x xs IH].
      + exists (x0). split... intros z [].
      + assert (xs_isFiniteSubsetOf' : isFiniteSubsetOf xs X).
        { ii. eapply xs_isFiniteSubsetOf. right... }
        pose proof (IH xs_isFiniteSubsetOf') as [y' ?]; desnw.
        assert (x_in_X : x \in X).
        { eapply xs_isFiniteSubsetOf. left... }
        pose proof (DIRECTED_OR_EMPTY x x_in_X y' H_IN) as [y [? [? ?]]].
        exists (y). split... intros x1 [x1_eq_x | x1_in_xs].
        { subst x1... }
        { transitivity (y')... }
    - unnw. split.
      + assert (xs_isFiniteSubsetOf : isFiniteSubsetOf [] X).
        { intros z []. }
        pose proof (DIRECTED [] xs_isFiniteSubsetOf) as [x0 ?]; desnw.
        exists (x0)...
      + ii. set (xs := [x1; x2]).
        assert (xs_isFiniteSubsetOf : isFiniteSubsetOf xs X).
        { intros z [z_eq_x1 | [z_eq_x2 | []]]; subst z... }
        pose proof (DIRECTED xs xs_isFiniteSubsetOf) as [y [H_IN UPPER_BOUND]].
        exists (y). split... split; eapply UPPER_BOUND; [left | right; left]...
  Qed.

  Class isCPO (D : Type) {requiresPoset : isPoset D} : Type :=
    { getBottom_inCPO : D
    ; getSupremumOf_inCPO (X : ensemble D) (X_isDirected : isDirected X) : D
    ; getBottom_inCPO_isBottom : forall x : D, getBottom_inCPO =< x
    ; getSupremumOf_inCPO_isSupremum (X : ensemble D) (X_isDirected : isDirected X) : isSupremumOf (getSupremumOf_inCPO X X_isDirected) X
    }
  .

  Lemma preservesDirected_if_isMonotonicMap {dom : Type} {cod : Type} {dom_requiresPoset : isPoset dom} {cod_requiresPoset : isPoset cod} (f : dom -> cod)
    (f_isMonotonicMap : isMonotonicMap f)
    : forall X : ensemble dom, << DIRECTED : isDirected X >> -> isDirected (image f X).
  Proof.
    ii; desnw. destruct DIRECTED; desnw. split; unnw.
    - exists (f x0). econstructor; eauto.
    - intros y1 ? y2 ?; desnw. apply in_image_iff in H_IN1, H_IN2.
      destruct H_IN1 as [x1 [y1_eq x1_in]]; destruct H_IN2 as [x2 [y2_eq x2_in]]; subst y1 y2.
      pose proof (DIRECTED_OR_EMPTY x1 x1_in x2 x2_in) as [x3 [x3_in [x1_le_x3 x2_le_x3]]]; unnw.
      exists (f x3). rewrite in_image_iff. split; eauto with *.
  Qed.

End DomainTheoryHelper.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := mult lf2 (plus Zero x).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  mult (Succ x) (Succ y).


Inductive Node : Type :=
| null
| node (x:nat) (ls rs :Node).

Inductive cmpType :=
|less
|greater
|equal.

Fixpoint cmp x y : cmpType :=
match x,y with
|0,0 => equal
|S n, 0 => greater
|0, S n => less
|S x, S y => cmp x y
end.

Definition Greater ( x y : nat) : bool :=
  match ( cmp x y ) with
  | greater => true
  | _ => false
  end.

Definition Less ( x y : nat) : bool :=
  match ( cmp x y ) with
  | less => true
  | _ => false
  end.

Notation " x <? y" := (Less x y ) ( at level 50 , left associativity).
Notation " x >? y" := (Greater x y ) ( at level 50 , left associativity).

Fixpoint insert (rt : Node) (val : nat) : Node :=
  match rt with
  | null => node val null null
  | node x ls rs =>
      match cmp val x with
      |equal => rt
      |less  => node x (insert ls val) rs
      |greater => node x ls (insert rs val)
      end
  end.

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

Fixpoint Count (rt : Node) (val : nat ) : bool :=
  match rt with
  |null => false
  |node x ls rs =>
      match cmp val x with
      |equal => true
      |less  => Count ls val
      |greater => Count rs val
     end
 end.

Definition LL_Rotate (rt : Node) : Node :=
 match rt with
|null => null
|node gf (node f fl fr) gfr => node f fl (node gf fr gfr)
|_ => rt
end.

Definition RR_Rotate (rt : Node) : Node :=
 match rt with
|null => null
|node gf gfl (node f fl fr)  => node f (node gf  gfl fl)  fr
|_ => rt
end.

Definition Max (x y : nat) : nat :=
  match cmp x y with
  |greater => x
  |_ => y
  end.

Fixpoint Depth (rt:Node) : nat :=
  match rt with
  |null => 0
  |node x ls rs => 1 + max (Depth ls) (Depth rs)
end.

Definition t1 := null<-2<-1<-3<-4<-5.

Fixpoint Dif (x y : nat) : nat :=
  match x,y with
  |0,_ => y
  |_,0 => x
  |S x', S y' => Dif x' y'
  end.

Definition LR_Rotate (rt:Node) : Node :=
  match rt with
  | null => null
  | node x ls rs =>
      match ls with
      |null => rt
      |_    => LL_Rotate ( node x (RR_Rotate ls) rs )
     end
end.

Definition RL_Rotate (rt:Node) :Node :=
  match rt with
  | null => null
  | node x ls rs =>
      match rs with
      |null => rt
      |_    => RR_Rotate ( node x ls (LL_Rotate rs) )
     end
end.

Inductive dir : Type :=
|left
|right.

Definition getVal(rt : Node) : nat :=
  match rt with
  | null => 0
  |node x y z => x
  end.

Definition Balance (rt : Node) (val : nat) (d :dir) : Node :=
  match rt with
  |null => null
  |node x ls rs =>
    match (Dif (Depth ls) (Depth rs)) , d with
    |0,_ => rt
    |1,_ => rt
    |_,left => if ( val >? (getVal ls) ) then LL_Rotate rt
               else LR_Rotate rt
    |_,right => if( val <? (getVal rs) ) then RR_Rotate rt
               else RL_Rotate rt
    end
 end.

Fixpoint AVL_insert (rt : Node) (val : nat) : Node :=
  match rt with
  | null => node val null null
  | node x ls rs =>
      match cmp val x with
      |equal => rt
      |less  => Balance ( node x (AVL_insert ls val) rs ) val left
      |greater => Balance ( node x ls (AVL_insert rs val) ) val right
      end
  end.

Notation "x <. y" := (AVL_insert x y) ( at level 50 , left associativity).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (lf2 : natural) (lf1 : natural) : natural :=
  mult (Succ Zero) lf1.


(* This file contains some important results on lists of elements from an ordered type.
   Following are some important notions formalized in this file----------------------

 IsOrd l           <==> l is an strictly increasing list
 isOrd l           ==> boolean function to check if the list is strictly increasing

 Some of the useful results in this file are:

 Lemma IsOrd_NoDup (l: list A): IsOrd l -> NoDup l.
 Lemma isOrdP (l:list A): reflect(IsOrd l)(isOrd l).

 Lemma head_equal (a b: A)(l s: list A):
            IsOrd (a::l)-> IsOrd (b::s)-> Equal (a::l) (b::s)-> a=b.
 Lemma tail_equal (a b: A)(l s:list A):
            IsOrd (a::l)->IsOrd (b::s)->Equal (a::l)(b::s)-> Equal l s.
 Lemma set_equal (l s: list A): IsOrd l -> IsOrd s -> Equal l s -> l=s.
 Lemma length_equal (l s: list A): IsOrd l -> IsOrd s -> Equal l s -> |l|=|s|.
                                                                             ------- *)

Require Export Lists.List.
Require Export GenReflect SetSpecs OrdType.
Require Export DecList.

Set Implicit Arguments.

Section OrderedLists.
  Context {A: ordType}.
  (* Variable A: ordType.  *)

  Lemma decA (x y:A): {x=y}+{x<>y}.
  Proof. eapply reflect_dec with (b:= eqb x y). apply eqP. Qed.

  Lemma EM_A (x y: A): x=y \/ x<>y.
  Proof. eapply reflect_EM with (b:= eqb x y). apply eqP. Qed.

  (* ------------IsOrd Predicate  -----------------------------------------------  *)
  Inductive IsOrd :list A -> Prop:=
  |  IsOrd_nil: IsOrd nil
  | IsOrd_singl: forall x:A, IsOrd (x::nil)
  | IsOrd_cons: forall (x y: A)(l: list A), (ltb x y)-> IsOrd (y::l) -> IsOrd (x::y::l).

  Lemma IsOrd_elim (l: list A)(x y: A): IsOrd (x::y::l)-> IsOrd (y::l).
  Proof. intro H;inversion H; auto. Qed.
  Lemma IsOrd_elim1 (l: list A)(x y: A): IsOrd (x::y::l)-> (ltb x y).
  Proof. intro H;inversion H; auto. Qed.
  Lemma IsOrd_elim0 (l:list A)(x:A): IsOrd (x::l)-> IsOrd(l).
  Proof. case l. constructor. intros s l0. apply IsOrd_elim. Qed.

  Lemma IsOrd_intro (a:A)(l: list A): IsOrd l-> (forall x, In x l -> ltb a x)-> IsOrd (a::l).
  Proof. intros H H1. case l eqn:H2. constructor. constructor.
         apply H1. all: auto. Qed.

  Hint Resolve IsOrd_elim IsOrd_elim1 IsOrd_elim0 IsOrd_intro: core.

  Lemma IsOrd_elim2(l:list A): forall a:A, IsOrd (a::l)-> (forall x:A, In x l-> ltb a x).
  Proof. { induction l.
         { intros a H x H0. inversion H0.  }
         { intros a0 H x H0.
           assert (H1: x=a \/ In x l); auto.
           destruct H1 as [H1 | H1]. rewrite H1. eapply IsOrd_elim1; exact H.
           assert (H2: a <b x). apply IHl; eauto.
           assert (H3 : a0 <b a). eapply IsOrd_elim1;exact H. eauto.   } } Qed.

   Lemma IsOrd_elim2a(l:list A)(a x:A): IsOrd (a::l)-> In x l -> ltb a x.
  Proof. { intros H H1. eapply (@IsOrd_elim2 l a) in H. exact H. auto. } Qed.

  Lemma IsOrd_elim3 (x a: A)(l: list A): IsOrd (a::l)-> ltb x a -> ~ In x (a::l).
  Proof. { intros H H0 H1.
         assert (H2: x=a \/ In x l); eauto.
         destruct H2. eapply ltb_not_eq; eauto.
         assert (H3: a <b x). eapply IsOrd_elim2;eauto.  eapply ltb_antisym;eauto. } Qed.

  Lemma IsOrd_elim4 (a:A)(l: list A): IsOrd (a::l)-> ~ In a l.
  Proof. { intros H H1. assert (H2: ltb a a). eapply IsOrd_elim2;eauto.
           absurd (a <b a); auto. } Qed.

  Lemma IsOrd_elim5 (a b:A)(l: list A): IsOrd (a::l)-> In b (a::l)-> (b=a \/ a <b b).
    Proof.  { intros H1 H2. cut (b=a \/ In b l).
           intro H0; destruct H0 as [Ha | Hb]. left;auto.
           right; eapply IsOrd_elim2;eauto.  eauto. } Qed.

  Hint Resolve IsOrd_elim2a IsOrd_elim3 IsOrd_elim4 IsOrd_elim5: core.

  Lemma IsOrd_NoDup (l: list A): IsOrd l -> NoDup l.
  Proof. { intros. induction l. constructor.
         constructor. eapply IsOrd_elim4;auto.  eauto. } Qed.

  Fixpoint isOrd (l: list A): bool:=
    match l with
    |nil => true
    |x ::l1=> match l1 with
             | nil => true
             | y::l2 => (ltb x y) && (isOrd l1)
             end
    end.
   Lemma isOrd_elim (l: list A)(x y: A): isOrd (x::y::l)-> isOrd (y::l).
   Proof.  simpl; move /andP; tauto.  Qed.
   Lemma isOrd_elim1 (l: list A)(x y: A): isOrd (x::y::l)-> (ltb x y).
   Proof. simpl; move /andP; tauto. Qed.
   Lemma isOrd_elim0 (l:list A)(x:A): isOrd (x::l)-> isOrd(l).
   Proof. case l. simpl;auto.  intros s l0. simpl; move /andP; tauto. Qed.

   Hint Resolve isOrd_elim isOrd_elim1 isOrd_elim0: core.

  Lemma isOrdP (l:list A): reflect(IsOrd l)(isOrd l).
  Proof. { apply reflect_intro. split.
         { intro H. induction l.
         { simpl;auto. }
         { simpl. case l eqn:H1.  auto. apply /andP.
           split. eapply IsOrd_elim1;exact H. apply IHl. eauto. } }
         {  intro H. induction l. constructor. case l eqn:H1.
            constructor. constructor. eapply isOrd_elim1;exact H.
            apply IHl. eapply isOrd_elim. apply H.  } } Qed.

  Hint Resolve isOrdP: core.

  Lemma NoDup_elim1(a:A)(l:list A): NoDup (a::l) -> ~ In a l.
  Proof. eapply NoDup_cons_iff. Qed.

  Lemma NoDup_elim2 (a: A)(l: list A): NoDup (a::l) -> NoDup l.
  Proof. eapply NoDup_cons_iff. Qed.

  Lemma NoDup_intro (a: A)(l: list A): ~ In a l -> NoDup l -> NoDup (a::l).
  Proof. intros; eapply NoDup_cons_iff;auto. Qed.

  Hint Resolve NoDup_elim1 NoDup_elim2 NoDup_intro: core.

  (* --------------------Equality of Ordered Lists---------------------------------------*)

  Definition empty: list A:= nil.

  Lemma empty_equal_nil (l: list A): l [=] empty -> l = empty.
  Proof. { case l. auto. intros s l0. unfold "[=]". intro H.
           destruct H as [H1 H2]. absurd (In s empty). all: eauto. } Qed.

  Lemma head_equal (a b: A)(l s: list A): IsOrd (a::l)-> IsOrd (b::s)-> Equal (a::l) (b::s)-> a = b.
  Proof. { intros H H1 H2.
         assert(H3: In b (a::l)).
         unfold "[=]" in H2. apply H2. auto.
         assert(H3A: b=a \/ a <b b).  eapply IsOrd_elim5; eauto.
         assert(H4: In a (b::s)). unfold "[=]" in H2. apply H2. auto.
         assert(H4A: a = b \/ b <b a). eapply IsOrd_elim5; eauto.
         destruct H3A; destruct H4A.
         auto. symmetry;auto. auto. absurd (b <b a); auto. } Qed.

  Lemma tail_equal (a b: A)(l s:list A):IsOrd (a::l)->IsOrd (b::s)->Equal (a::l)(b::s)-> Equal l s.
  Proof. { intros H H1 H2. unfold "[=]".
         assert(H0: a = b). eapply head_equal;eauto. subst b.
         split; intro x.
         { intro H3. assert (H3A: a <b x).
           eapply IsOrd_elim2a. exact H. auto.
           assert (H3B: In x (a::l)). auto.
           assert (H3C: x=a \/ In x s).
           { cut (In x (a::s)). eauto. apply H2;auto. }
           destruct H3C. absurd (a <b x); eauto. auto. }
          { intro H3. assert (H3A: a <b x). eapply IsOrd_elim2a. exact H1. auto.
           assert (H3B: In x (a::s)). auto.
           assert (H3C: x=a \/ In x l).
           { cut (In x (a::l)). auto.  apply H2;auto. }
           destruct H3C. absurd (a <b x); auto. auto. } } Qed.

  Lemma set_equal (l s: list A): IsOrd l -> IsOrd s -> Equal l s -> l=s.
  Proof. { revert s. induction l; induction s.
         { auto. }
         { intros; symmetry; apply empty_equal_nil; unfold empty; auto.  }
         { intros; apply empty_equal_nil; unfold empty; auto. }
         { intros H H1 H2. replace a0 with a. replace s with l.
           auto. apply IHl. eauto. eauto.
           eapply tail_equal; eauto. eapply head_equal;eauto. } } Qed.

  Lemma length_equal (l s: list A): IsOrd l -> IsOrd s -> Equal l s -> |l|=|s|.
  Proof. intros. replace s with l. auto. eapply set_equal; eauto. Qed.

  Hint Resolve head_equal tail_equal set_equal length_equal: core.

  (*----------Misc property on ordList-------------------------------*)
  Lemma nodup_Subset_elim(a:A)(l s: list A):
    NoDup (a::l)-> NoDup (a::s)-> a::l [<=] a::s -> l [<=] s.
  Proof. { intros H H1 H2 x H3. assert (Hs: In x (a::s)). apply H2; auto.
         destruct Hs. subst x; absurd (In a l); auto. auto. } Qed.

  Lemma IsOrd_Subset_elim1 (e a: A)(l s: list A):
    IsOrd (e::l)-> IsOrd (a::s) -> e::l [<=] a::s -> a <=b e.
  Proof. intros H H1 H2. match_up a e. subst a;auto. auto. absurd (In e (a::s)); auto.  Qed.

  Lemma IsOrd_Subset_elim2 (e a: A)(l s: list A):
    IsOrd (e::l)-> IsOrd (a::s) -> e::l [<=] a::s -> e<>a -> e::l [<=] s.
  Proof. { intros H H1 H2 H3 x Hl.
         destruct Hl.
         { subst x. cut (In e (a::s)). intro H4. destruct H4.
           symmetry in H0. contradiction. auto. auto. }
         { assert(H4: In x (a::s)). auto. destruct H4. subst x.
           assert (H4: e <b a).
           { apply leb_antisym2. exact H3. apply ltb_leb; eapply IsOrd_elim2a.
             exact H. auto. }
           assert (H5: a <=b e). eapply IsOrd_Subset_elim1;eauto.
           by_conflict. auto. } } Qed.

  Lemma idx_IsOrd (l: list A)(x y: A): IsOrd l -> In x l-> In y l-> x <b y -> idx x l < idx y l.
  Proof. { induction l as [| a l'].
           { simpl. tauto. }
           { intros h1 h2 h3 h4.
             assert (h5: x = a \/ x <> a). eauto.
             assert (h6: y = a \/ y <> a). eauto.
             destruct h5 as [h5 |h5]; destruct h6 as [h6 |h6].
             { subst x; subst y. by_conflict. }
             { assert (h3a: In y l'). eauto.
               assert (h3b: idx y l' > 0). auto.
               simpl. replace (x == a) with true.
               replace (y == a) with false. replace (memb y l') with true.
               omega. symmetry; apply /membP;auto. all: symmetry;auto. }
             { assert (h3a: In x l'). eauto.
               assert (h3b: a <b x). eauto. subst y. by_conflict. }
             { assert (h2a: In x l'); eauto.
               assert (h2b: idx x l' > 0); auto.
               assert (h3a: In y l'); eauto.
               assert (h3b: idx y l' > 0); auto.
               simpl. replace (x == a) with false.
               replace (y == a) with false. replace (memb y l') with true.
               replace (memb x l') with true.
               cut (idx x l' < idx y l'). omega. apply IHl';auto. eauto.
               symmetry; apply /membP;auto. all: symmetry;auto. } } } Qed.

End OrderedLists.

Hint Resolve IsOrd_elim IsOrd_elim1 IsOrd_elim0 IsOrd_intro: core.
Hint Resolve IsOrd_elim2a IsOrd_elim3 IsOrd_elim4 IsOrd_elim5: core.
Hint Resolve isOrd_elim isOrd_elim1 isOrd_elim0: core.
Hint Resolve isOrdP: core.

Hint Resolve NoDup_elim1 NoDup_elim2 NoDup_intro: core.
Hint Immediate head_equal tail_equal set_equal length_equal: core.
Hint Resolve IsOrd_NoDup: core.

Hint Resolve nodup_Subset_elim IsOrd_Subset_elim1 IsOrd_Subset_elim2:core.

Hint Resolve idx_IsOrd:core.