(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Import R_sqrt.
Require BuiltIn.
Require real.Real.
Require real.Square.

(* Why3 assumption *)
Definition dot (x1:R) (x2:R) (y1:R) (y2:R): R :=
  ((x1 * y1)%R + (x2 * y2)%R)%R.

(* Why3 assumption *)
Definition norm2 (x1:R) (x2:R): R := ((Rsqr x1) + (Rsqr x2))%R.

Axiom norm2_pos : forall (x1:R) (x2:R), (0%R <= (norm2 x1 x2))%R.

Axiom Lagrange : forall (a1:R) (a2:R) (b1:R) (b2:R), (((norm2 a1
  a2) * (norm2 b1 b2))%R = ((Rsqr (dot a1 a2 b1
  b2)) + (Rsqr ((a1 * b2)%R - (a2 * b1)%R)%R))%R).

Axiom CauchySchwarz_aux : forall (x1:R) (x2:R) (y1:R) (y2:R), ((Rsqr (dot x1
  x2 y1 y2)) <= ((norm2 x1 x2) * (norm2 y1 y2))%R)%R.

(* Why3 assumption *)
Definition norm (x1:R) (x2:R): R := (sqrt (norm2 x1 x2)).

Axiom norm_pos : forall (x1:R) (x2:R), (0%R <= (norm x1 x2))%R.

Axiom sqr_le_sqrt : forall (x:R) (y:R), ((Rsqr x) <= y)%R ->
  (x <= (sqrt y))%R.

Axiom CauchySchwarz : forall (x1:R) (x2:R) (y1:R) (y2:R), ((dot x1 x2 y1
  y2) <= ((norm x1 x2) * (norm y1 y2))%R)%R.

Axiom triangle_aux : forall (x1:R) (x2:R) (y1:R) (y2:R), ((norm2 (x1 + y1)%R
  (x2 + y2)%R) <= (Rsqr ((norm x1 x2) + (norm y1 y2))%R))%R.

Axiom sqr_sqrt_le : forall (x:R) (y:R), ((0%R <= y)%R /\ ((0%R <= x)%R /\
  (x <= (Rsqr y))%R)) -> ((sqrt x) <= y)%R.

(* Why3 goal *)
Theorem triangle : forall (x1:R) (x2:R) (y1:R) (y2:R), ((norm (x1 + y1)%R
  (x2 + y2)%R) <= ((norm x1 x2) + (norm y1 y2))%R)%R.
intros x1 x2 y1 y2.
apply sqr_sqrt_le.
split.
apply Rplus_le_le_0_compat; apply norm_pos.
split.
apply Rplus_le_le_0_compat; apply Rle_0_sqr.
apply triangle_aux.
Qed.


(** 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 (y : natural) (lf1 : natural) (x : natural) : natural :=
  plus (mult x y) y.


(**

This file contains temporary definitions that will eventually
get merged into the various files from the TLC library.

Author: Arthur Charguéraud.
License: CC-by 4.0.

*)

Set Implicit Arguments.
From SLF (* TLC *) Require Import LibTactics LibLogic LibList LibReflect.
From SLF (* TLC *) Require LibListZ LibWf LibMultiset.
Generalizable Variables A B.

(*----------------------*)
(* Nat *)

From SLF (* TLC *) Require Import LibNat LibInt.
Open Scope Int_scope.

Section NatSimpl.
Open Scope nat_scope.
Implicit Types n : nat.

Lemma nat_zero_plus : forall n,
  0 + n = n.
Proof using. intros. math. Qed.

Lemma nat_plus_zero : forall n,
  n + 0 = n.
Proof using. intros. math. Qed.

Lemma nat_plus_succ : forall n1 n2,
  n1 + S n2 = S (n1 + n2).
Proof using. intros. math. Qed.

Lemma nat_minus_zero : forall n,
  n - 0 = n.
Proof using. intros. math. Qed.

Lemma nat_succ_minus_succ : forall n1 n2,
  S n1 - S n2 = n1 - n2.
Proof using. intros. math. Qed.

Lemma nat_minus_same : forall n,
  n - n = 0.
Proof using. intros. math. Qed.

Lemma nat_plus_minus_same : forall n1 n2,
  n1 + n2 - n1 = n2.
Proof using. intros. math. Qed.

End NatSimpl.

Hint Rewrite nat_zero_plus nat_plus_zero nat_plus_succ
  nat_minus_zero nat_succ_minus_succ
  nat_minus_same nat_plus_minus_same : rew_nat.

(** [nat_seq i n] generates a list of variables [x1;x2;..;xn]
    with [x1=i] and [xn=i+n-1]. Such lists are useful for
    generic programming. *)

Fixpoint nat_seq (start:nat) (nb:nat) :=
  match nb with
  | O => nil
  | S nb' => start :: nat_seq (S start) nb'
  end.

Lemma length_nat_seq : forall start nb,
  length (nat_seq start nb) = nb.
Proof using.
  intros. gen start. induction nb; simpl; intros.
  { auto. } { rew_list. rewrite~ IHnb. }
Qed.

(*----------------------*)
(*--LATER: move to TLC LibNatExec *)

Fixpoint nat_compare (x y : nat) :=
  match x, y with
  | O, O => true
  | S x', S y' => nat_compare x' y'
  | _, _ => false
  end.

Lemma nat_compare_eq : forall n1 n2,
  nat_compare n1 n2 = isTrue (n1 = n2).
Proof using.
  intros n1. induction n1; intros; destruct n2; simpl; rew_bool_eq; auto_false.
  rewrite IHn1. extens. rew_istrue. math.
Qed.

(*----------------------*)
(* LibInt *)

Definition max (n m:int) : int :=
  If n > m then n else m.

Lemma max_nonpos : forall n,
  n <= 0 ->
  max 0 n = 0.
Proof using. introv M. unfold max. case_if; math. Qed.

Lemma max_nonneg : forall n,
  n >= 0 ->
  max 0 n = n.
Proof using. introv M. unfold max. case_if; math. Qed.

Lemma max_l : forall n m,
  n >= m ->
  max n m = n.
Proof using. introv M. unfold max. case_if; math. Qed.

Lemma max_r : forall n m,
  n <= m ->
  max n m = m.
Proof using. introv M. unfold max. case_if; math. Qed.

(*----------------------*)
(* LibLogic *)

Lemma if_classicT_eq_if_isTrue : forall A (X Y:A) (P:Prop),
  (If P then X else Y) = (if isTrue P then X else Y).
Proof using. intros. do 2 case_if~. Qed.

(*----------------------*)
(* TLCExec *)

Definition eq_exec A (cmp:A->A->bool) : Prop :=
  forall x y, cmp x y = isTrue (x = y).

(*----------------------*)
(* ListAssoc *)

Module LibListAssoc.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lookup *)

Fixpoint get_opt A B (x:A) (E:list(A*B)) : option B :=
  match E with
  | nil => None
  | (y,v)::E1 => If y = x
                   then Some v
                   else get_opt x E1
  end.

Section GetOpt.
Variables (A B : Type).
Implicit Types a x y : A.
Implicit Types v : B.
Implicit Types l : list (A*B).

Lemma get_opt_nil : forall a,
  get_opt a (nil:list(A*B)) = None.
Proof using. auto. Qed.

Lemma get_opt_cons : forall x v l a,
  get_opt a ((x,v)::l) = (If x = a then Some v else get_opt a l).
Proof using. auto. Qed.

Lemma get_opt_app : forall l1 l2 a,
  get_opt a (l1 ++ l2) = match get_opt a l1 with
                         | None => get_opt a l2
                         | Some v => Some v
                         end.
Proof using.
  introv. induction l1 as [|(y,w) l1']; rew_list; simpl.
  { auto. }
  { case_if~. }
Qed.

End GetOpt.

Hint Rewrite get_opt_nil get_opt_cons get_opt_app : rew_listx.

Global Opaque get_opt.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Equivalence *)

Definition equiv A B (l1 l2:list(A*B)) :=
  forall x, get_opt x l1 = get_opt x l2.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Disjointness *)

Definition disjoint A B (l1 l2:list(A*B)) :=
  forall x v1 v2, get_opt x l1 = Some v1 -> get_opt x l2 = Some v2 -> False.

(* --TODO: equivalent definitions of disjoint using mem *)

Section Disjoint.
Variables (A B : Type).
Implicit Types l : list (A*B).

Lemma disjoint_cons_l_inv : forall x v l1 l2,
  disjoint ((x,v)::l1) l2 ->
  disjoint l1 l2.
Proof using.
  introv M. intros y v1 v2 K1 K2. tests C: (x = y).
  { applys M v v2 K2. rewrite get_opt_cons. case_if~. }
  { applys M v1 v2 K2. rewrite get_opt_cons. case_if~. }
Qed.

End Disjoint.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Remove key *)

Definition rem A B (x:A) (l:list(A*B)) :=
  LibList.filter (fun '(y,v) => x <> y) l.

Section Rem.
Variables (A B : Type).
Implicit Types a x y : A.
Implicit Types v : B.
Implicit Types l : list (A*B).

Lemma rem_as_filter : forall a l,
  rem a l = LibList.filter (fun '(x,v) => a <> x) l.
Proof using. auto. Qed.

Lemma rem_nil : forall a,
  rem a (nil:list(A*B)) = nil.
Proof using. auto. Qed.

Lemma rem_cons : forall x v l a,
  rem a ((x,v)::l) = (If x = a then rem a l else (x,v) :: rem a l).
Proof using. intros. unfold rem. rewrite filter_cons. repeat case_if~. Qed.

Lemma rem_app : forall l1 l2 a,
  rem a (l1 ++ l2) = rem a l1 ++ rem a l2.
Proof using. intros. unfold rem. rewrite~ filter_app. Qed.

Lemma rem_last : forall x v l a,
  rem a (l & (x,v)) = rem a l ++ (If x = a then nil else (x,v)::nil).
Proof using. intros. unfold rem. rewrite filter_last. repeat case_if~. Qed.

Lemma get_opt_rem : forall x a l,
  get_opt x (rem a l) = (If x = a then None else get_opt x l).
Proof using.
  intros. induction l as [|(y,v) l']; simpl.
  { do 2 rewrite~ get_opt_nil. case_if~. }
  { rewrite rem_cons. rewrite get_opt_cons.
    case_if; try rewrite get_opt_cons; repeat case_if; auto. }
Qed.

Lemma equiv_rem : forall a l1 l2,
  equiv l1 l2 ->
  equiv (rem a l1) (rem a l2).
Proof using.
  introv M. unfolds equiv. intros y.
  do 2 rewrite get_opt_rem. case_if~.
Qed.

Lemma disjoint_rem : forall a l1 l2,
  disjoint l1 l2 ->
  disjoint (rem a l1) (rem a l2).
Proof using.
  introv D. intros y v1 v2 K1 K2. rewrite get_opt_rem in *.
  case_if~. applys* D K1 K2.
Qed.

End Rem.

Hint Rewrite rem_nil rem_cons rem_app rem_last : rew_listx.

Global Opaque rem.

End LibListAssoc.

Module LibListAssocExec.
Import LibListAssoc.

Definition is_beq A (beq:A->A->bool) :=
  forall x y, beq x y = isTrue (x = y).

Fixpoint get_opt A (beq:A->A->bool) B (a:A) (l:list(A*B)) : option B :=
  match l with
  | nil => None
  | (x,v)::l' => if beq x a
                   then Some v
                   else get_opt beq a l'
  end.

Lemma get_opt_eq : forall A beq B a (l:list(A*B)),
  is_beq beq ->
  get_opt beq a l = LibListAssoc.get_opt a l.
Proof using.
  introv M. induction l as [|(x,v) l']; simpl.
  { rewrite~ get_opt_nil. }
  { rewrite~ get_opt_cons. rewrite M. repeat case_if; auto. }
Qed.

Fixpoint rem A (beq:A->A->bool) B (x:A) (E:list(A*B)) : list(A*B) :=
  match E with
  | nil => nil
  | (y,v)::E' =>
      let E'' := rem beq x E' in
      if beq x y then E'' else (y,v)::E''
  end.

Lemma rem_eq : forall A beq B a (l:list(A*B)),
  is_beq beq ->
  rem beq a l = LibListAssoc.rem a l.
Proof using.
  introv M. induction l as [|(x,v) l']; simpl.
  { rewrite~ rem_nil. }
  { rewrite~ rem_cons. rewrite M. repeat case_if; fequals. }
Qed.

End LibListAssocExec.

(*----------------------*)
(* List *)

Section ListSub.
Variable (A:Type).

(** Sub-list well-founded order *)

Inductive list_sub : list A -> list A -> Prop :=
  | list_sub_cons : forall x l,
      list_sub l (x::l)
  | list_sub_tail : forall x l1 l2,
      list_sub l1 l2 ->
      list_sub l1 (x::l2).

Hint Constructors list_sub.

Lemma list_sub_wf : LibWf.wf list_sub.
Proof using.
  intros l. induction l; apply Acc_intro; introv H.
  { inverts~ H. }
  { inverts~ H. applys~ IHl. }
Qed.

End ListSub.

Arguments list_sub {A}.
Hint Constructors list_sub.
Hint Resolve list_sub_wf : wf.

Lemma length_zero_inv : forall A (L:list A),
  length L = 0%nat ->
  L = nil.
Proof using.
  introv N. destruct L as [|]; rew_list in *; tryfalse. eauto.
Qed.

Lemma length_one_inv : forall A (L:list A),
  length L = 1%nat ->
  exists x, L = x::nil.
Proof using.
  introv N. destruct L as [|x [|]]; rew_list in *; tryfalse. eauto.
Qed.

Lemma update_cons_case : forall (n:nat) A (v:A) (x:A) (l:list A),
  LibList.update n v (x::l) = (If n = 0%nat then v::l else x::(LibList.update (n-1) v l)).
Proof using.
  intros. destruct n as [|n']; case_if.
  { applys update_zero. }
  { rewrite update_cons. fequals_rec. math. }
Qed.

Lemma update_nth_same : forall A `{Inhab A} (n:nat) (l:list A),
  n < length l ->
  LibList.update n (LibList.nth n l) l = l.
Proof using.
  introv E. gen n. induction l as [|x l']; intros.
  { rewrite length_nil in E. false. math. }
  { rewrite length_cons in E. rewrite update_cons_case.
    destruct n as [|n']; case_if.
    { subst. rewrite* nth_zero. }
    { fequals. rewrite nth_cons. math_rewrite (S n' - 1 = n')%nat.
      rewrite* IHl'. math. } }
Qed.

Global Opaque LibList.update.

(*----------------------*)
(* ListExec *)

From SLF (* TLC *) Require Import LibLogic. (* needed? *)
From SLF (* TLC *) Require Import LibReflect.

Lemma not_mem_inv : forall A x y (l:list A),
  ~ mem x (y::l) ->
  x <> y /\ ~ mem x l.
Proof using.
  introv M. split.
  { intro_subst. false* M. }
  { intros N. false* M. }
Qed.

Definition is_nil A (l:list A) : bool :=
  match l with
  | nil => true
  | _ => false
  end.

Lemma is_nil_eq : forall A (l:list A),
  is_nil l = isTrue (l = nil).
Proof using. intros. destruct l; simpl; rew_bool_eq; auto_false. Qed.

Definition is_not_nil A (l:list A) : bool :=
  match l with
  | nil => false
  | _ => true
  end.

Lemma is_not_nil_eq : forall A (l:list A),
  is_not_nil l = isTrue (l <> nil).
Proof.
  intros. destruct l; simpl; rew_bool_eq; auto_false.
Qed.

Lemma List_length_eq :
  List.length = LibList.length.
Proof using. extens ;=> A l. induction l; simpl; rew_list; auto. Qed.

Lemma List_fold_right_eq : forall A B (f:A->B->B) (l:list A) (b:B),
  List.fold_right f b l = LibList.fold_right f b l.
Proof using. intros. induction l; simpl; rew_list; fequals. Qed.

Lemma List_app_eq :
  List.app = LibList.app.
Proof using.
  extens ;=> A L1 L2. induction L1; simpl; rew_list; congruence.
Qed.

Lemma List_rev_eq : forall A, (* --LATER: why fails if A is not quantified here? *)
  @List.rev A = @LibList.rev A.
Proof using.
  extens ;=> L. induction L; simpl; rew_list. { auto. }
  { rewrite List_app_eq. simpl. congruence. }
Qed.

Lemma List_map_eq :
  List.map = LibList.map.
Proof using.
  extens ;=> A B f L. induction L; simpl; rew_listx; congruence.
Qed.

Lemma List_combine_eq : forall A B (L1:list A) (L2:list B),
  length L1 = length L2 ->
  List.combine L1 L2 = LibList.combine L1 L2.
Proof using. (* --LATER: redo proof using list2_ind *)
  introv E. gen L2.
  induction L1 as [|x1 L1']; intros; destruct L2 as [|x2 L2']; tryfalse.
  { auto. }
  { rew_list in E. simpl. fequals~. }
Qed.

Hint Rewrite LibList.length_map : rew_listx.

(* --TODO: replace all List_foo_eq with a rew_list_exec tactic *)

Fixpoint mem_exec A (cmp:A->A->bool) (x:A) (l:list A) : bool :=
  match l with
  | nil => false
  | y::l' => cmp x y || mem_exec cmp x l'
  end.

Lemma mem_exec_eq : forall A (cmp:A->A->bool) x l,
  eq_exec cmp ->
  mem_exec cmp x l = isTrue (mem x l).
Proof using.
  introv Xcmp. induction l as [|y l']; simpl; rew_listx; rew_isTrue; fequals.
Qed.

(*----------------------*)
(* Hint for LibListZ *)

Hint Rewrite LibListZ.length_map LibListZ.index_map_eq : rew_arr.

(*----------------------*)
(* LibList *)

(** The congruence rule for [map] on lists *)

Lemma map_congr : forall A B (f1 f2 : A->B) l,
  (forall x, mem x l -> f1 x = f2 x) ->
  LibList.map f1 l = LibList.map f2 l.
Proof using.
  introv H. induction l. { auto. } { rew_listx. fequals~. }
Qed.

Lemma map_map : forall A B C (l:list A) (f:A->B) (g:B->C),
  map g (map f l) = map (fun x => g (f x)) l.
Proof using.
  intros. induction l as [|x l'].
  { auto. }
  { repeat rewrite map_cons. fequals. }
Qed.

Lemma mem_map' : forall A B (l : list A) (f:A->B) (x:A) (y:B),
  mem x l ->
  y = f x ->
  mem y (LibList.map f l).
Proof using. intros. subst. applys* mem_map. Qed.

Lemma LibListZ_length_zero_eq_eq_nil : forall A (l:list A),
  (LibListZ.length l = 0) = (l = nil).
Proof using.
  intros. rewrite <- length_zero_eq_eq_nil.
  unfold LibListZ.length. extens. math.
Qed.

(*----------------------*)
(* LibInt *)

Global Opaque Z.mul.
Global Opaque Z.add.

(*----------------------*)
(* LibEqual *)

Section FuncExtDep.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).

Lemma fun_eta_dep_3 : forall (f : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), A4 x3),
  (fun x1 x2 x3 => f x1 x2 x3) = f.
Proof using. intros. apply~ fun_ext_3. Qed.

End FuncExtDep.

(* ---------------------------------------------------------------------- *)
(* LibTactics *)

(* problematic to prove [(forall h, H1 h <-> H2 h) -> (H1 h <-> H2 h)]
Ltac jauto_set_goal ::=
  repeat match goal with
  | |- exists a, _ => esplit
  | |- _ /\ _ => split
  | |- _ <-> _ => split
  end. *)

Ltac fequal_base ::=
  let go := f_equal_fixed; [ fequal_base | ] in
  match goal with
  | |- exist _ _ = exist _ _ => apply exist_eq_exist
  | |- (_,_,_) = (_,_,_) => go
  | |- (_,_,_,_) = (_,_,_,_) => go
  | |- (_,_,_,_,_) = (_,_,_,_,_) => go
  | |- (_,_,_,_,_,_) = (_,_,_,_,_,_) => go
  | |- _ => f_equal_fixed
  end.

(* [isubst] generalizes [intro_subst]
  DEPRECATED : should use [intros ? ->] *)

Ltac isbust_core tt :=
  match goal with |- forall _, _ = _ -> _ =>
    let X := fresh "TEMP" in
    let HX := fresh "E" X in
    intros X HX; subst X
  end.

Tactic Notation "isubst" :=
  isbust_core tt.

(** [get_head E] implemented recursively *)

Ltac get_head E :=
  match E with
  | ?E' ?x => get_head E'
  | _ => constr:(E)
  end.

(** [has_no_evar E] succeeds if [M] contains no evars. *)

Ltac has_no_evar E :=
  first [ has_evar E; fail 1 | idtac ].

(* ---------------------------------------------------------------------- *)
(* Cases *)

Tactic Notation "cases" constr(E) :=
  let H := fresh "Eq" in cases E as H.

(* ---------------------------------------------------------------------- *)
(* Induction on pairs of lists *)

Lemma list2_ind : forall A B (P:list A->list B->Prop) l1 l2,
  length l1 = length l2 ->
  P nil nil ->
  (forall x1 xs1 x2 xs2,
     length xs1 = length xs2 -> P xs1 xs2 -> P (x1::xs1) (x2::xs2)) ->
  P l1 l2.
Proof using.
  introv E M1 M2. gen l2. induction l1 as [|x1 l1']; intros;
   destruct l2 as [|x2 l2']; try solve [false; math]; auto.
Qed.

Tactic Notation "list2_ind" constr(l1) constr(l2) :=
  pattern l2; pattern l1;
  match goal with |- (fun a => (fun b => @?P a b) _) _ =>
   (* applys list2_ind P *)
   let X := fresh "P" in set (X := P); applys list2_ind X; unfold X; try clear X
 end.

Tactic Notation "list2_ind" "~" constr(l1) constr(l2) :=
  list2_ind l1 l2; auto_tilde.

Tactic Notation "list2_ind" "*" constr(l1) constr(l2) :=
  list2_ind l1 l2; auto_star.

Tactic Notation "list2_ind" constr(E) :=
  match type of E with length ?l1 = length ?l2 =>
    list2_ind l1 l2; [ apply E | | ] end.

(** Same, but on last element *)

Lemma list2_ind_last : forall A B (P:list A->list B->Prop) l1 l2,
  length l1 = length l2 ->
  P nil nil ->
  (forall x1 xs1 x2 xs2,
     length xs1 = length xs2 -> P xs1 xs2 -> P (xs1&x1) (xs2&x2)) ->
  P l1 l2.
Proof using.
  introv E M1 M2. gen l2. induction l1 using list_ind_last;
   [| rename a into x1, l1 into l1']; intros;
   destruct (last_case l2) as [|(x2&l2'&E2)]; subst; rew_list in *;
   try solve [false; math]; auto.
Qed.

Tactic Notation "list2_ind_last" constr(l1) constr(l2) :=
  pattern l2; pattern l1;
  match goal with |- (fun a => (fun b => @?P a b) _) _ =>
   (* applys list2_ind P *)
   let X := fresh "P" in set (X := P); applys list2_ind_last X; unfold X; try clear X
 end.

Tactic Notation "list2_ind_last" "~" constr(l1) constr(l2) :=
  list2_ind_last l1 l2; auto_tilde.

Tactic Notation "list2_ind_last" "*" constr(l1) constr(l2) :=
  list2_ind_last l1 l2; auto_star.

Tactic Notation "list2_ind_last" constr(E) :=
  match type of E with length ?l1 = length ?l2 =>
    list2_ind_last l1 l2; [ apply E | | ] end.

(* ---------------------------------------------------------------------- *)
(* LibMultiset *)

Tactic Notation "multiset_eq" := (* --TODO: move to TLC *)
  check_noevar_goal; LibMultiset.permut_simpl.

(* ---------------------------------------------------------------------- *)
(* LibList *)

Hint Rewrite fold_nil fold_cons fold_app : rew_listx.

Lemma list_same_length_inv_nil : forall A1 A2 (l1:list A1) (l2:list A2),
  length l1 = length l2 ->
  l1 = nil <-> l2 = nil.
Proof using. intros. destruct l1; destruct l2; auto_false*. Qed.

(* ---------------------------------------------------------------------- *)
(* LibTactics, temporary for Coq < 8.11 *)

Ltac nrapply H :=
  first
  [ notypeclasses refine (H)
  | notypeclasses refine (H _)
  | notypeclasses refine (H _ _)
  | notypeclasses refine (H _ _ _)
  | notypeclasses refine (H _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _ _ _ _ _ _)
  | notypeclasses refine (H _ _ _ _ _ _ _ _ _ _ _ _ _ _) ].

(* ---------------------------------------------------------------------- *)
(* LibWf *)

From SLF (* TLC *) Require Import LibWf.

Ltac induction_wf_core_then IH E X cont ::=
  let clearX tt :=
    first [ clear X | fail 3 "the variable on which the induction is done appears in the hypotheses" ] in
  first [ pattern X;
          first [ eapply (@well_founded_ind _ E)
                | eapply (@well_founded_ind _ (E _))
                | eapply (@well_founded_ind _ (E _ _))
                | eapply (@well_founded_ind _ (E _ _ _))
                | applys well_founded_ind (wf_measure E)
                | applys well_founded_ind E ];
          clearX tt;
          match goal with
          | |- wf _ => auto with wf
          | |- well_founded _ => change well_founded with wf; auto with wf
          | |- _ => intros X IH; cont tt
          end ].

Global Arguments list_sub [A].

(* 2020-03-09 15:04:14 (UTC+01) *)


Require Import init.

Require Export topology_base.
Require Export topology_order.
Require Export topology_order2.
Require Export topology_connected.
Require Export real.
Require Import rat.
Require Import rat_abstract.
Require Import order_minmax.
Require Import card_types.

Definition real_order_topology := order_topology (U := real).

(* begin hide *)
Section RealOrderTopology.

Existing Instance real_order_topology.
(* end hide *)
Theorem real_open_interval : ∀ B, top_basis B → ∃ a b, B = open_interval a b.
Proof.
    intros B B_basis.
    destruct B_basis as [B_basis|[B_basis|B_basis]].
    -   exact B_basis.
    -   destruct B_basis as [a [b [B_eq b_max]]].
        specialize (b_max (b + 1)).
        rewrite <- nlt_le in b_max.
        exfalso; apply b_max.
        apply lt_plus_one.
    -   destruct B_basis as [a [b [B_eq a_min]]].
        specialize (a_min (a - 1)).
        apply le_plus_rrmove in a_min.
        rewrite neg_neg in a_min.
        rewrite <- nlt_le in a_min.
        exfalso; apply a_min.
        apply lt_plus_one.
Qed.

Theorem real_open_interval_eq : ∀ B, top_basis B ↔ ∃ a b, B = open_interval a b.
Proof.
    intros B.
    split.
    -   apply real_open_interval.
    -   intros B_basis.
        left.
        exact B_basis.
Qed.

Theorem real_connected : connected real.
Proof.
    apply complete_connected.
Qed.

Global Instance real_hausdorff : HausdorffSpace real.
Proof.
    split.
    assert (∀ a b, a < b → ∃ S1 S2, open S1 ∧ open S2 ∧ S1 a ∧ S2 b
        ∧ disjoint S1 S2) as wlog.
    {
        intros a b ltq.
        exists (open_interval (a - 1) ((a + b)/2)),
               (open_interval ((a + b)/2) (b + 1)).
        split; [>|split; [>|split; [>|split]]].
        -   apply open_interval_open.
        -   apply open_interval_open.
        -   split.
            +   apply lt_minus_one.
            +   apply average_leq1.
                exact ltq.
        -   split.
            +   apply average_leq2.
                exact ltq.
            +   apply lt_plus_one.
        -   apply empty_eq.
            intros x [[lt1 lt2] [lt3 lt4]].
            pose proof (trans lt2 lt3) as lt.
            contradiction (irrefl _ lt).
    }
    intros a b neq.
    destruct (trichotomy a b) as [[leq|eq]|leq]; [>|contradiction|].
    -   exact (wlog a b leq).
    -   specialize (wlog b a leq)
            as [S1 [S2 [S1_open [S2_open [S1a [S2a dis]]]]]].
        exists S2, S1.
        repeat split; try assumption.
        unfold disjoint.
        rewrite inter_comm.
        exact dis.
Qed.

Definition real_rat_basis (S : real → Prop) := ∃ a b : rat,
    a < b ∧ S = open_interval (rat_to_abstract a) (rat_to_abstract b).

Theorem real_rat_basis_countable : countable (|set_type real_rat_basis|)%card.
Proof.
    unfold countable.
    rewrite <- nat_mult_nat.
    rewrite <- rat_size.
    unfold le, mult; equiv_simpl.
    exists (λ S, (ex_val [|S], ex_val (ex_proof [|S]))).
    split.
    intros A B.
    unfold ex_val at 1 3, ex_proof.
    destruct (ex_to_type [|A]) as [a C0]; cbn.
    destruct (ex_to_type [|B]) as [a2 C1]; cbn.
    rewrite_ex_val b [ab A_eq].
    rewrite_ex_val b2 [ab2 B_eq].
    clear C0 C1.
    intros eq.
    inversion eq; clear eq.
    subst a2 b2.
    rewrite <- B_eq in A_eq.
    rewrite set_type_eq in A_eq.
    exact A_eq.
Qed.

Theorem real_rat_basis_open : real_rat_basis ⊆ open.
Proof.
    intros S [a [b [ab S_eq]]]; subst S.
    apply open_interval_open.
Qed.

Theorem real_rat_basis_contains :
    ∀ S x, open S → S x → ∃ B, real_rat_basis B ∧ B ⊆ S ∧ B x.
Proof.
    intros S x S_open Sx.
    rewrite <- open_all_basis in S_open.
    specialize (S_open x Sx) as [B [B_basis [Bx B_sub]]].
    apply real_open_interval in B_basis as [a [b B_eq]]; subst B.
    destruct Bx as [ax xb].
    pose proof (rat_dense_in_arch a x ax) as [a' [a'_gt a'_lt]].
    pose proof (rat_dense_in_arch x b xb) as [b' [b'_gt b'_lt]].
    exists (open_interval (rat_to_abstract a') (rat_to_abstract b')).
    split; [>|split].
    -   exists a', b'.
        split; [>|reflexivity].
        rewrite <- rat_to_abstract_lt.
        exact (trans a'_lt b'_gt).
    -   intros y [y_gt y_lt].
        apply B_sub.
        split.
        +   exact (trans a'_gt y_gt).
        +   exact (trans y_lt b'_lt).
    -   split; assumption.
Qed.

Definition real_rat_topology := make_basis_topology
    real_rat_basis real_rat_basis_open real_rat_basis_contains.

(* begin hide *)
End RealOrderTopology.

Section LowerLimit.
(* end hide *)
Program Instance real_lower_limit_topology : TopologyBasis real := {
    top_basis S := ∃ a b, S = closed_open_interval a b
}.
Next Obligation.
    exists (closed_open_interval x (x + 1)).
    split.
    -   exists x, (x + 1).
        reflexivity.
    -   split.
        +   apply refl.
        +   apply lt_plus_one.
Qed.
Next Obligation.
    rename H into a1, H5 into b1, H0 into a2, H3 into b2.
    rename H1 into S1, H2 into S2.
    exists (closed_open_interval (max a1 a2) (min b1 b2)).
    split.
    2: split.
    -   exists (max a1 a2), (min b1 b2).
        reflexivity.
    -   split.
        +   unfold max; case_if.
            *   apply S2.
            *   apply S1.
        +   unfold min; case_if.
            *   apply S1.
            *   apply S2.
    -   intros y [y_ge y_lt].
        split; split.
        +   exact (trans (lmax _ _) y_ge).
        +   exact (lt_le_trans y_lt (lmin _ _)).
        +   exact (trans (rmax _ _) y_ge).
        +   exact (lt_le_trans y_lt (rmin _ _)).
Qed.

(* begin hide *)
End LowerLimit.

Section KTop.
(* end hide *)
Definition real_K x := ∃ n, x = /(from_nat (nat_suc n)).

Program Instance real_k_topology : TopologyBasis real := {
    top_basis S := ∃ a b,
        (S = open_interval a b) ∨
        (S = (open_interval a b - real_K)%set)
}.
Next Obligation.
    exists (open_interval (x - 1) (x + 1)).
    split.
    -   exists (x - 1), (x + 1).
        left.
        reflexivity.
    -   split.
        1: apply lt_plus_rrmove.
        all: apply lt_plus_one.
Qed.
Next Obligation.
    rename H into a1, H5 into b1, H0 into a2, H3 into b2.
    rename H6 into B1_open, H4 into B2_open.
    rename H1 into B1x, H2 into B2x.
    assert (open_interval a1 b1 x) as x_in1 by
        (destruct B1_open; subst; apply B1x).
    assert (open_interval a2 b2 x) as x_in2 by
        (destruct B2_open; subst; apply B2x).
    classic_case (real_K x) as [Kx|nKx].
    -   destruct B1_open as [B1_open|contr].
        2: {
            rewrite contr in B1x.
            destruct B1x; contradiction.
        }
        destruct B2_open as [B2_open|contr].
        2: {
            rewrite contr in B2x.
            destruct B2x; contradiction.
        }
        subst; clear B1x B2x.
        exists (open_interval (max a1 a2) (min b1 b2)).
        split.
        2: split.
        +   exists (max a1 a2), (min b1 b2).
            left.
            reflexivity.
        +   split.
            *   unfold max; case_if.
                --  apply x_in2.
                --  apply x_in1.
            *   unfold min; case_if.
                --  apply x_in1.
                --  apply x_in2.
        +   intros y [y_gt y_lt].
            split; split.
            *   exact (le_lt_trans (lmax _ _) y_gt).
            *   exact (lt_le_trans y_lt (lmin _ _)).
            *   exact (le_lt_trans (rmax _ _) y_gt).
            *   exact (lt_le_trans y_lt (rmin _ _)).
    -   exists (open_interval (max a1 a2) (min b1 b2) - real_K)%set.
        split.
        2: split.
        +   exists (max a1 a2), (min b1 b2).
            right.
            reflexivity.
        +   split.
            1: split.
            *   unfold max; case_if.
                --  apply x_in2.
                --  apply x_in1.
            *   unfold min; case_if.
                --  apply x_in1.
                --  apply x_in2.
            *   exact nKx.
        +   intros y [[y_gt y_lt] nKy].
            assert (open_interval a1 b1 y) as y_in1.
            {
                split.
                -   exact (le_lt_trans (lmax _ _) y_gt).
                -   exact (lt_le_trans y_lt (lmin _ _)).
            }
            assert (open_interval a2 b2 y) as y_in2.
            {
                split.
                -   exact (le_lt_trans (rmax _ _) y_gt).
                -   exact (lt_le_trans y_lt (rmin _ _)).
            }
            split.
            *   destruct B1_open; subst.
                2: split.
                1, 2: exact y_in1.
                exact nKy.
            *   destruct B2_open; subst.
                2: split.
                1, 2: exact y_in2.
                exact nKy.
Qed.

(* begin hide *)
End KTop.
(* end hide *)
Theorem real_lower_limit_finer : topology_strictly_finer
    (@basis_topology _ real_lower_limit_topology)
    (@basis_topology _ real_order_topology).
Proof.
    apply topology_not_finer_strict.
    -   apply topology_basis_finer.
        intros x B2 B2_basis B2x.
        apply real_open_interval in B2_basis.
        destruct B2_basis as [a [b B2_eq]].
        subst B2.
        exists (closed_open_interval x b).
        split.
        2: split.
        +   exists x, b.
            reflexivity.
        +   split.
            *   apply refl.
            *   apply B2x.
        +   intros y [y_gt y_lt].
            split.
            *   exact (lt_le_trans (land B2x) y_gt).
            *   exact y_lt.
    -   intros contr.
        rewrite topology_basis_finer in contr.
        pose (B2 := closed_open_interval 0 1).
        assert (@top_basis real real_lower_limit_topology B2) as B2_basis.
        {
            exists 0, 1.
            reflexivity.
        }
        assert (B2 0) as B20.
        {
            split.
            -   apply refl.
            -   exact one_pos.
        }
        specialize (contr 0 B2 B2_basis B20) as [B1 [B1_basis [B10 B1_sub]]].
        apply real_open_interval in B1_basis.
        destruct B1_basis as [a [b B1_eq]]; subst B1.
        unfold B2 in *.
        clear B2 B2_basis B20.
        destruct B10 as [a_neg b_pos].
        assert (a/2 < 0) as a2_neg.
        {
            apply half_neg.
            exact a_neg.
        }
        assert (open_interval a b (a/2)) as a2_in.
        {
            split.
            -   apply lt_mult_rcancel_pos with 2; try exact two_pos.
                rewrite mult_rlinv by apply two_pos.
                rewrite ldist; rewrite mult_rid.
                rewrite <- (plus_rid a) at 3.
                apply lt_lplus.
                exact a_neg.
            -   exact (trans a2_neg b_pos).
        }
        apply B1_sub in a2_in.
        destruct a2_in as [a2_pos].
        destruct (lt_le_trans a2_neg a2_pos); contradiction.
Qed.

Theorem real_k_finer : topology_strictly_finer
    (@basis_topology _ real_k_topology)
    (@basis_topology _ real_order_topology).
Proof.
    apply topology_not_finer_strict.
    -   apply topology_basis_finer.
        intros x B2 B2_basis B2x.
        exists B2.
        split.
        2: split.
        +   apply real_open_interval in B2_basis.
            destruct B2_basis as [a [b B2_eq]]; subst B2.
            exists a, b.
            left.
            reflexivity.
        +   exact B2x.
        +   apply refl.
    -   intros contr.
        rewrite topology_basis_finer in contr.
        pose (B2 := (open_interval (-(1)) 1 - real_K)%set).
        assert (@top_basis real real_k_topology B2) as B2_basis.
        {
            unfold top_basis; cbn.
            exists (-(1)), 1.
            right.
            reflexivity.
        }
        assert (B2 0) as B20.
        {
            split.
            -   split.
                1: apply pos_neg2.
                all: exact one_pos.
            -   unfold real_K.
                rewrite not_ex.
                intros n.
                apply real_n_div_pos.
        }
        specialize (contr 0 B2 B2_basis B20) as [B1 [B1_basis [B1x B1_sub]]].
        apply real_open_interval in B1_basis.
        destruct B1_basis as [a [b B1_eq]]; subst B1.
        unfold B2 in B1_sub; clear B2 B2_basis B20.
        destruct B1x as [a_neg b_pos].
        pose proof (archimedean2 b b_pos) as [n n_ltq].
        assert (open_interval a b (/from_nat (nat_suc n))) as n_in.
        {
            split.
            -   apply (trans a_neg).
                apply real_n_div_pos.
            -   exact n_ltq.
        }
        apply B1_sub in n_in.
        destruct n_in as [n_in1 n_in2].
        apply n_in2.
        exists n.
        reflexivity.
Qed.

Theorem real_lower_limit_k_incomparable : ¬topology_comparable
    (@basis_topology _ real_lower_limit_topology)
    (@basis_topology _ real_k_topology).
Proof.
    intros [finer|finer].
    -   rewrite topology_basis_finer in finer.
        pose (B2 := (open_interval (-(1)) 1 - real_K)%set).
        assert (@top_basis real real_k_topology B2) as B2_basis.
        {
            unfold top_basis; cbn.
            exists (-(1)), 1.
            right.
            reflexivity.
        }
        assert (B2 0) as B20.
        {
            split.
            -   split.
                1: apply pos_neg2.
                all: exact one_pos.
            -   unfold real_K.
                rewrite not_ex.
                intros n.
                apply real_n_div_pos.
        }
        specialize (finer 0 B2 B2_basis B20) as [B1 [B1_basis [B1x B1_sub]]].
        destruct B1_basis as [a [b B1_eq]]; subst B1.
        unfold B2 in B1_sub; clear B2 B2_basis B20.
        destruct B1x as [a_neg b_pos].
        pose proof (archimedean2 b b_pos) as [n n_ltq].
        assert (closed_open_interval a b (/from_nat (nat_suc n))) as n_in.
        {
            split.
            -   apply (trans a_neg).
                apply real_n_div_pos.
            -   exact n_ltq.
        }
        apply B1_sub in n_in.
        destruct n_in as [n_in1 n_in2].
        apply n_in2.
        exists n.
        reflexivity.
    -   rewrite topology_basis_finer in finer.
        pose (B2 := closed_open_interval 0 1).
        assert (@top_basis real real_lower_limit_topology B2) as B2_basis.
        {
            exists 0, 1.
            reflexivity.
        }
        assert (B2 0) as B20.
        {
            split.
            -   apply refl.
            -   exact one_pos.
        }
        specialize (finer 0 B2 B2_basis B20) as [B1 [B1_basis [B10 B1_sub]]].
        destruct B1_basis as [a [b B1_eq]].
        assert (open_interval a b 0) as B10'.
        {
            destruct B1_eq; subst B1.
            -   exact B10.
            -   apply B10.
        }
        unfold B2 in *.
        clear B2 B2_basis B20 B10.
        destruct B10' as [a_neg b_pos].
        classic_case (real_K (a/2)) as [Ka|nKa].
        +   destruct Ka as [n n_eq].
            assert (0 < a) as a_pos.
            {
                apply lt_mult_rcancel_pos with (/2).
                1: apply div_pos; exact two_pos.
                rewrite mult_lanni.
                rewrite n_eq.
                apply real_n_div_pos.
            }
            destruct (trans a_neg a_pos); contradiction.
        +   assert (a/2 < 0) as a2_neg.
            {
                apply half_neg.
                exact a_neg.
            }
            assert (open_interval a b (a/2)) as a2_in'.
            {
                split.
                -   apply lt_mult_rcancel_pos with 2; try exact two_pos.
                    rewrite mult_rlinv by apply two_pos.
                    rewrite ldist; rewrite mult_rid.
                    rewrite <- (plus_rid a) at 3.
                    apply lt_lplus.
                    exact a_neg.
                -   exact (trans a2_neg b_pos).
            }
            assert (B1 (a/2)) as a2_in.
            {
                destruct B1_eq; subst B1.
                2: split.
                1, 2: exact a2_in'.
                exact nKa.
            }
            apply B1_sub in a2_in.
            destruct a2_in as [a2_pos].
            destruct (lt_le_trans a2_neg a2_pos); contradiction.
Qed.


(** 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) (y : natural) : natural :=
  plus Zero (mult y lf2).


(** 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 (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus x (plus lf1 y).


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

Require Import cl.

Set Implicit Arguments.

Section cl_equivalence.

  (* Now the definition of equivalence between the terms
     of combinatory algebras. It is the least equivalence
     relation (reflexive, symmetry and transitive) which
     is congruent with composition o and such that
       I o x ~~ x, K o x o y ~~ x and
       S o x o y o z ~~ x o z o (y o z)
  *)

  Reserved Notation "x '~cl' y" (at level 70).

  Inductive cl_eq : clterm -> clterm -> Prop :=

    | in_cl_eq_I : forall x,               I o x ~cl x

    | in_cl_eq_K : forall x y,         K o x o y ~cl x

    | in_cl_eq_S : forall x y z,   S o x o y o z ~cl x o z o (y o z)

    | in_cl_eq_0 : forall x,                   x ~cl x

    | in_cl_eq_1 : forall x y,                 x ~cl y
                              ->               y ~cl x

    | in_cl_eq_2 : forall x y z,               x ~cl y
                              ->               y ~cl z
                              ->               x ~cl z

    | in_cl_eq_3 : forall x y z,           x     ~cl y
                              ->           x o z ~cl y o z

    | in_cl_eq_4 : forall x y z,               y ~cl     z
                              ->           x o y ~cl x o z

  where "x ~cl y" := (cl_eq x y).

  (* Some exercices with cl_term equivalence *)

  Fact cl_eq_refl f g : f = g -> f ~cl g.
  Proof.
  Admitted.

  Definition cl_eq_sym := in_cl_eq_1.

  Definition cl_eq_trans := in_cl_eq_2.

  Fact cl_eq_app x y a b : x ~cl y -> a ~cl b -> x o a ~cl y o b.
  Proof.
  Admitted.

  Fact cl_I_prop x : I o x ~cl x.
  Proof.
    apply in_cl_eq_I.
  Qed.

  Fact cl_K_prop x y : K o x o y ~cl x.
  Proof.
    apply in_cl_eq_K.
  Qed.

  Fact cl_S_prop x y z : S o x o y o z ~cl x o z o (y o z).
  Proof.
    apply in_cl_eq_S.
  Qed.

  Fact cl_SKI_prop x : S o K o I o x ~cl x.
  Proof.
    apply cl_eq_trans with (1 := cl_S_prop _ _ _).
  Admitted.

  Corollary cl_SKI_I : forall x, S o K o I o x ~cl I o x.
  Proof.
  Admitted.

  Definition cl_D := S o I o I.

  Notation D := cl_D.

  Fact cl_D_prop x : D o x ~cl x o x.
  Proof.
  Admitted.

  Definition cl_B := S o (K o S) o K.

  Notation B := cl_B.

  Hint Resolve in_cl_eq_0.

  Fact cl_B_prop f g x : B o f o g o x ~cl f o (g o x).
  Proof.
    unfold cl_B.
    apply cl_eq_trans with (K  o S o f o (K o f) o g o x).
    do 2 (apply cl_eq_app; auto); apply cl_S_prop.
    apply cl_eq_trans with (S o (K o f) o g o x).
    do 3 (apply cl_eq_app; auto); apply cl_K_prop.
    apply cl_eq_trans with (1 := cl_S_prop _ _ _).
    apply cl_eq_app; auto.
    apply cl_K_prop.
  Qed.

  Definition cl_L := D o (B o D o D).

  Notation L := cl_L.

  Fact cl_L_prop : L ~cl L o L.
  Proof.
  Admitted.

End cl_equivalence.

Notation "x '~cl' y" := (cl_eq x y) (at level 70).


From mathcomp Require Import all_ssreflect.
Require Import vds_sort.
Require Import Coq.Sorting.Permutation.

Section Define.

  Inductive color : Type := Red | Black.

  Inductive tree : Type :=
  | E : tree
  | T : color -> tree -> nat -> tree -> tree.

  Definition empty := E.

  Fixpoint flatten t :=
    match t with
    | E => [::]
    | T _ l v r => flatten l ++ (v :: flatten r)
    end.

End Define.

Section Query.

  Fixpoint member (n : nat)  (t : tree) : bool :=
    match t with
    | E => false
    | T _ l v r => if n < v
                   then member n l
                   else if n == v then true
                        else member n r
    end.

  Lemma member_in t n : member n t -> n \in (flatten t).
  Proof.
    elim: t => [|c l IHl v r IHr] //=.
    case: ifP => Hlt.
    move => H. rewrite mem_cat IHl. by rewrite orTb. exact.
    case: ifP => Heq. move => H {H}.
    by rewrite mem_cat in_cons Heq //= orbT.
    move => H. rewrite mem_cat in_cons IHr. by rewrite orbA orbT. exact.
  Qed.

  Fixpoint height t : nat :=
    match t with
    | E => 0
    | T _ l _ r => 1 + max (height l) (height r)
    end.

  Fixpoint tree_size t : nat :=
    match t with
    | E => 0
    | T _ l _ r => 1 + tree_size l + tree_size r
    end.

  Lemma tree_sizeK t : tree_size t = size (flatten t).
  Proof.
    elim: t => [| c l IHl v r IHr] //=.
    rewrite size_cat //= IHl IHr. rewrite -[in RHS]addn1.
    by rewrite addnA -[in LHS]addnA [in LHS]addnC.
  Qed.

End Query.

(* tactic written by Jacques Garrigue *)
Ltac decompose_rewrite :=
  let H := fresh "H" in
  move/andP=>[] || (move=>H; try rewrite H; try rewrite (eqP H)).

Section Insert.

  Definition balanceL c l v r :=
    match c, l with
    | Black, T Red (T Red a x b) y c
    | Black, T Red a x (T Red b y c)
      => T Red (T Black a x b) y (T Black c v r)
    | _, _ => T c l v r
    end.

  Definition balanceR c l v r :=
    match c, r with
    | Black, T Red (T Red b y c) z d
    | Black, T Red b y (T Red c z d)
      => T Red (T Black l v b) y (T Black c z d)
    | _, _ => T c l v r
    end.

  Fixpoint ins x t :=
    match t with
    | E => T Red E x E
    | T c l v r as s =>
      if x < v
      then balanceL c (ins x l) v r
      else if x > v
           then balanceR c l v (ins x r)
           else s
    end.

  Definition insert x t :=
    match ins x t with
    | E => E (* impossible *)
    | T _ l v r => T Black l v r
    end.

  Fixpoint is_redblack (t : tree) ctxt bh :=
    match t with
    | E => bh == 0
    | T c l _ r =>
      match c, ctxt with
      | Red, Red => false (* red child can't have red parent *)
      | Red, Black => is_redblack l Red bh && is_redblack r Red bh
      | Black, _ => (bh > 0) && is_redblack l Black (bh.-1) && is_redblack r Black (bh.-1)
      end
    end.

  Definition nearly_redblack (t : tree) bh :=
    match t with
    | T Red l _ r => is_redblack l Black bh && is_redblack r Black bh
    | _ => is_redblack t Black bh
    end.

  Lemma is_redblack_red_black t n : is_redblack t Red n -> is_redblack t Black n.
  Proof.
    elim: t => [| c l IHl v r IHr] //=. case: c => //=.
  Qed.

  Lemma is_redblack_nearly_redblack c t n : is_redblack t c n ->
                                            nearly_redblack t n.
  Proof.
    case: c; elim: t => [| tc l IHl v r IHr] //=; case: tc => //=.
    move/andP => [Hl Hr]. by rewrite !is_redblack_red_black.
  Qed.

  Lemma balanceL_black_is_redblack l r v n :
    nearly_redblack l n -> is_redblack r Black n ->
    is_redblack (balanceL Black l v r) Black n.+1.
  Proof.
    case: l => [| [] [| [] lll llval llr] lval [| [] lrl lrval lrr]] //=;
    repeat decompose_rewrite => //=;
    try (by rewrite !is_redblack_red_black).
    move/eqP in H1. by rewrite -!H1 !is_redblack_red_black.
  Qed.

  Lemma balanceR_black_is_redblack l r v n :
    is_redblack l Black n -> nearly_redblack r n ->
    is_redblack (balanceR Black l v r) Black n.+1.
  Proof.
    case: r => [| [] [| [] rll rlval rlr] rval [| [] rrl rrval rrr]] //=;
    repeat decompose_rewrite => //=;
    try (by rewrite !is_redblack_red_black).
    move/eqP in H2. by rewrite -!H2 !is_redblack_red_black.
  Qed.

  Lemma ins_is_redblack (t : tree) x n :
    (is_redblack t Black n -> nearly_redblack (ins x t) n) /\
    (is_redblack t Red n -> is_redblack (ins x t) Black n).
  Proof.
    elim: t n => [| c l IHl v r IHr] n //.
    rewrite //=. split => -> //.
    have ins_black: (is_redblack (T Black l v r) Black n -> is_redblack (ins x (T Black l v r)) Black n).
    { rewrite {3}[Black]lock /= -lock => /andP [/andP [/prednK <- Hl] Hr].
      case: ifP => _.
      rewrite balanceL_black_is_redblack //; by apply IHl.
      case: ifP => _. rewrite balanceR_black_is_redblack //; by apply IHr.
      rewrite //=. rewrite succnK in Hl. rewrite succnK in Hr. by rewrite Hl Hr. }
    split; case: c => //.
    specialize IHl with n. specialize IHr with n.
    move: IHl => [IHl_b IHl_r]. move: IHr => [IHr_b IHr_r].
    move=> /= /andP [Hl Hr] //=.
    case: ifP => _ //=. rewrite IHl_r. by rewrite is_redblack_red_black. exact.
    case: ifP => _ //=. rewrite IHr_r. by rewrite is_redblack_red_black. exact.
    rewrite !is_redblack_red_black; exact.
    move/ins_black => H. by apply: (is_redblack_nearly_redblack Black).
  Qed.

  Lemma insert_is_redblack (t : tree) x n :
    is_redblack t Red n -> exists n', is_redblack (insert x t) Red n'.
  Proof.
    exists (if (ins x t) is T Red _ _ _ then n.+1 else n).
    move/(proj2 (ins_is_redblack t x n)): H.
    rewrite /insert => //=. destruct ins => //=.
    case: c => //= /andP [Hd1 Hd2].
    by rewrite !is_redblack_red_black.
  Qed.

End Insert.

Section BST.

  Definition is_bst t := sorted (flatten t).

  Lemma empty_is_bst : is_bst empty.
  Proof. exact. Qed.

  Fixpoint tree_all (pred : nat -> bool) t :=
    match t with
    | E => true
    | T _ l v r => pred v && tree_all pred l && tree_all pred r
    end.

  Lemma tree_allK pred t : tree_all pred t = all pred (flatten t).
  Proof.
    elim: t => [| c l IHl v r IHr] //=.
    by rewrite all_cat //= IHl IHr andbCA andbA.
  Qed.

  Fixpoint is_bst_rec (t : tree) :=
    match t with
    | E => true
    | T _ l v r => is_bst_rec l && is_bst_rec r && tree_all (leq^~ v) l &&
                   tree_all [eta leq v] r
    end.

  Lemma is_bst_is_bst_rec : is_bst =1 is_bst_rec.
  Proof.
    rewrite /eqfun. move => t. elim: t => [| c l IHl v r IHr] //=.
    rewrite -IHl -IHr /is_bst /= -sorted_cat_cons_e.
    rewrite -sorted_cons_e. rewrite !tree_allK. rewrite -!andbA.
    case: (all (leq^~ v) (flatten l)) => //=. by rewrite !andbF.
  Qed.

  Lemma balanceLK c l v r : flatten (balanceL c l v r) = flatten l ++ v :: flatten r.
  Proof.
    rewrite /balanceL; case c => //=;
    case: l => [| [] [| [] lll llval llr] lval [| [] lrl lrval lrr]] //=;
    try rewrite -!cat_cons; try rewrite !catA; try exact.
    by rewrite -!catA cat_cons.
  Qed.

  Lemma balanceRK c l v r : flatten (balanceR c l v r) = flatten l ++ v :: flatten r.
  Proof.
    rewrite /balanceR; case c => //=;
    case: r => [| [] [| [] rll rlval rlr] rval [| [] rrl rrval rrr]] //=;
    try rewrite -!cat_cons; try rewrite !catA; try exact.
    by rewrite -!catA cat_cons.
  Qed.

  Lemma insK x (t : tree) : is_bst t -> flatten (ins x t) = seq_insert x (flatten t).
  Proof.
    elim: t => [| c l IHl v r IHr] //=. move => H.
    case Hlt: (x < v). rewrite balanceLK insert_cat_cons_l. rewrite IHl //=.
    rewrite is_bst_is_bst_rec. rewrite is_bst_is_bst_rec /= -!andbA in H.
    by move/and4P: H => [-> _ _ _]. by rewrite /is_bst in H.
    by rewrite Hlt.
    rewrite ltnNge leq_eqVlt Hlt orbF. case Heq: (x == v) => //=.
    by rewrite (eqP Heq) insert_same.
    rewrite balanceRK insert_cat_cons_r. rewrite IHr //=.
    rewrite is_bst_is_bst_rec. rewrite is_bst_is_bst_rec /= -!andbA in H.
    by move/and4P: H => [_ -> _ _]. by rewrite /is_bst in H.
    by rewrite ltnNge leq_eqVlt Hlt Heq.
  Qed.

  Lemma insertK x (t : tree) : is_bst t -> flatten (insert x t) = seq_insert x (flatten t).
  Proof.
    move => H. rewrite /insert -insK. by case: ins. exact.
  Qed.

  Lemma insert_is_bst x t : is_bst t -> is_bst (insert x t).
  Proof.
    move => H. rewrite /is_bst. rewrite insertK. apply: sorted_insert.
    by rewrite /is_bst in H. exact.
  Qed.

  Lemma tree_all_geq_trans t x y : tree_all (geq^~ x) t -> y <= x -> tree_all (geq^~ y) t.
  Proof.
    elim: t => [| c l IHl v r IHr] //=. rewrite -andbA.
    move/and3P => [Hxv Hl Hr] Hyx. rewrite IHl; try (rewrite IHr); try exact.
    rewrite !andbT. apply: leq_trans. apply: Hyx. apply: Hxv.
  Qed.

  Lemma tree_all_leq_trans t x y : tree_all (leq^~ x) t -> x <= y -> tree_all (leq^~ y) t.
  Proof.
    elim: t => [| c l IHl v r IHr] //=. rewrite -andbA.
    move/and3P => [Hvx Hl Hr] Hxy. rewrite IHl; try (rewrite IHr); try exact.
    rewrite !andbT. apply: leq_trans. apply: Hvx. apply: Hxy.
  Qed.

  Lemma balanceL_is_bst c l r x : is_bst_rec l -> is_bst_rec r -> tree_all (leq^~ x) l -> tree_all (geq^~ x) r -> is_bst_rec (balanceL c l x r).
  Proof.
    rewrite /balanceL. case: c => //=; case: l => [| [] [| [] lll llval llr] lval [| [] lrl lrval lrr]] //=; repeat decompose_rewrite; try exact.
    by rewrite (@tree_all_geq_trans r x lrval).
    by rewrite (@tree_all_geq_trans r x lval).
    by rewrite (@tree_all_geq_trans r x lval).
    by rewrite (@tree_all_geq_trans r x lval).
    rewrite (@tree_all_leq_trans lll llval lrval).
    rewrite (@tree_all_leq_trans llr lval lrval) //=.
    rewrite (@tree_all_geq_trans r x lrval) //= !andbT.
    all: (try apply: leq_trans; try apply: H7; try apply: H10; try exact).
  Qed.

  Lemma balanceR_is_bst c l r x : is_bst_rec l -> is_bst_rec r -> tree_all (leq^~ x) l -> tree_all (geq^~ x) r -> is_bst_rec (balanceR c l x r).
  Proof.
    rewrite /balanceR. case: c => //=; case: r => [| [] [| [] rll rlval rlr] rval [| [] rrl rrval rrr]] //=; repeat decompose_rewrite; try exact.
    by rewrite (@tree_all_leq_trans l x rval).
    by rewrite (@tree_all_leq_trans l x rlval).
    rewrite (@tree_all_leq_trans l x rlval).
    rewrite (@tree_all_geq_trans rrl rval rlval).
    rewrite (@tree_all_geq_trans rrr rval rlval) //=. rewrite !andbT.
    apply: leq_trans. apply: H8. apply: H11. all: try exact.
    rewrite (@tree_all_leq_trans l x rlval).
    rewrite (@tree_all_geq_trans rrl rval rlval).
    rewrite (@tree_all_geq_trans rrr rval rlval) //= !andbT.
    apply: leq_trans. apply: H8. apply: H11. all: try exact.
    by rewrite (@tree_all_leq_trans l x rval).
  Qed.

  Lemma tree_all_balanceL pred c l r v : tree_all pred l && tree_all pred r &&
    pred v = tree_all pred (balanceL c l v r).
  Proof.
    rewrite /balanceL. case: c => //=; case: l => [| [] [| [] lll llval llr] lval [| [] lrl lrval lrr]] //=;
    repeat decompose_rewrite; try (rewrite !andbT); try (rewrite andbC);
    try (rewrite -!andbA); try exact;
    case: (pred v) => //=; try (by rewrite !andbF). by rewrite andbCA.
    case: (pred lval) => //=; case: (pred lrval) => //=; case: (pred llval) => //=.
    by rewrite !andbF.
  Qed.

  Lemma tree_all_balanceR pred c l r v : tree_all pred l && tree_all pred r &&
    pred v = tree_all pred (balanceR c l v r).
  Proof.
    rewrite /balanceR. case: c => //=; case: r => [| [] [| [] rll rlval rlr] rval [| [] rrl rrval rrr]] //=; repeat decompose_rewrite;
    try (rewrite !andbT); try (rewrite andbC);
    try (rewrite -!andbA); try exact; case: (pred v) => //=;
    try (case: (pred rval) => //=; case: (pred rlval) => //=);
    try (by rewrite !andbF).
    by rewrite andbCA.
  Qed.

  Lemma tree_all_ins pred t x : tree_all pred t && pred x = tree_all pred (ins x t).
  Proof.
    elim: t => [| c l IHl v r IHr] //=. by rewrite !andbT.
    case: ifP => H; try (case: ifP => H'); try (rewrite -tree_all_balanceL -IHl);
    try (rewrite -tree_all_balanceR -IHr);
    case pv: (pred v) => //=; case px: (pred x) => //=; try (by rewrite !andbT); try (by rewrite !andbF).
    by rewrite pv andbT.
    have He: (v == x). apply: negbNE. by rewrite neq_ltn H H'.
    by rewrite -(eqP He) pv in px.
    by rewrite pv. by rewrite pv.
  Qed.

  Lemma ins_is_bst (t : tree) x : is_bst_rec t -> is_bst_rec (ins x t).
  Proof.
    elim: t => [| c l IHl v r IHr] //=.
    rewrite -!andbA. move/and4P => [Hl Hr Hleq Hgeq].
    case: ifP => Hlt.
    apply: balanceL_is_bst; try exact. by apply: IHl.
    by rewrite -tree_all_ins Hleq //= leq_eqVlt Hlt orbT.
    case: ifP => Hlt'. apply: balanceR_is_bst; try exact. by apply: IHr.
    rewrite -tree_all_ins. rewrite ltnNge in Hlt. move/negbFE in Hlt.
    by rewrite /geq //= Hlt Hgeq.
    by rewrite //= Hl Hr Hleq Hgeq.
  Qed.

  Lemma insert_is_bst_rec (t : tree) x : is_bst_rec t -> is_bst_rec (insert x t).
  Proof.
    move/(ins_is_bst t x). rewrite /insert => //=.
    destruct ins => //=.
  Qed.

End BST.

Section Membership.

  Lemma all_gt_not_in x s : all [eta ltn x] s -> x \notin s.
  Proof.
    elim: s => [| h s IHs] //=. move/andP => [Hltn Hs].
    rewrite in_cons negb_or. rewrite IHs. by rewrite neq_ltn Hltn.
    exact.
  Qed.

  Lemma all_geq_gt_trans x y s : all [eta leq y] s -> x < y -> all [eta ltn x] s.
  Proof.
    elim: s => [| h s IHs] //=. move => /andP [Hyh Hy] Hxy.
    rewrite IHs. rewrite andbT. apply: leq_trans. apply: Hxy. apply: Hyh. exact.
    exact.
  Qed.

  Lemma all_lt_not_in x s : all (ltn^~ x) s -> x \notin s.
  Proof.
    elim: s => [| h s IHs] //=. move/andP => [Hltn Hs].
    rewrite in_cons negb_or. rewrite IHs. by rewrite neq_ltn Hltn orbT.
    exact.
  Qed.

  Lemma all_leq_lt_trans x y s : all (leq^~ x) s -> x < y -> all (ltn^~ y) s.
  Proof.
    elim: s => [| h s IHs] //=. move => /andP [Hyh Hy] Hxy.
    rewrite IHs. rewrite andbT. apply: leq_ltn_trans. apply: Hyh. apply: Hxy.
    exact. exact.
  Qed.

  Lemma memberK x t : (is_bst_rec t) -> member x t = (x \in (flatten t)).
  Proof.
    elim: t => [| c l IHl v r IHr] //=.
    rewrite -!andbA. move/and4P => [Hl Hr Hleq Hgeq].
    case: ifP => x_lt_v. rewrite mem_cat IHl.
    have not_r: member x r = false.
    { apply/negbTE. rewrite tree_allK in Hgeq. rewrite IHr.
      apply: all_gt_not_in. apply: all_geq_gt_trans. apply: Hgeq. exact.
      exact. }
    rewrite in_cons. rewrite -IHr. rewrite not_r orbF.
    have neq_xv: (x == v) = false. apply/negbTE. by rewrite neq_ltn x_lt_v.
    by rewrite neq_xv orbF. exact. exact.
    case: ifP => Heq_xv. by rewrite mem_cat in_cons Heq_xv orbC.
    rewrite mem_cat IHr.
    have not_l: member x l = false.
    { apply/negbTE. rewrite tree_allK in Hleq. rewrite IHl.
      apply: all_lt_not_in. apply: all_leq_lt_trans. apply: Hleq.
      rewrite ltn_neqAle. by rewrite eq_sym negbT //= leqNgt x_lt_v. exact. }
    rewrite in_cons. rewrite -IHl. by rewrite not_l //= Heq_xv.
    exact. exact.
  Qed.

End Membership.

Section TreeSort.

  Fixpoint build_tree s :=
    match s with
    | [::] => E
    | h :: t => insert h (build_tree t)
    end.

  Definition tree_sort s := flatten (build_tree s).

  Lemma bst_sorted (t : tree) : is_bst_rec t = sorted (flatten t).
  Proof. by rewrite -is_bst_is_bst_rec /is_bst. Qed.

  Lemma tree_sort_sorted s : sorted (tree_sort s).
  Proof.
    rewrite /tree_sort. rewrite -bst_sorted.
    elim: s => [| h s IHs] //=. by apply: insert_is_bst_rec.
  Qed.

End TreeSort.


(* Definition and basic facts about distributive lattices. *)
Structure Lattice :={
  lt_carrier :> Type;
  lt_and : lt_carrier -> lt_carrier -> lt_carrier;
  lt_or : lt_carrier -> lt_carrier -> lt_carrier;
  lt_zero : lt_carrier;
  lt_one : lt_carrier;
  lt_and_commute : forall x y, lt_and x y = lt_and y x;
  lt_or_commute : forall x y, lt_or x y = lt_or y x;
  lt_and_associate : forall x y z, lt_and x (lt_and y z) = lt_and (lt_and x y) z;
  lt_or_associate : forall x y z, lt_or x (lt_or y z) = lt_or (lt_or x y) z;
  lt_or_absorb : forall x y, lt_or x (lt_and x y) = x;
  lt_and_absorb : forall x y, lt_and x (lt_or x y) = x;
  lt_zero_identity_r : forall x, lt_or x lt_zero = x;
  lt_one_identity_r : forall x, lt_and x lt_one = x;
  lt_distribute_or : forall x y z, lt_or x (lt_and y z) = lt_and (lt_or x y) (lt_or x z);
  lt_distribute_and : forall x y z, lt_and x (lt_or y z) = lt_or (lt_and x y) (lt_and x z)
}.

Hint Resolve lt_and_commute : lt_hints.
Hint Resolve lt_or_commute : lt_hints.
Hint Resolve lt_and_associate : lt_hints.
Hint Resolve lt_or_associate : lt_hints.
Hint Resolve lt_or_absorb : lt_hints.
Hint Resolve lt_and_absorb : lt_hints.
Hint Resolve lt_zero_identity_r : lt_hints.
Hint Resolve lt_one_identity_r : lt_hints.
Hint Resolve lt_distribute_or : lt_hints.
Hint Resolve lt_distribute_and : lt_hints.

Notation "p && q" := (lt_and _ p q) (at level 40, left associativity).
Notation "p || q" := (lt_or _ p q) (at level 50, left associativity).
Notation "1" := (lt_one _).
Notation "0" := (lt_zero _).

Structure LatticeHom (A B : Lattice) :=
  {
    lt_hom :> A -> B ;
    lt_hom_and : forall x y , lt_hom (x && y) = lt_hom x && lt_hom y;
    lt_hom_or : forall x y , lt_hom (x || y) = lt_hom x || lt_hom y;
    lt_hom_zero : lt_hom 0 = 0;
    lt_hom_one : lt_hom 1 = 1
  }.

Definition lt_id {A : Lattice}: LatticeHom A A.
Proof.
  refine {| lt_hom := fun x => x |} ; reflexivity.
Defined.

Definition lt_comp {A B C:Lattice}: LatticeHom B C -> LatticeHom A B -> LatticeHom A C.
Proof.
  intros g f.
  refine {| lt_hom := fun x => g (f x) |}.
  - intros. rewrite lt_hom_and. rewrite lt_hom_and. reflexivity.
  - intros; repeat (rewrite lt_hom_or). reflexivity.
  - intros. repeat (rewrite lt_hom_zero). reflexivity.
  - intros. repeat (rewrite lt_hom_one). reflexivity.
Defined.

Notation "g 'o' f" := (lt_comp g f) (at level 65, left associativity).

Lemma lt_id_left (A B : Lattice) (f : LatticeHom A B) (x: A): (lt_id o f) x  = f x.
Proof.
  reflexivity.
Qed.

Lemma comp_assoc
      (A B C D : Lattice)
      (f : LatticeHom A B)
      (g : LatticeHom B C) (h : LatticeHom C D) (x : A) :
  (h o (g o f)) x = ((h o g) o f) x.
Proof.
  reflexivity.
Qed.


From mathcomp Require Import all_ssreflect.

Require Import Wf_nat Recdef.

Check lt_wf : well_founded lt.

(* 自己確認(ここから) *)
Check well_founded lt : Prop.
Print well_founded.
(*
well_founded =
  fun (A : Type) (R : A -> A -> Prop) =>
    forall a : A, Acc R a
  : forall A : Type, (A -> A -> Prop) -> Prop
*)
Print Acc.
(*
Inductive Acc (A : Type) (R : A -> A -> Prop) (x : A) : Prop :=
    Acc_intro : (forall y : A, R y x -> Acc R y) -> Acc R x
*)
Check lt : nat -> nat -> Prop.
(* 自己確認(ここまで) *)

Check lt_wf_ind :
        forall (n : nat) (P : nat -> Prop),
          (forall n0 : nat, (forall m : nat, (m < n0)%coq_nat -> P m) -> P n0) ->
          P n. (* 不等号の定義がスタンダードCoqとMathCompで違うということを覚えておく *)

Check leP. (* <= *)
Check ltP. (* < congr (_ + _). *)

Function gcd (m n : nat) {wf lt m} : nat :=
  if m is 0
  then n
  else gcd (modn n m) m.
Proof.
  - move=> m n m0 _. apply/ltP.
      by rewrite ltn_mod.
  - exact: lt_wf.
  Restart.
  (* 自己確認(ここから) *)
  - (* 本題の証明 *)
    move=> m n n0 Hm.
    Check ltP. (* : reflect (?m < ?n)%coq_nat (?m < ?n) *)
    apply/ltP.
    Check ltn_mod : forall m d : nat, (m %% d < d) = (0 < d).
    rewrite ltn_mod.
    Check ltn0Sn : forall n : nat, 0 < n.+1.
    by apply: ltn0Sn.
  - (* well_founded lt の証明 *)
    by apply: lt_wf.
  (* 自己確認(ここまで) *)
Qed.

Check gcd_equation :
  forall m n : nat,
    gcd m n = match m with
              | 0 => n
              | _.+1 => gcd (n %% m) m
              end.

Check gcd_ind :
        forall P : nat -> nat -> nat -> Prop,
          (forall m n : nat, m = 0 -> P 0 n n) ->
          (forall m n _x : nat,
             m = _x ->
             match _x with
             | 0    => False
             | _.+1 => True
             end ->
             P (n %% m) m (gcd (n %% m) m) ->
             P _x n (gcd (n %% m) m)) ->
          forall m n : nat, P m n (gcd m n).

Print gcd_terminate.
(*
  とても理解できる代物じゃない。
*)

Require Import Extraction.

Extraction gcd.                             (* wf が消える*)
(*
Fetching opaque proofs from disk for mathcomp.ssreflect.ssrnat
Fetching opaque proofs from disk for Coq.ssr.ssrbool
The extraction is currently set to bypass opacity, the following opaque constant bodies have
been accessed : eqnP iffP idP.
 [extraction-opaque-accessed,extraction]
(** val gcd : nat -> nat -> nat **)

let rec gcd m n =
  match m with
  | O -> n
  | S n0 -> gcd (modn n (S n0)) (S n0)
*)

Check divn_eq :
        forall m d : nat,
          m = m %/ d * d + m %% d.

Theorem gcd_divides m n :
  (gcd m n %| m) && (gcd m n %| n).
Proof.
  functional induction (gcd m n).
  - (* m = 0 の場合 *)
    by rewrite dvdn0 dvdnn.
  - (* m = _.+1 の場合 *)
    move: IHn0 => /andP [H1 H2].
    apply/andP; split.
    + (* gcd (n %% m) m %| m の証明 *)
      by apply: H2.
    + (* gcd (n %% m) m %| n の証明 *)
      Check divn_eq n m : n = n %/ m * m + n %% m.
      rewrite {2}(divn_eq n m).
      Check dvdn_add : forall d m n : nat, d %| m -> d %| n -> d %| m + n.
      apply: dvdn_add; last done.
      Check dvdn_mull : forall d m n : nat, d %| n -> d %| m * n.
      by apply: dvdn_mull.
Qed.

Check addKn :
        forall n : nat,
          cancel (addn n) (subn^~ n).

Check gcd_equation :
        forall m n : nat,
          gcd m n = match m with
                    | 0 => n
                    | _.+1 => gcd (n %% m) m
                    end.

Check muln_modl :
        forall p m d : nat,
          m %% d * p = (m * p) %% (d * p).

Lemma gcd_max_sub g k1 k2 :
  gcd (k1 * g) (k2 * g) = (gcd k1 k2) * g.
Proof.
  functional induction (gcd k1 k2).
  - (* k1 = 0 *)
    rewrite mul0n.
    rewrite gcd_equation.
    by [].
  - (* k1 = _.+1 *)
    rewrite -IHn.
    rewrite (@muln_modl g n m).
    rewrite gcd_equation.
    case: (m * g); last done.
    rewrite modn0.
    case: (n * g).
    + (* n * g = 0 *)
      rewrite gcd_equation.
      by [].
    + (* n * g = _.+1 *)
      move=> n'.
      rewrite gcd_equation.
      rewrite mod0n.
      rewrite gcd_equation.
      by [].
  Restart.
  functional induction (gcd k1 k2).
  - (* k1 = 0 *)
    by rewrite mul0n gcd_equation.
  - (* k1 = _.+1 *)
    rewrite -IHn (@muln_modl g n m) gcd_equation.
    case: (m * g); last done.
    rewrite modn0; case: (n * g) => [| n'].
    + (* n * g = 0 *)
      by rewrite gcd_equation.
    + (* n * g = _.+1 *)
      by rewrite gcd_equation mod0n gcd_equation.
  Restart.
  (* ProofCafe 須原様が示された証明 *)
  (* 古い MathComp では muln_modl に 0 < p の前提があるため、対応する。 *)
  case H : (0 < g).
  - functional induction (gcd k1 k2).
    + by rewrite mul0n gcd_equation.
    + rewrite -IHn (@muln_modl g n m) => //=.
      rewrite gcd_equation.
      case: (m * g); last done.
      rewrite modn0.
      case: (n * g) => [| n'].
      * by rewrite gcd_equation.
      * by rewrite gcd_equation mod0n gcd_equation.
  (* g = 0 の場合。新しい MathComp では不要である。 *)
  - move/negP/negP : H.
    rewrite -eqn0Ngt.
    move/eqP => ->.
    rewrite 3!muln0.
      by rewrite gcd_equation.
Qed.

Theorem gcd_max g m n :
  g %| m ->
  g %| n ->
  g %| gcd m n.
Proof.
  (*
    g %| m が成り立つなら、m = k1 * g が成り立つはず。
    g %| n が成り立つなら、n = k2 * g が成り立つはず。
    m = k1 * g, n = k2 * g が成り立つなら、
    gcd m n = gcd (k1 * g) (k2 * g) = (gcd k1 k2) * g が成り立つはず。
    そうしたら、g %| gcd m n が成り立つはず。
  *)
  rewrite dvdn_eq => /eqP <-.
  rewrite dvdn_eq => /eqP <-.
  rewrite gcd_max_sub.
  by apply: dvdn_mull.
Qed.

Lemma odd_square n :
  odd n = odd (n * n).
Proof.
  rewrite oddM.
  by case (odd n).
  Restart.
  (* ProofCafe 須原様が示された別解 *)
  rewrite odd_mul.
  apply/idP/idP. (* = (boolの必要十分ｎ条件) を -> と <- に分ける定石 by 須原様 *)
  - move=> H.
    apply/andP.
    by split.
  - case => /andP.
    by case.
Qed.

Lemma even_double_half n :
  ~~odd n ->
  n./2.*2 = n.
Proof.
  move=> Hnoddn.
  rewrite -[RHS]odd_double_half.
  rewrite -[LHS]add0n.
  apply/eqP.
  rewrite eqn_add2r.
  move: Hnoddn.
  rewrite -eqb0.
  move/eqP ->.
  by [].
  Restart.
  (* ProofCafe 須原様、盛田様の証明 *)
  move=> H.
  rewrite -[RHS]odd_double_half.
  move/negbTE in H.
  by rewrite H.
Qed.

(* 本定理*)

(*
まずは自然数で以下の定理を証明する．
定理1
  任意の自然数n とp について，
  n · n = 2(p · p) ならばp = 0

証明はn の関する整礎帰納法を使う．
 n = 0 のとき，p = 0
 n ̸= 0 のとき，
   n とp が偶数でなければならないので，n = 2n′, p = 2p′ とおける
   再び，n′ · n′ = 2(p′ · p′) が得られ，n′ < n
   帰納法の仮定よりp′ = 0
   すなわち，p = 0
*)

(*
Lemma main_thm_sub1 n :
  ~~ odd n -> exists k, n = k.*2.
Proof.
  move=> Hevn.
  exists (n./2).
  by rewrite (@even_double_half n); last done.
Qed.

Check even_double_half : forall n : nat, ~~ odd n -> (n./2).*2 = n.

Lemma main_thm_sub2 n :
  ~~ odd (n * n) = ~~ odd n.
Proof.
  by rewrite -odd_square.
Qed.

Check odd_square : forall n : nat, odd n = odd (n * n).
*)

Theorem main_thm (n p : nat) :
  n * n = (p * p).*2 ->
  p = 0.
Proof.
  elim/lt_wf_ind: n p => n.                 (* 整礎帰納法*)
  case: (posnP n) => [-> _ [] // | Hn IH p Hnp].
  (* 解答開始はここから *)
  move: (@odd_double (p * p)).
  rewrite -Hnp.
  move/negbT.
  rewrite -odd_square.
  move/even_double_half => Hnev. (* この時点で、(n./2).*2 = n を証明できた。 *)

  move: (Hnp).
  rewrite -Hnev.
  rewrite -{2}muln2 mulnA -[RHS]muln2.
  rewrite [(n./2).*2 * n./2]mulnC -[(n./2).*2]muln2 mulnA [n./2 * n./2 * 2]muln2.
  move/eqP.
  rewrite eqn_mul2r => /orP [H2eq0 | Hpn] //.
  move: Hpn => /eqP Hpn.
  move: (@odd_double (n./2 * n./2)).
  rewrite Hpn.
  move/negbT.
  rewrite -odd_square.
  move/even_double_half => Hpev. (* この時点で、(p./2).*2 = p を証明できた。 *)

  have H : n./2 * n./2 = (p./2 * p./2).*2.
    move: (Hpn).
    rewrite -Hpev.
    rewrite -[in RHS]muln2 [RHS]mulnA [p./2 * 2 * p./2]mulnC [p./2 * (p./2 * 2)]mulnA.
    rewrite [p./2 * p./2 * 2]muln2 -[LHS]muln2.
    move/eqP.
    rewrite eqn_mul2r => /orP [H2e0 | Hhnhp] //.
    move: Hhnhp => /eqP Hhnhp.
    rewrite Hhnhp Hpev.
    by []. (* この時点で、n./2 * n./2 = (p./2 * p./2).*2 を証明できた。 *)

  rewrite -Hpev -muln2 -[RHS](mul0n 2).
  apply/eqP.
  rewrite eqn_mul2r.
  apply/orP.
  right. (* この時点で、ゴールを p./2 == 0 に書き換えることができた。 *)

  Check (IH n./2) :
          (n./2 < n)%coq_nat ->
          forall p : nat,
            n./2 * n./2 = (p * p).*2 ->
            p = 0.

  apply/eqP/(IH n./2); last done.
  (* この時点で、ゴールを (n./2 < n)%coq_nat に書き換えることができた。 *)

  rewrite -divn2.

  Check ltP. (* : reflect (?m < ?n)%coq_nat (?m < ?n) *)
  Check ltn_Pdiv :
          forall m d : nat,
            1 < d ->
            0 < m ->
            m %/ d < m.
  Check (@ltn_Pdiv n 2) :
          1 < 2 ->
          0 < n ->
          n %/ 2 < n.

  by apply/ltP/(@ltn_Pdiv n 2).
Qed.

Lemma main_thm'_lm1 (n p : nat) :
  n * n = (p * p).*2 ->
  (n./2).*2 = n.
Proof.
  move=> Hnp.
  move: (@odd_double (p * p)).
  rewrite -Hnp => /negbT.
  by rewrite -odd_square => /even_double_half.
Qed.
(*
pが2で割り切れるか割り切れないかの場合分けが必要なはず。
どこで行っているか？
*)
Lemma main_thm'_lm2 (n p : nat) :
  n * n = (p * p).*2 ->
  p * p = (n./2 * n./2).*2.
Proof.
  move=> Hnp.
  move: (Hnp) => /main_thm'_lm1 => Hnev.
  move: (Hnp).
  rewrite -Hnev -{2}muln2 mulnA -[RHS]muln2
          [(n./2).*2 * n./2]mulnC -[(n./2).*2]muln2 mulnA
          [n./2 * n./2 * 2]muln2 => /eqP.
  rewrite eqn_mul2r => /orP [H2eq0 | Hpn] //.
  rewrite muln2 Hnev.
  by move: Hpn => /eqP.
Qed.

Theorem main_thm' (n p : nat) :
  n * n = (p * p).*2 ->
  p = 0.
Proof.
  elim/lt_wf_ind: n p => n.                 (* 整礎帰納法*)
  case: (posnP n) => [-> _ [] // | Hn IH p Hnp].
  (* 解答開始はここから *)

  (* n * n = (p * p).*2 から p * p = (n./2 * n./2).*2 を導く。 *)
  move: (@main_thm'_lm2 n p Hnp) => Hpn.

  (* p * p = (n./2 * n./2).*2 から (p./2).*2 = p を導き、
     ゴールを (p./2).*2 = 0 に書き換える。 *)
  move: (@main_thm'_lm1 p n./2 Hpn) => <-.

  (* ゴールを p./2 == 0 に書き換える。 *)
  rewrite -muln2 -[RHS](mul0n 2).
  apply/eqP; rewrite eqn_mul2r; apply/orP; right.

  (* (IH n./2) を apply することで必要になる
     命題 n./2 * n./2 = (p./2 * p./2).*2 を証明する。 *)
  move: (@main_thm'_lm2 p n./2 Hpn) => H.

  (* (IH n./2) を apply して、ゴールを (n./2 < n)%coq_nat に書き換える。 *)
  apply/eqP/(IH n./2); last done.
  apply/ltP.
  (*
    ( )%coq_natのスコープをなくしてMathCompに統一するために、
    なるべく早くapply/ltPを実行するべき。 by 須原様
  *)

  (* (@ltn_Pdiv n 2) を apply して、証明を完了する。 *)
  rewrite -divn2.
  by apply(*/ltP*)/(@ltn_Pdiv n 2).
Qed.

(* 無理数*)
Require Import Reals Field.      (* 実数とそのためのfield タクティク*)

(*
定理 main_thm : n * n = (p * p).*2 -> p = 0 を使って、
√2 が無理数であることを証明する。
もしも √2 が有理数なら、ある n と p が存在し、√2 = n/p、すなわち n ^ 2 = 2 * p ^ 2 となる。
しかし上の定理から p = 0 となるので矛盾。
*)

Check INR : nat -> R.

Definition irrational (x : R) : Prop :=  (* x が有理数でないという主張の定義らしい。 *)
  forall (p q : nat),
    q <> 0 ->
    x <> (INR p / INR q)%R.

Theorem irrational_sqrt_2:
  irrational (sqrt (INR 2)).
Proof.
  rewrite /irrational /not. (* わかりやすくするために定義を展開。 *)
  move=> p q Hq Hrt. (* これにより、ゴールが False となる。 *)
  apply: (Hq). (* これにより、ゴールが q = 0 となる。 *)

  Check (main_thm p) :
          forall p0 : nat,
            p * p = (p0 * p0).*2 ->
            p0 = 0.

  apply: (main_thm p). (* これにより、ゴールが p * p = (q * q).*2 となる。 *)

  Check INR_eq :
          forall n m : nat,
            INR n = INR m ->
            n = m.

  apply: INR_eq. (* これにより、ゴールが INR (p * p) = INR (q * q).*2 となる。 *)
  rewrite -mul2n. (* これにより、ゴールが INR (p * p) = INR (2 * (q * q)) となる。 *)

  Check mult_INR :
          forall n m : nat,
            INR (n * m)%coq_nat = (INR n * INR m)%R.

  rewrite !mult_INR.
    (* これにより、ゴールが (INR p * INR p)%R = (INR 2 * (INR q * INR q))%R となる。 *)

  Check sqrt_def (INR 2) :
          (0 <= INR 2)%R ->
          (sqrt (INR 2) * sqrt (INR 2))%R = INR 2.

  rewrite -(sqrt_def (INR 2)).
  - (* 本題の証明 *)
    rewrite Hrt.
    field.
    (*
      ここで、ゴールが INR q <> 0%R に変わるのは、分母が0でないことが新たなゴールとなるため。
      「分母が0でないなら、体の要素として等しい」という形の補題を適用することになるため、
      分母が0でないことが新たなゴールとなるとのこと。by 盛田様
    *)
    (*
      環は、乗算について逆元の存在を要求していないので、除算ができない。
      体は、0以外は乗算について逆元の存在を要求するので、除算ができる。
      とのこと。
    *)
    have : INR q <> 0%R.
      by auto with real.
    by apply.
  - (* (0 <= INR 2)%R の証明 *)
    auto with real.
  Restart.
  move=> p q Hq Hrt.
  apply /Hq /(main_thm p) /INR_eq.
  rewrite -mul2n !mult_INR -(sqrt_def (INR 2)) ?{}Hrt; last by auto with real.
  have Hqr : INR q <> 0%R by auto with real.
    by field.
Qed.


(** 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 (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus y (plus Zero x).


From mathcomp
     Require Import ssreflect.
Section ModusPonens.
  Variables X Y : Prop.
  Hypothesis XtoY_is_true : X -> Y.
  Hypothesis X_is_true : X.

  Theorem MP : Y.
  Proof.
    move: X_is_true.
      by [].
  Qed.
End ModusPonens.

Section HilbertSAxiom.
  Variables A B C : Prop.
  Theorem HS1 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
  Proof.
    move => AtoBtoC_is_true.
    move => AtoB_is_true.
    move => A_is_true.

    apply: (MP B C).

    apply: (MP A (B -> C)).
      by [].
        by [].

        apply: (MP A B).
          by [].
            by [].
  Qed.

  Theorem HS2 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
  Proof.
    move => AtoBtoC_is_true AtoB_is_true A_is_true.
      by apply: (MP B C); [apply: (MP A (B -> C)) | apply: (MP A B)].
  Qed.

  Theorem HS3 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
  Proof.
    move => AtoBtoC_is_true AtoB_is_true A_is_true.
      by move: A_is_true (AtoB_is_true A_is_true).
  Qed.

End HilbertSAxiom.


(**
  Various auxiliary things
*)

Require Import Nat Bool Arith Omega.
Require Import Coq.Structures.Equalities.
Require Import Coq.Arith.Wf_nat.

(** * Insert and Remove
  To describe some operations we need we have to define what is to "insert" or to
  "remove" an element at nth position to or from the list.
  The existing Coq functions use Option A as a return type, but we want to keep
  things as simple as possible. So our functions "work" even when incorrect values
  are passed in.
*)

Require Import List.
Import ListNotations.
Module NthInserterRemover (Import T : Typ).

Definition A := T.t.

(**
  It works as we want when n < length l
  See lemmas below
*)

Fixpoint nth_remove n l : list A :=
  match n, l with
  | _, [] => []
  | 0, h::t => t
  | S n', h::t => h :: nth_remove n' t
  end.

Lemma nth_remove_length: forall n (l: list A),
  n < length l ->
  length (nth_remove n l) = (length l) - 1.
Proof.
  intros. generalize dependent n.
  induction l; intros; simpl in *; destruct n; intuition.
  assert (e: n < length l) by omega. apply IHl in e. simpl. rewrite e.
  omega.
Qed.

Lemma nth_remove_representation: forall n (l: list A),
  n < length l ->
  exists x lh lt, Some x = nth_error l n /\
    l = lh ++ x::lt /\ nth_remove n l = lh ++ lt
    /\ length lh = n /\ length lt = (length l) - n - 1.
Proof.
  intros.
  generalize dependent n; induction l; intros; simpl in *.
  - easy.
  - destruct n; simpl in *. exists a, [], l; intuition.
    assert (e: n < length l) by omega; apply IHl in e; destruct e as [q0 [q1 [q3 ]]].
    intuition. exists q0, (a::q1), q3. rewrite H1, H2, H0. rewrite <- H3.
    ssimpl_list. intuition.
Qed.

Lemma nth_remove_overflow: forall n l,
  n >= length l <->
  nth_remove n l = l.
Proof.
  induction n; destruct l; intros; simpl in *; intuition.
  - easy.
  - apply f_equal with (B := nat) (f:=@length A) in H. simpl in H.
    intuition.
  - assert (e: n >= length l) by omega; apply (IHn _) in e; rewrite e.
    auto.
  - inversion H as [H']; rewrite H'; apply IHn in H'. omega.
Qed.

(**
  It works as we want when n <= length l
  See lemmas below
*)

Fixpoint nth_insert n l x : list A :=
  match n, l with
  | 0, _ => x::l
  | _, [] => []
  | S n', h::t => h::(nth_insert n' t x)
  end.

Lemma nth_insert_length: forall n l x,
  n <= length l ->
  length (nth_insert n l x) = S (length l).
Proof.
  intros.
  generalize dependent n; induction l; intros; simpl in *.
  - inversion H. intuition.
  - destruct n; auto.
    simpl.
    assert (e: n <= length l) by omega; apply IHl in e; rewrite e.
    reflexivity.
Qed.

Lemma nth_insert_representation: forall n (l: list A) x,
  n <= length l ->
  Some x = nth_error (nth_insert n l x) n /\
  exists lh lt, nth_insert n l x = lh ++ x::lt /\ l = lh ++ lt
    /\ length lh = n /\ length lt = (length l) - n.
Proof.
  intros.
  generalize dependent n; induction l; intros; simpl in *.
  - inversion H. simpl. split; [auto | exists [], []]. intuition.
  - destruct n; simpl in *. split; [auto | exists [], (a::l)]; intuition.
    assert (e: n <= length l) by omega; apply IHl in e; destruct e as [q0 [q1 [q3 ]]].
    intuition. exists (a::q1), q3; simpl. rewrite H1, H4, H0. auto.
Qed.

Lemma nth_insert_overflow: forall n l x,
  n > length l <->
  nth_insert n l x = l.
Proof.
  induction n; destruct l; intros; simpl in *; intuition; try easy.
  - apply f_equal with (B := nat) (f:=@length A) in H. simpl in H.
    intuition.
  - assert (e: n > length l) by omega; apply (IHn _ x) in e; rewrite e.
    auto.
  - inversion H as [H']; rewrite H'; apply IHn in H'. omega.
Qed.

Lemma nth_insert_app: forall l1 l2 x,
  nth_insert (length l1) (l1 ++ l2) x = l1 ++ x::l2.
Proof.
  intros. induction l1; auto.
  simpl; rewrite IHl1; auto.
Qed.

(**
  A link between nth_insert and nth_remove functions
*)

Lemma nth_insert_remove: forall n l x,
  n < length l ->
  Some x = nth_error l n ->
  (nth_insert n (nth_remove n l) x) = l.
Proof.
  intros.
  remember H as H' eqn: Heq; clear Heq.
  assert (n <= length (nth_remove n l)).
    apply nth_remove_length in H; rewrite H; omega.
  apply nth_insert_representation with (x:=x) in H1. firstorder.
  apply nth_remove_representation in H. firstorder.
  rewrite H3 in H7. rewrite <- H0 in H. inversion H. rewrite H2, H6. subst.
  apply f_equal with (f := fun l => (nth_insert (length x0) l x)) in H7.
  rewrite <- H8 in H7 at 2.
  repeat rewrite nth_insert_app in H7.
  auto.
Qed.

End NthInserterRemover.


(** 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) : natural :=
  plus (Succ lf2) lf3.


(** 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 (z : natural) (y : natural) (x : natural) : natural :=
  mult z (mult x y).


(** * Suprema and infima

Authors:
    - Jim Portegies

This file is part of Waterproof-lib.

Waterproof-lib is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Waterproof-lib is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

Require Import Reals.
(*
Require Import Classical.
Require Import Classical_Prop.
Require Import Classical_Pred_Type.
*)

Require Import Waterproof.AllTactics.
Require Import Waterproof.notations.notations.
Require Import Waterproof.load.
Import databases_RealsAndIntegers.

Require Import Waterproof.set_search_depth.To_5.
(* Require Import Waterproof.load_database.Intuition. *)
Require Import Coq.Logic.Classical.

Declare Scope sup_and_inf_scope.

Definition is_in {D : Set} := fun (A : (D → Prop)) ↦ (fun (x : D) ↦ A x).
Notation "x ∈ A" := (@is_in _ A x) (at level 50) : sup_and_inf_scope.
(** ## Suprema and infima*)
Notation is_sup := is_lub.
Notation is_bdd_above := bound.

Open Scope R_scope.
Open Scope sup_and_inf_scope.

(** ## Upper bounds

A number $M : ℝ$ is called an **upper bound** of a subset $A : ℝ \to \mathsf{Prop}$ of the real numbers, if for all $a : ℝ$, if $a ∈ A$ then $a ≤ M$.

```
Definition is_upper_bound (A : ℝ → Prop) (M : ℝ) :=
  ∀ a : A, a ∈ A ⇒ a ≤ M.
```

We say that a subset $A : ℝ \to \mathsf{Prop}$ is bounded above if there exists an $M : ℝ$ such that $M$ is an upper bound of $A$.

```
Definition is_bounded_above (A : ℝ → Prop) :=
  ∃ M : ℝ, is_upper_bound A M.
```

## The supremum

A real number $L : ℝ$ is called the **supremum** of a subset $A : ℝ \to \mathsf{Prop}$ if it is the smallest upper bound.
```
Definition is_sup (A : ℝ → Prop) (L : ℝ) :=
  (is_upper_bound A L) ∧ (∀ M : ℝ, is_upper_bound A M ⇒ (L ≤ M) ).
```

## The completeness axiom

The completeness axiom of the real numbers says that when a subset $A$ of the real numbers is bounded from above, and when there exists an element in the set, then there exists an $L$ such that $L$ is the supremum of $A$.

```
Axiom completeness : ∀ A : ℝ → Prop,
      is_bounded_above A ⇒
        ((∃ x : ℝ, x ∈ A) ⇒ { M : ℝ | is_sup A M }).
```*)
(** ## Lower bounds

A number $m : ℝ$ is called a lower bound of a subset $A : ℝ → \mathsf{Prop}$, if for all $a : \mathbb{R}$, if $a \in A$ then $a ≥ m$.*)
Definition is_lower_bound (A : ℝ → Prop) (m : ℝ) :=
  ∀ a : ℝ, a ∈ A ⇒ m ≤ a.
(** We say that a subset $A : ℝ → \mathsf{Prop}$ is bounded below if there exists an $m : ℝ$ such that $m$ is a lower bound of $A$.*)
Definition is_bdd_below (A : ℝ → Prop) :=
  ∃ m : ℝ, is_lower_bound A m.
(** ## The infimum

A real number $m : ℝ$ is called the **infimum** of a subset $A : ℝ → \mathsf{Prop}$ if it is the largest lower bound.*)
Definition is_inf :=
  fun (A : ℝ → Prop) m
    ↦ (is_lower_bound A m) ∧ (∀ l : ℝ, is_lower_bound A l ⇒ l ≤ m).
(** ## Reflection of a subset of ℝ in the origin

Before we continue showing properties of the infimum, we first introduce the reflection of subsets of $\mathbb{R}$ in the origin. Given a subset $A : ℝ → \mathsf{Prop}$, we consider the set $-A$ (which we write as $\mathsf{set\_opp} A$), defined by*)
Definition set_opp (A : ℝ → Prop)  :=
  fun (x : ℝ) ↦ (A (-x)).

Lemma upp_bd_set_to_low_bd_set_opp :
  ∀ (A : ℝ → Prop) (M : ℝ),
    is_upper_bound A M ⇒
      is_lower_bound (set_opp A) (-M).
Proof.
    Take A : (ℝ → Prop).
    Take M : ℝ.
    Assume that (is_upper_bound A M) (i).
    Expand the definition of is_lower_bound.
    That is, write the goal as (for all a : ℝ, a ∈ set_opp A ⇨ -M ≤ a).
    We need to show that (∀ a : ℝ, (-a ∈ A) ⇒ -M ≤ a).
    Take a : ℝ.
    Assume that (-a ∈ A).
    By (i) it holds that (-a ≤ M).
    It follows that (-M ≤ a).
Qed.

Lemma low_bd_set_to_upp_bd_set_opp :
  ∀ (A : ℝ → Prop) (m : ℝ),
    is_lower_bound A m ⇒
      is_upper_bound (set_opp A) (-m).
Proof.
    Take A : (ℝ → Prop).
    Take m : ℝ.
    Assume that (is_lower_bound A m) (i).
    Expand the definition of is_upper_bound.
    That is, write the goal as (for all x : ℝ, set_opp A x ⇨ x ≤ -m).
    We need to show that (∀ a : ℝ, (-a ∈ A) ⇒ a ≤ -m).
    Take a : ℝ.
    Assume that (-a ∈ A).
    By (i) it holds that (m ≤ -a).
    It follows that (a ≤ -m).
Qed.

Lemma low_bd_set_opp_to_upp_bd_set :
  ∀ (A : ℝ → Prop) (m : ℝ),
    is_lower_bound (set_opp A) m ⇒
      is_upper_bound A (-m).
Proof.
    Take A : (ℝ → Prop).
    Take m : ℝ.
    Assume that (is_lower_bound (set_opp A) m).
    Expand the definition of is_upper_bound.
    That is, write the goal as (for all x : ℝ, A x ⇨ x ≤ - m).
    Take a : ℝ.
    Assume that (a ∈ A) (i).
    It holds that (for all x : R, (-x) ∈ A -> m <= x).
    We claim that (--a ∈ A).
    { It holds that (--a = a) (ii).
      (* TODO: We conclude that (--a ∈ A). should work *)
      exact (eq_ind_r(_,_,(fun x => x ∈ A),(i),_,(ii))).
    }
    It holds that (m ≤ -a).
    It follows that (a ≤ -m).
Qed.

Lemma upp_bd_set_opp_to_low_bd_set :
  ∀ (A : ℝ → Prop) (M : ℝ),
    is_upper_bound (set_opp A) M ⇒
      is_lower_bound A (-M).
Proof.
    Take A : (ℝ → Prop).
    Take M : ℝ.
    Assume that (is_upper_bound (set_opp A) M).
    Expand the definition of is_lower_bound.
    That is, write the goal as (for all a : ℝ, a ∈ A ⇨ - M ≤ a).
    Take a : ℝ.
    Assume that (a ∈ A) (i).
    We claim that (--a ∈ A).
    { It holds that (--a = a) (ii).
      (* TODO: We conclude that (--a ∈ A). should work *)
      exact (eq_ind_r(_,_,(fun x => x ∈ A),(i),_,(ii))).
    }
    It holds that (-a ≤ M).
    It follows that (-M ≤ a).
Qed.

Lemma bdd_below_to_bdd_above_set_opp :
  ∀ (A : ℝ → Prop),
    is_bdd_below A ⇒ is_bdd_above (set_opp A).
Proof.
    Take A : (ℝ → Prop).
    Assume that (is_bdd_below A) (i).
    We need to show that (∃ M : ℝ, is_upper_bound (set_opp A) M).
    Expand the definition of is_bdd_below in (i).
    That is, write (i) as (∃ m : ℝ, is_lower_bound A m).
    Obtain m according to (i), so for m : R it holds that (is_lower_bound A m).
    Choose M := (-m).
    We need to show that (is_upper_bound (set_opp A) M).
    By low_bd_set_to_upp_bd_set_opp we conclude that (is_upper_bound (set_opp A) M).
Qed.

Lemma sup_set_opp_is_inf_set :
  ∀ (A : ℝ → Prop) (M : ℝ),
    is_sup (set_opp A) M ⇒ is_inf A (-M).
Proof.
    Take A : (ℝ → Prop).
    Take M : ℝ.
    Assume that (is_sup (set_opp A) M) (i).
    Expand the definition of is_inf.
    That is, write the goal as (is_lower_bound A (- M)
      ∧ (for all l : ℝ, is_lower_bound A l ⇨ l ≤ - M)).
    We show both statements.
    - We need to show that ( is_lower_bound A (- M) ).
      Expand the definition of is_lub in (i).
      That is, write (i) as (is_upper_bound (set_opp A) M
        ∧ (for all b : ℝ, is_upper_bound (set_opp A) b ⇨ M ≤ b)).
      Because (i) both (is_upper_bound (set_opp A) M) and
        (for all b : ℝ, is_upper_bound (set_opp A) b ⇨ M ≤ b) hold.
      By upp_bd_set_opp_to_low_bd_set we conclude that (is_lower_bound A (-M)).
    - We need to show that (∀ l : ℝ, is_lower_bound A l ⇒ l ≤ -M).
      Expand the definition of is_lower_bound.
      That is, write the goal as (for all l : ℝ, (for all a : ℝ, a ∈ A ⇨ l ≤ a) ⇨ l ≤ - M).
      Take l : ℝ.
      Assume that (is_lower_bound A l).
      Expand the definition of is_lub in (i).
      That is, write (i) as (is_upper_bound (set_opp A) M
        ∧ (for all b : ℝ, is_upper_bound (set_opp A) b ⇨ M ≤ b)).
      Because (i) both (is_upper_bound (set_opp A) M)
        and (for all b : ℝ, is_upper_bound (set_opp A) b ⇨ M ≤ b) (ii) hold.
      By low_bd_set_to_upp_bd_set_opp it holds that (is_upper_bound (set_opp A) (-l)).
      By (ii) it holds that (M ≤ -l).
      We conclude that (l <= -M).
Qed.

Lemma exists_inf :
  ∀ A : (ℝ →  Prop), is_bdd_below A ⇒
    ((∃ x : ℝ, x ∈ A) ⇒ { m | is_inf A m }).
Proof.
    Take A : (ℝ → Prop).
    Assume that (is_bdd_below A).
    Assume that (∃ x : ℝ, x ∈ A) (i).
    Define B := (set_opp A).
    We claim that (for all s : ℝ, (A s) -> (B (-s))) (ii).
    { Take s : ℝ.
      Assume that (A s).
      (* TODO: make nicer *)
      We need to show that (A (--s)).
      It holds that (A (--s) = A s) (iii).
      Fail We conclude that (A (--s)).
      rewrite iii.
      We conclude that (A s).
    }
    By bdd_below_to_bdd_above_set_opp it holds that (is_bdd_above B).
    We claim that (∃ y : ℝ, y ∈ B).
    { Obtain x according to (i), so for x : R it holds that (A x).
      Choose y := (-x).
      We need to show that (B (-x)).
      By (ii) we conclude that (B (-x)).
    }
    By completeness it holds that ({L | is_sup B L}) (iv).
    Obtain L according to (iv), so for L : R it holds that (is_sup B L).
    By sup_set_opp_is_inf_set it holds that (is_inf A (-L)).
    We conclude that ({m | is_inf A m}). (*TODO: make solvable with 'Choose ...'.*)
Qed.

(** ### A supremum is an upper bound

If $M$ is the supremum of a set $A$, it is also an upper bound.*)
Lemma sup_is_upp_bd :
  ∀ A : ℝ → Prop,
    ∀ M : ℝ,
      is_sup A M ⇒ is_upper_bound A M.
Proof.
    Take A : (ℝ → Prop) and M : ℝ.
    Assume that (is_sup A M).
    It holds that (is_upper_bound A M ∧ (∀ L : ℝ, is_upper_bound A L ⇒ M ≤ L)) (i).
    Because (i) both (is_upper_bound A M) and
      (∀ L : ℝ, is_upper_bound A L ⇒ M ≤ L) hold.
    It follows that (is_upper_bound A M).
Qed.

(** ### Any upper bound is greater than or equal to the supremum*)
Lemma any_upp_bd_ge_sup :
  ∀ A : ℝ → Prop,
    ∀ M L : ℝ,
      is_sup A M ⇒ (is_upper_bound A L ⇒ M ≤ L).
Proof.
    Take A : (ℝ → Prop) and M, l : ℝ.
    Assume that (is_sup A M) and (is_upper_bound A l).
    It holds that (is_upper_bound A M ∧ (∀ L : ℝ, is_upper_bound A L ⇒ M ≤ L)) (i).
    Because (i) both (is_upper_bound A M) and
      (∀ L : ℝ, is_upper_bound A L ⇒ M ≤ L) hold.
    (** We need to show that $M \leq L$.*)
    We conclude that (M <= l).
Qed.

(** ## Infima*)
(** ## An infimum is a lower bound*)
Lemma inf_is_low_bd :
  ∀ A : ℝ → Prop,
    ∀ m : ℝ,
      is_inf A m ⇒ is_lower_bound A m.
Proof.
    Take A : (ℝ → Prop) and m : R.
    Assume that (is_inf A m).
    It holds that (is_lower_bound A m ∧ (∀ l : ℝ, is_lower_bound A l ⇒ l ≤ m)) (i).
    Because (i) both (is_lower_bound A m) and
      (∀ l : ℝ, is_lower_bound A l ⇒ l ≤ m).
    We conclude that (is_lower_bound A m).
Qed.

(** ## Any lower bound is less than or equal to the infimum*)
Lemma any_low_bd_ge_inf :
  ∀ A : ℝ → Prop,
    ∀ m l : ℝ,
      is_inf A m ⇒ is_lower_bound A l ⇒ l ≤ m.
Proof.
    Take A : (R → Prop) and m, l : R.
    Assume that (is_inf A m) and (is_lower_bound A l).
    It holds that (is_lower_bound A m ∧ (∀ l : ℝ, is_lower_bound A l ⇒ l ≤ m)) (i).
    Because (i) both (is_lower_bound A m) and (∀ l : ℝ, is_lower_bound A l ⇒ l ≤ m) (ii) hold.
    By (ii) we conclude that (l ≤ m).
Qed.

(** ### $\varepsilon$-characterizations*)
Lemma exists_almost_maximizer :
  ∀ (A : ℝ -> Prop) (M : ℝ),
    is_sup A M ⇒
      ∀ (L : ℝ), L < M ⇒
        ∃ a : ℝ, A a ∧ L < a.
Proof.
    Take A : (ℝ -> Prop) and M : ℝ.
    Assume that (is_sup A M).
    Take L : ℝ.
    Assume that (L < M).
    We argue by contradiction.
    Assume that (¬ (there exists a : ℝ, A a ∧ L < a)).
    It holds that (∀ x : ℝ, A x ⇒ (x <= L)).
    It holds that (is_upper_bound A L).
    By any_upp_bd_ge_sup it holds that (M ≤ L).
    It holds that (¬(M ≤ L)).
    Contradiction.
Qed.

Lemma exists_almost_maximizer_ε :
  ∀ (A : ℝ -> Prop) (M : ℝ),
    is_sup A M ⇒
      ∀ (ε : ℝ), ε > 0 ⇒
        ∃ a : ℝ, A a ∧ M - ε < a.
Proof.
    Take A : (ℝ -> Prop) and M : ℝ.
    Assume that (is_sup A M).
    Take ε : ℝ; such that (ε > 0).
    It holds that (M - ε < M).
    apply exists_almost_maximizer with (L := M- ε) (M := M).
    - We conclude that (is_sup A M).
    - We conclude that (M - ε < M).
Qed.

Lemma max_or_strict :
  ∀ (A : ℝ → Prop) (M : ℝ),
    is_sup A M ⇒
      (A M) ∨ (∀ a : ℝ, A a ⇒ a < M).
Proof.
    Take A : (ℝ → Prop) and M : ℝ.
    Assume that (is_sup A M).
    We argue by contradiction.
    Assume that ( ¬ (A M ∨ (for all a : ℝ, A a ⇨ a < M))).
    It holds that ((¬ (A M)) ∧ ¬(∀ a : ℝ, A a ⇒ a < M)) (i).
    Because (i) both (¬ (A M)) and  (¬(∀ a : ℝ, A a ⇒ a < M)) hold.
    (** We only show the proposition on the *)
    (** hand side of the or-sign, i.e. we will show that for all $a \in \mathbb{R}$, if $a \in A$ then $a < M$*)
    We claim that (∀ a : ℝ, A a ⇒ a < M).
    { Take a : ℝ.
      Assume that (A a).
      By sup_is_upp_bd it holds that (is_upper_bound A M).
      It holds that (a ≤ M).
      We claim that (¬(a = M)).
      { Assume that (a = M) (eq_1).
        We claim that (A M).
        { (* TODO: improve*)
          rewrite <- eq_1.
          We conclude that (A a).
        }
        Contradiction.
      }
      We conclude that (a < M).
    }
    Contradiction.
Qed.

(** ## Suprema and sequences*)
Lemma seq_ex_almost_maximizer_ε :
  ∀ (a : ℕ → ℝ) (pr : has_ub a) (ε : ℝ),
    ε > 0 ⇒ ∃ k : ℕ, a k > lub a pr - ε.
Proof.
    Take a : (ℕ → ℝ).
    Assume that (has_ub a) (i).
    Expand the definition of lub.
    That is, write the goal as (for all ε : ℝ,  ε > 0
      ⇨ there exists k : ℕ, a k > (let (a0, _) := ub_to_lub a (i) in a0) - ε).
    Define lub_a_prf := (ub_to_lub a (i)).
    Obtain l according to (lub_a_prf), so for l : R it holds that (is_sup (EUn a) l).
    Take ε : ℝ; such that (ε > 0).
    By exists_almost_maximizer_ε it holds that (∃ y : ℝ, (EUn a) y ∧ y > l - ε) (iv).
    Obtain y according to (iv), so for y : R it holds that
      ((EUn a) y ∧ y > l - ε) (v).
    Because (v) both (EUn a y) (vi) and (y > l - ε) hold.
    Expand the definition of EUn in (vi).
    That is, write (vi) as (there exists n : ℕ , y = a n).
    Obtain n according to (vi), so for n : nat it holds that (y = a n).
    Choose k := n.
    We need to show that (l - ε < a n).
    We conclude that (& l - ε < y = a n).
Qed.

Lemma seq_ex_almost_maximizer_m :
  ∀ (a : ℕ → ℝ) (pr : has_ub a) (m : ℕ),
    ∃ k : ℕ, a k > lub a pr - 1 / (INR(m) + 1).
Proof.
    Take a : (ℕ → ℝ).
    Assume that (has_ub a).
    Take m : ℕ.
    By seq_ex_almost_maximizer_ε it suffices to show that (1 / (m + 1) > 0).
    (** We need to show that $1/(m+1) > 0$.*)
    It holds that (0 < m + 1)%R.
    We conclude that (1 / (m+1) > 0).
Qed.

Lemma exists_almost_lim_sup_aux :
  ∀ (a : ℕ → ℝ) (pr : has_ub a) (m : ℕ) (N : ℕ),
    ∃ k : ℕ, (k ≥ N)%nat ∧ a k > sequence_ub a pr N - 1 / (INR(m) + 1).
Proof.
    Take a : (ℕ → ℝ).
    Assume that (has_ub a) (i).
    Take m, Nn : ℕ.
    By seq_ex_almost_maximizer_m it holds that
      (∃ k : ℕ, a (Nn + k)%nat > sequence_ub a (i) Nn - 1 / (INR m + 1)) (ii).
    Obtain k according to (ii), so for k : nat it holds that
      (a (Nn + k)%nat > sequence_ub a i Nn - 1 / (m + 1)).
    Choose l := (Nn+k)%nat.
    We show both statements.
    - We need to show that (l ≥ Nn)%nat.
      We conclude that (l ≥ Nn)%nat.
    - We need to show that ( a l > sequence_ub a (i) Nn - 1 / (m + 1) ).
      We conclude that ( a l > sequence_ub a (i) Nn - 1 / (m + 1) ).
Qed.

Close Scope sup_and_inf_scope.
Close Scope R_scope.


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

Fixpoint plus (n m: nat) :=
    match n with
    | S n' => S (plus n' m)
    | O => m
    end.

(* A magma is a set with a binary (closed) operation. *)
Module Type Magma.
    Parameter T: Set.
    Parameter op: T -> T -> T.
End Magma.

(* Natural numbers with plus form a magma. *)
Module Nat: Magma.
    Definition T := nat.
    Definition op := plus.
End Nat.

Module Type M := Magma.
Module MyNat: M := Nat.

(* A functor transforming a magma into another magma. *)
Module DoubleMagma (M: Magma): Magma.
    Definition T := M.T.
    Definition op x y := M.op (M.op x y) (M.op x y).
End DoubleMagma.

Module NatWithDoublePlus := DoubleMagma Nat.