Require Import List.
Require Import Peano_dec.

Fixpoint upto_aux m m' n {struct n} : list nat :=
  match n with
    | 0 => nil
    | (S n') =>
      match eq_nat_dec n m' with
        | left _ => nil
        | right _ => m::(upto_aux (S m) m' n')
      end
  end.

Definition upto m n := upto_aux m m n.

Fixpoint downto m n {struct m} : list nat :=
  match eq_nat_dec m n with
    | left _ => nil
    | right _ =>
      match m with
        | 0 => nil
        | (S m') => m::(downto m' n)
      end
  end.

Require Import Ascii.

Inductive digit : Set := Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine.
Definition base10 := list digit.

Fixpoint base10_inc (xs : base10) :=
  match xs with
    | nil => cons One nil
    | cons x xs' =>
      match x with
        | Zero => cons One xs'
        | One => cons Two xs'
        | Two => cons Three xs'
        | Three => cons Four xs'
        | Four => cons Five xs'
        | Five => cons Six xs'
        | Six => cons Seven xs'
        | Seven => cons Eight xs'
        | Eight => cons Nine xs'
        | Nine => cons Zero (base10_inc xs')
      end
  end.

Fixpoint base10_of_nat (n:nat) :=
  match n with
    | 0 => cons Zero nil
    | S n' => base10_inc (base10_of_nat n')
  end.

Definition nat_of_digit (d:digit) :=
  match d with
    | Zero => 0
    | One => S(0)
    | Two => S(S(0))
    | Three => S(S(S(0)))
    | Four => S(S(S(S(0))))
    | Five => S(S(S(S(S(0)))))
    | Six => S(S(S(S(S(S(0))))))
    | Seven => S(S(S(S(S(S(S(0)))))))
    | Eight => S(S(S(S(S(S(S(S(0))))))))
    | Nine => S(S(S(S(S(S(S(S(S(0)))))))))
  end.

Fixpoint nat_of_base10 (b:base10) :=
  match b with
    | nil => 0
    | cons d ds => (nat_of_digit d) + (10 * (nat_of_base10 ds))
  end.

Require Import String.
Open Local Scope char_scope.
Definition string_of_digit (d : digit) :=
  match d with
    | Zero => "0"
    | One => "1"
    | Two => "2"
    | Three => "3"
    | Four => "4"
    | Five => "5"
    | Six => "6"
    | Seven => "7"
    | Eight => "8"
    | Nine => "9"
  end.

Open Local Scope string_scope.
Fixpoint string_of_base10_aux (ds : base10) :=
  match ds with
    | nil => ""
    | cons d ds' => String (string_of_digit d) (string_of_base10_aux ds')
  end.

Definition string_of_base10 (ds : base10) := string_of_base10_aux (rev ds).

Definition string_of_nat (n:nat) := string_of_base10 (base10_of_nat n).

Require Import OptionMonad.
Open Scope char_scope.

Fixpoint base10_of_string_aux (s:string) : option base10 :=
  match s with
    | EmptyString => Some (A:=base10) nil
    | String c s' =>
      match c with
        | "0" => t <- (base10_of_string_aux s') ;; ret (cons Zero t)
        | "1" => t <- (base10_of_string_aux s') ;; ret (cons One t)
        | "2" => t <- (base10_of_string_aux s') ;; ret (cons Two t)
        | "3" => t <- (base10_of_string_aux s') ;; ret (cons Three t)
        | "4" => t <- (base10_of_string_aux s') ;; ret (cons Four t)
        | "5" => t <- (base10_of_string_aux s') ;; ret (cons Five t)
        | "6" => t <- (base10_of_string_aux s') ;; ret (cons Six t)
        | "7" => t <- (base10_of_string_aux s') ;; ret (cons Seven t)
        | "8" => t <- (base10_of_string_aux s') ;; ret (cons Eight t)
        | "9" => t <- (base10_of_string_aux s') ;; ret (cons Nine t)
        | _ => None (A:=base10)
      end
  end.

Definition base10_of_string (s:string) := l <- (base10_of_string_aux s) ;; ret (rev l).

Definition nat_of_string (s:string) := x <- (base10_of_string s) ;; ret (nat_of_base10 x).

Notation "A || B" := (if A then true else (if B then true else false)).
Notation "A && B" := (if A then (if B then true else false) else false).
Notation "! A" := (if A then false else true) (at level 10).

Definition compose `A B C` (f : B -> C) (g : A -> B) :=
  (fun (x:A) => f (g x)).
Implicit Arguments compose [A B C].
Infix "o" := compose (at level 20).

Definition uncurry `A B C` (f : A -> B -> C) (p : A * B) : C.
Proof.
  firstorder.
Defined.

Fixpoint foldr (A B : Type) (f : A -> B -> B) (zero : B) (l : list A) : B :=
  match l with
    | nil => zero
    | cons h t => (f h (foldr A B f zero t))
  end.
Implicit Arguments foldr [A B].

Fixpoint foldl (A B : Type) (f : A -> B -> B) (zero : B) (l : list A) : B :=
  match l with
    | nil => zero
    | cons h t => foldl A B f (f h zero) t
  end.
Implicit Arguments foldl [A B].

Fixpoint map (A B : Type) (f : A -> B) (l : list A) : list B :=
  match l with
    | nil => nil
    | cons h t => cons (f h) (map A B f t)
  end.

Fixpoint assoc (A B :Type) (f : A -> bool) (l : list (A*B)) : option B :=
  match l with
    | nil => None
    | cons h t =>
      match h with
        | (k,v) =>
          if f k
            then Some v
            else assoc A B f t
      end
  end.
Implicit Arguments assoc [A B].

Theorem pair_eq_dec : forall (A B:Type),
  (forall (a a':A), {a = a'} + {a <> a'}) ->
  (forall (b b':B), {b = b'} + {b <> b'}) ->
  (forall (c c':A*B), {c = c'} + {c <> c'}).
Proof.
  decide equality.
Defined.
Implicit Arguments pair_eq_dec [A B].

Fixpoint zip (A B:Type) (l:list A) (l':list B) : option (list (A*B)):=
  match l, l' with
    | nil, nil => Some nil
    | cons h t, cons h' t' =>
      match zip A B t t' with
        | None => None
        | Some a => Some (cons (h,h') a)
      end
    | _,_ => None
  end.

Fixpoint iter (A:Type) (f:A->A) (zero:A) (n:nat) {struct n} : A :=
  match n with
    | 0 => zero
    | S n' => f (iter A f zero n')
  end.

(* This gives us an `In' predicate that uses decidable equality so is useable for both Type and Set, and not just Prop *)
Definition Member : forall (A : Type) (eq_dec : forall (a b:A), {a = b} + {a <> b}) (a : A) (l : list A), Prop.
  intros A eq_dec.
  refine
    (fix Member (a : A) (l : list A) {struct l} : Prop :=
      match l with
        | nil => False
        | b :: m => match eq_dec a b with
                      | left p => True
                      | right p => Member a m
                    end
      end) ; try (right ; clear Member ; auto ; fail).
Defined.
Implicit Arguments Member [A].

Lemma member_imp_in : forall A (x:A) l eq_dec, Member eq_dec x l -> In x l.
Proof.
  induction l. intros. inversion H. intros. simpl in H. case_eq (eq_dec x a).
  intros. rewrite e. firstorder.
  intros. rewrite H0 in H. simpl. right. eapply IHl. eauto.
Defined.

Lemma in_imp_member : forall A (x:A) l eq_dec, In x l -> Member eq_dec x l.
Proof.
  induction l. intros. inversion H. intros. simpl in H. inversion H.
  simpl. case_eq (eq_dec x a). intros. auto. intros. congruence.
  simpl. case_eq (eq_dec x a). intros. auto. intros.
  apply IHl. auto.
Defined.

Require Import List.
Fixpoint Prefix `A` (l:list A) (l':list A) : Prop :=
  match l' with
    | nil => False
    | cons h' t' =>
      match l with
        | nil => True
        | cons h t => h = h' /\ Prefix A t t'
      end
  end.

Lemma prefix_correct : forall A (a:A) (l:list A) (l':list A), Prefix l l' -> exists l'':list A, l++l''=l'.
Proof.
  induction l. intros. exists l'. auto.
  intros. simpl in H. destruct l'. inversion H.
  inversion H. rewrite H0. apply IHl in H1. inversion H1.
  exists x. rewrite <- H2. auto.
Defined.

(*
Inductive Suffix A (l':list A) : list A -> Prop :=
| suffix_same : forall (a:A) (l:list A), l' = l -> Suffix A l' (cons a l)
| suffix_next : forall (a:A) (l:list A), Suffix A l' l -> Suffix A l' (cons a l).
Implicit Arguments Suffix [A].
*)

Fixpoint Suffix `A` (l:list A) (l':list A) : Prop :=
  match l' with
    | nil => False
    | cons h' t' => l = t' \/ Suffix A l t'
  end.

(* Definition Suffix `A` (l:list A) (l':list A) := Prefix (rev l) (rev l'). *)

Lemma suffix_correct : forall A (l':list A) (l:list A), Suffix l l' -> exists l'':list A, l'' <> nil /\ l''++l=l'.
Proof.
  induction l'. intros. inversion H.
  intros. simpl in H. destruct l. exists (a::l'). split. congruence. rewrite app_nil_end. auto. inversion H. rewrite H0.
  exists (a::nil). auto. split. congruence.
  firstorder.
  apply IHl' in H0. inversion H0.
  exists (a::x). simpl. split. congruence. inversion H1. subst. auto.
Defined.

Lemma prefix_smaller : forall A (l:list A) (l':list A), Prefix l l' -> length l < length l'.
Proof.
  induction l ; destruct l'; firstorder ; simpl ; auto with arith.
Defined.

Lemma suffix_smaller : forall A (l:list A) (l':list A), Suffix l l' -> length l < length l'.
Proof.
  intros A l l'. generalize dependent l. generalize dependent l'.
  induction l' ; destruct l ; firstorder simpl in * ; subst ; auto with arith.
Defined.

Lemma suffix_one : forall A (l l':list A) (a:A), Suffix (cons a l') l -> Suffix l' l.
Proof.
  intros. induction l. inversion H.
  simpl. inversion H. subst. right. simpl. auto.
  right. apply IHl. auto.
Defined.

Lemma suffix_nil : forall A (l:list A) (a:A), Suffix nil (cons a l).
Proof.
  induction l. simpl. left. auto.
  intros. simpl in *. right. apply IHl. auto.
Defined.

Lemma suffix_not_nil : forall A (l l':list A), Suffix l l' -> l' <> nil.
Proof.
  intros. destruct l'. inversion H. unfold not. intros. inversion H0.
Defined.

Lemma suffix_app : forall A (l x:list A), x <> nil -> Suffix l (x ++ l).
Proof.
  intros. induction x. congruence.
  simpl. destruct x. left. simpl. auto.
  simpl. right. simpl in IHx. apply IHx. congruence.
Defined.

Lemma suffix_trans : forall A (l l' l'':list A), Suffix l' l -> Suffix l'' l' -> Suffix l'' l.
Proof.
  intros A l l' l'' H H0. cut (Suffix l' l) ; auto ; intros H1. apply suffix_not_nil in H1.
  apply suffix_correct in H ; apply suffix_correct in H0.
  destruct H. destruct H0. destruct H ; destruct H0. subst.
  rewrite <- app_ass in *. apply suffix_app.
  destruct x ; destruct x0 ; try (congruence).
  simpl. firstorder.
Defined.

Lemma Suffix_acc : forall A (l:list A), Acc Suffix l.
Proof.
  induction l.
  constructor. intros. inversion H.
  constructor. intros. inversion H. subst. auto.
  eapply Acc_inv. eauto. auto.
Defined.

Theorem Suffix_wf : forall A, well_founded (Suffix (A:=A)).
Proof.
  intros. exact (Suffix_acc A).
Defined.


Require Import ssreflect ssrbool eqtype ssrnat.

(**
# 第8回

http://qnighy.github.io/coqex2014/ex6.html

## 課題37 (別解）

自然数の対の商集合として整数を定義する。下の証明の空欄を埋めよ。
omega等を使ってもよい。

オリジナルの出題は SetoidClass を使用しているが、それを使わない場合。
「Add Parametric Relation : int equiv」を使う。

参考：
http://d.hatena.ne.jp/m-a-o/20110112
http://sssslide.com/www.slideshare.net/tmiya/coq-setoid-20110129
*)

Require Import Setoid.                      (* !!! *)

Record int :=
  {
    Ifst : nat;
    Isnd : nat
  }.

Definition equiv (x y : int) :=             (* == *)
  Ifst x + Isnd y = Ifst y + Isnd x.

Notation "x == z" := (equiv x z) (at level 70).

(* equivがint上の同値関係である事を証明する。 *)
Lemma equiv_refl : reflexive int equiv.
Proof.
  by rewrite /reflexive.
Qed.

Lemma equiv_sym : symmetric int equiv.
Proof.
  by rewrite /symmetric.
Qed.

Lemma addn2r p m n : (m + p = n + p) -> (m = n).
Proof.
  move/eqP => H.
  apply/eqP.
  by rewrite -(eqn_add2r p).
Qed.

Lemma equiv_trans : transitive int equiv.
Proof.
  rewrite /transitive.
  rewrite /equiv.
  move=> x y z.
  move=> Hxy Hyz.
  apply (addn2r (Ifst y + Isnd y)).
  rewrite !addnA.
  rewrite [Ifst x + Isnd z + Ifst y + Isnd y]addnC.
  rewrite [Ifst z + Isnd x + Ifst y + Isnd y]addnC.
  rewrite !addnA.
  rewrite [Isnd y + Ifst x]addnC.
  rewrite [Isnd y + Ifst z]addnC.
  rewrite Hxy.
  rewrite -Hyz.
  rewrite [Ifst y + Isnd z + Isnd x + Ifst y]addnC.
  rewrite [Ifst y + Isnd z + Isnd x]addnC.
  rewrite [Ifst y + Isnd z]addnC.
  rewrite !addnA.
  by [].
Qed.

(* int equiv が Setoid であることを登録す。 *)
Add Parametric Relation : int equiv
    reflexivity  proved by equiv_refl
    symmetry     proved by equiv_sym
    transitivity proved by equiv_trans as ISetoid.

Definition zero : int :=
  {|
    Ifst := 0;
    Isnd := 0
  |}.

Definition int_plus (x y : int) : int :=
  {|
    Ifst := Ifst x + Ifst y;
    Isnd := Isnd x + Isnd y
  |}.

Definition int_minus (x y : int) : int :=
  {|
    Ifst := Ifst x + Isnd y;
    Isnd := Isnd x + Ifst y
  |}.

Add Parametric Morphism : int_plus with
  signature (equiv ==> equiv ==> equiv) as int_plus_compat.
Proof.
  move=> x y Hxy x' y' Hx'y'.
  rewrite /int_plus /equiv /=.

  have Hxy2 : (Ifst x + Isnd y = Ifst y + Isnd x) by apply Hxy.
  have Hx'y'2 : (Ifst x' + Isnd y' = Ifst y' + Isnd x') by apply Hx'y'.

  rewrite 2!addnA.
  rewrite -[Ifst x + Ifst x' + Isnd y]addnA.
  rewrite [Ifst x' + Isnd y]addnC.
  rewrite addnA.
  rewrite Hxy2.
  rewrite -[(Ifst y + Isnd x) + Ifst x' + Isnd y']addnA.
  rewrite Hx'y'2.
  rewrite addnA.
  rewrite -[Ifst y + Isnd x + Ifst y']addnA.
  rewrite [Isnd x + Ifst y']addnC.
  rewrite addnA.
  by [].
Qed.

Add Parametric Morphism : int_minus with
  signature (equiv ==> equiv ==> equiv) as int_minus_compat.
Proof.
  move=> x y Hxy x' y' Hx'y'.
  rewrite /int_minus /equiv /=.

  have Hxy2 : (Ifst x + Isnd y = Ifst y + Isnd x) by apply Hxy.
  have Hx'y'2 : (Ifst x' + Isnd y' = Ifst y' + Isnd x') by apply Hx'y'.

  rewrite 2!addnA.
  rewrite [Ifst x + Isnd x' + Isnd y]addnC.
  rewrite [Ifst y + Isnd y' + Isnd x]addnC.
  rewrite 2!addnA.
  rewrite [Isnd y + Ifst x]addnC.
  rewrite -addnA.
  rewrite [Isnd x' + Ifst y']addnC.
  rewrite [Isnd x + Ifst y]addnC.
  rewrite -Hx'y'2.
  rewrite -Hxy2.
  rewrite -[(Ifst x + Isnd y) + Isnd y' + Ifst x']addnA.
  rewrite [Isnd y' + Ifst x']addnC.
  by [].
Qed.

Lemma int_sub_diag : forall x, int_minus x x == zero.
Proof.
  move=> x.
  rewrite /equiv.
  rewrite /int_minus.
  by rewrite addn0 add0n addnC.
Qed.

(* まず、int_minus_compatを証明せずに、下の2つの証明を実行して、どちらも失敗することを確認せよ。*)
(* 次に、int_minus_compatを証明し、下の2つの証明を実行せよ。 *)

(* rewrite と setoid_rewrite は SetoidClassと同様に使える。 *)

Goal forall x y, int_minus x (int_minus y y) == int_minus x zero.
Proof.
  intros x y.
  rewrite int_sub_diag.
  reflexivity.
Qed.

Goal forall x y, int_minus x (int_minus y y) == int_minus x zero.
Proof.
  intros x y.
  setoid_rewrite int_sub_diag.
  reflexivity.
Qed.

(**

おまけ : ISetoidの定義においてProgram InstanceをInstanceに変更し、Next Obligation. を取り除
いてもISetoidは定義できるが、続きがうまくいかなくなる。これは何故か？

ヒント

通常のイコール (Coq.Init.Logic.eq) 以外の同値関係を入れたい場合、Setoidを使います。Setoidに
よる書き換えは、通常rewriteで行えます。明示的にSetoidを使う場合は、setoid_rewriteを使います。

Setoidによってreplaceを行いたい場合はsetoid_replaceを使えます。通常のイコールと違い、
Setoidの同値関係を保存しない写像が存在する可能性があります。例えば、この問題におけるIfst関
数はSetoidの同値関係を保存しません。Setoidによる書き換えを行うためには、それぞれの関数が同
値関係を保存することを逐一証明する必要があります。

Recordは単一のコンストラクタを持ち再帰的でない型を定義するのに使えるコマンドです。メンバを
取り出す関数(この例ではIfst, Isnd)が自動的に定義されることや、{| ... |} という構文でRecord
型の値を記述できるという利点があります。
*)

(* END *)


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


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


(**
Here we define the category of join semilattices using the mechanism of algebras.
 *)
Require Import prelude.all.
Require Import syntax.hit_signature.
Require Import syntax.hit.
Require Import syntax.hit_properties.
Require Import algebras.set_algebra.
Require Import existence.hit_existence.
Require Import displayed_algebras.displayed_algebra.
Require Import examples.free.

Open Scope cat.

Opaque HIT_exists hit_ind hit_ind_prop hit_rec.

(** We first define the signature. *)

(** Operations *)
Definition semilattice_operations
  : poly_code
  := (I * I) (* join *)
     + C unitset (* empty *).

(** Labels of group axioms *)
Inductive semilattice_ax :=
| nl : semilattice_ax
| idem : semilattice_ax
| com : semilattice_ax
| assoc : semilattice_ax.

(** Arguments for each label *)
Definition semilattice_arg
  : semilattice_ax → poly_code
  := fun j =>
       match j with
       | nl => I
       | idem => I
       | com => I * I
       | assoc => I * I * I
       end.

(** Some convenient notation for the constructor terms. These represent the operations.
    For the signature, we call the operation `join`.
*)
Definition join_e
           {P : poly_code}
           (e₁ e₂ : endpoint semilattice_operations P I)
  : endpoint semilattice_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₁ _ _)).
  exact (pair e₁ e₂).
Defined.

Definition empty_e
           {P : poly_code}
  : endpoint semilattice_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₂ _ _)).
  apply c.
  exact tt.
Defined.

(** The left hand side of each equation *)
Definition semilattice_lhs
  : ∏ (j : semilattice_ax), endpoint semilattice_operations (semilattice_arg j) I.
Proof.
  induction j ; cbn.
  - refine (join_e _ _). (* nl *)
    + exact empty_e.
    + exact (id_e _ _).
  - refine (join_e _ _). (* idem *)
    + exact (id_e _ _).
    + exact (id_e _ _).
  - refine (join_e _ _). (* com *)
    + exact (π₁ _ _).
    + exact (π₂ _ _).
  - refine (join_e (join_e _ _) _). (* assoc *)
    + exact (comp (π₁ _ _) (π₁ _ _)).
    + exact (comp (π₁ _ _) (π₂ _ _)).
    + exact (π₂ _ _).
Defined.

(** The right hand side of each equation *)
Definition semilattice_rhs
  : ∏ (j : semilattice_ax), endpoint semilattice_operations (semilattice_arg j) I.
Proof.
  induction j ; cbn.
  - exact (id_e _ _). (* nl *)
  - exact (id_e _ _). (* idem *)
  - refine (join_e _ _). (* com *)
    + exact (π₂ _ _).
    + exact (π₁ _ _).
  - refine (join_e _ (join_e _ _)). (* assoc *)
    + exact (comp (π₁ _ _) (π₁ _ _)).
    + exact (comp (π₁ _ _) (π₂ _ _)).
    + exact (π₂ _ _).
Defined.

(** The signature of ring as a HIT signature *)
Definition semilattice_signature
  : hit_signature.
Proof.
  use tpair.
  - exact semilattice_operations.
  - use tpair.
    + exact semilattice_ax.
    + use tpair.
      * exact semilattice_arg.
      * split.
        ** exact semilattice_lhs.
        ** exact semilattice_rhs.
Defined.

(** The interpretation of ring in set *)
Definition semilattice_cat
  : univalent_category
  := set_algebra semilattice_signature.

(** Projections of a ring *)
Section JoinSemiLatticeProjections.
  Variable (S : semilattice_cat).

  Definition join_semilattice_carrier : hSet
    := pr11 S.

  Definition join
    : join_semilattice_carrier → join_semilattice_carrier → join_semilattice_carrier
    := λ x₁ x₂, pr21 S (inl (x₁ ,, x₂)).

  Local Notation "x₁ ∪ x₂" := (join x₁ x₂) (at level 40, left associativity).

  Definition empty
    : join_semilattice_carrier
    := pr21 S (inr tt).

  Local Notation "'0'" := empty.

  Definition join_semilattice_nl
    : ∏ (x : join_semilattice_carrier), 0 ∪ x = x
    := λ x, pr2 S nl x.

  Definition join_semilattice_idem
    : ∏ (x : join_semilattice_carrier), x ∪ x = x
    := λ x, pr2 S idem x.

  Definition join_semilattice_com
    : ∏ (x y : join_semilattice_carrier), x ∪ y = y ∪ x
    := λ x y, pr2 S com (x ,, y).

  Definition join_semilattice_assoc
    : ∏ (x y z : join_semilattice_carrier), (x ∪ y) ∪ z = x ∪ (y ∪ z)
    := λ x y z, pr2 S assoc ((x ,, y) ,, z).

  Definition join_semilattice_nr
    : ∏ (x : join_semilattice_carrier), x ∪ 0 = x
    := λ x, join_semilattice_com x 0 @ join_semilattice_nl x.
End JoinSemiLatticeProjections.

(** Builder for semilattices *)
Definition mk_semilattice
           {S : hSet}
           (e : S)
           (j : S → S → S)
           (j_nl : ∏ (x : S), j e x = x)
           (j_idem : ∏ (x : S), j x x = x)
           (j_com : ∏ (x y : S), j x y = j y x)
           (j_assoc : ∏ (x y z : S), j (j x y) z = j x (j y z))
  : semilattice_cat.
Proof.
  simple refine ((S ,, _) ,, _).
  - cbn.
    intros x.
    induction x as [x | x].
    + exact (j (pr1 x) (pr2 x)).
    + exact e.
  - intros k.
    induction k.
    + exact j_nl.
    + exact j_idem.
    + exact (λ z, j_com (pr1 z) (pr2 z)).
    + exact (λ z, j_assoc (pr11 z) (pr21 z) (pr2 z)).
Defined.

(** Kuratowski finite sets *)
Section KFinite.
  Variable (X : hSet).

  Local Definition kuratowski_free_HIT
    : set_algebra (free_signature semilattice_signature X)
    := free_algebra_help semilattice_signature X.

  Definition kuratowski_HIT
    : semilattice_cat
    := free_alg_to_alg _ kuratowski_free_HIT.

  (** Constructors *)
  Definition kuratowski
    : hSet
    := alg_carrier kuratowski_HIT.

  Definition k_empty
    : kuratowski
    := alg_operation kuratowski_HIT (inr tt).

  Definition k_singleton
    : X → kuratowski
    := free_algebra_inc semilattice_signature X.

  Definition k_union
    : kuratowski → kuratowski → kuratowski
    := λ x y, alg_operation kuratowski_HIT (inl (x ,, y)).

  Definition k_nl
    : ∏ (x : kuratowski), k_union k_empty x = x
    := alg_paths kuratowski_free_HIT nl.

  Definition k_nr
    : ∏ (x : kuratowski), k_union x k_empty = x
    := join_semilattice_nr kuratowski_HIT.

  Definition k_idem
    : ∏ (x : kuratowski), k_union x x = x
    := alg_paths kuratowski_free_HIT idem.

  Definition k_com
    : ∏ (x y : kuratowski), k_union x y = k_union y x
    := λ x y, alg_paths kuratowski_free_HIT com (x ,, y).

  Definition k_assoc
    : ∏ (x y z : kuratowski), k_union (k_union x y) z = k_union x (k_union y z)
    := λ x y z, alg_paths kuratowski_free_HIT assoc ((x ,, y) ,, z).

  (** Induction *)
  Section KInduction.
    Context {Y : kuratowski → UU}.
    Variable (Ye : Y k_empty)
             (Ys : ∏ (x : X), Y (k_singleton x))
             (Yu : ∏ (z₁ z₂ : kuratowski), Y z₁ → Y z₂ → Y (k_union z₁ z₂))
             (Ynl : ∏ (x : kuratowski) (y : Y x),
                     transportf Y (k_nl x) (Yu k_empty x Ye y)
                     =
                     y)
             (Yidem : ∏ (x : kuratowski) (y : Y x),
                      transportf Y (k_idem x) (Yu x x y y)
                      =
                      y)
             (Ycom : ∏ (x₁ x₂ : kuratowski) (y₁ : Y x₁) (y₂ : Y x₂),
                     transportf Y (k_com x₁ x₂) (Yu x₁ x₂ y₁ y₂)
                     =
                     Yu x₂ x₁ y₂ y₁)
             (Yassoc : ∏ (x₁ x₂ x₃ : kuratowski)
                         (y₁ : Y x₁) (y₂ : Y x₂) (y₃ : Y x₃),
                       transportf Y
                                  (k_assoc x₁ x₂ x₃)
                                  (Yu (k_union x₁ x₂) x₃ (Yu x₁ x₂ y₁ y₂) y₃)
                       =
                       Yu x₁ (k_union x₂ x₃) y₁ (Yu x₂ x₃ y₂ y₃))
             (Yset : ∏ (x : kuratowski), isaset (Y x)).

    Definition K_ind_disp_algebra
      : disp_algebra kuratowski_free_HIT.
    Proof.
      use make_disp_algebra.
      - intros x.
        use make_hSet.
        + exact (Y x).
        + exact (Yset x).
      - intros x.
        induction x as [x | x].
        + exact (λ _, Ys x).
        + induction x as [x | x].
          * intros y.
            exact (Yu (pr1 x) (pr2 x) (pr1 y) (pr2 y)).
          * induction x.
            exact (λ _, Ye).
      - intros j.
        simpl.
        induction j.
        + exact Ynl.
        + exact Yidem.
        + exact (λ x y, Ycom (pr1 x) (pr2 x) (pr1 y) (pr2 y)).
        + exact (λ x y, Yassoc (pr11 x) (pr21 x) (pr2 x) (pr11 y) (pr21 y) (pr2 y)).
    Defined.

    Definition K_ind_help
      : disp_algebra_map K_ind_disp_algebra
      := pr2 (HIT_exists (free_signature semilattice_signature X)) K_ind_disp_algebra.

    Definition K_ind
      : ∏ (x : kuratowski), Y x
      := pr1 K_ind_help.

    Definition K_ind_e
      : K_ind k_empty = Ye.
    Proof.
      apply K_ind_help.
    Qed.

    Definition K_ind_s
      : ∏ (x : X), K_ind (k_singleton x) = Ys x.
    Proof.
      intro x.
      apply K_ind_help.
    Qed.

    Definition K_ind_u
      : ∏ (x₁ x₂ : kuratowski),
        K_ind (k_union x₁ x₂)
        =
        Yu x₁ x₂ (K_ind x₁) (K_ind x₂).
    Proof.
      intros x₁ x₂.
      apply K_ind_help.
    Qed.
  End KInduction.

  (** Induction on families of propositions *)
  Section KInductionProp.
    Context {Y : kuratowski → UU}.
    Variable (Ye : Y k_empty)
             (Ys : ∏ (x : X), Y (k_singleton x))
             (Yu : ∏ (z₁ z₂ : kuratowski), Y z₁ → Y z₂ → Y (k_union z₁ z₂))
             (Yprop : ∏ (x : kuratowski), isaprop (Y x)).

    Definition K_ind_prop
      : ∏ (x : kuratowski), Y x.
    Proof.
      use K_ind.
      - exact Ye.
      - exact Ys.
      - exact Yu.
      - intros ; apply Yprop.
      - intros ; apply Yprop.
      - intros ; apply Yprop.
      - intros ; apply Yprop.
      - intro x.
        apply isasetaprop.
        apply Yprop.
    Defined.
  End KInductionProp.

  (** Recursion *)
  Section KRecusion.
    Context {A : UU}.
    Variable (Ae : A)
             (As : X → A)
             (Au : A → A → A)
             (Anl : ∏ (a : A), Au Ae a = a)
             (Aidem : ∏ (a : A), Au a a = a)
             (Acom : ∏ (a₁ a₂ : A), Au a₁ a₂ = Au a₂ a₁)
             (Aassoc : ∏ (a₁ a₂ a₃ : A), Au (Au a₁ a₂) a₃ = Au a₁ (Au a₂ a₃))
             (Aset : isaset A).

    Definition K_rec_algebra
      : set_algebra (free_signature semilattice_signature X).
    Proof.
      use make_algebra.
      - use make_hSet.
        + exact A.
        + exact Aset.
      - intros a ; cbn in a.
        induction a as [x | a].
        + exact (As x).
        + induction a as [a | a].
          * exact (Au (pr1 a) (pr2 a)).
          * exact Ae.
      - intros j.
        induction j.
        + exact Anl.
        + exact Aidem.
        + exact (λ x, Acom (pr1 x) (pr2 x)).
        + exact (λ x, Aassoc (pr11 x) (pr21 x) (pr2 x)).
    Defined.

    Definition K_rec_help
      : kuratowski_free_HIT --> K_rec_algebra
      := hit_rec _ K_rec_algebra.

    Definition K_rec
      : kuratowski → A
      := alg_map_carrier K_rec_help.

    Definition K_rec_e
      : K_rec k_empty = Ae.
    Proof.
      apply (eqtohomot (pr21 K_rec_help)).
    Qed.

    Definition K_rec_s
      : ∏ (x : X), K_rec (k_singleton x) = As x.
    Proof.
      intro x.
      apply (eqtohomot (pr21 K_rec_help)).
    Qed.

    Definition K_rec_u
      : ∏ (x₁ x₂ : kuratowski), K_rec (k_union x₁ x₂) = Au (K_rec x₁) (K_rec x₂).
    Proof.
      intros x₁ x₂.
      apply (eqtohomot (pr21 K_rec_help)).
    Qed.
  End KRecusion.
End KFinite.


(** * Additive principal ordinals *)

(** Pierre Casteran, LaBRI, Universite de Bordeaux *)

(**

In this library, we define the exponential of basis omega, also called [phi0].

In fact,  #<math> ω <sup> α </sup> </math># , written  [phi0 alpha] in Coq,
 is defined as the [alpha]-th _additive principal_ ordinal.

 *)

(* begin hide *)
From Coq Require Import Arith  Logic.Epsilon  Ensembles  Lia.
From hydras Require Export Countable  Schutte_basics
     Ordering_Functions.
Import  PartialFun  MoreEpsilonIota .
From hydras Require Export Schutte.Addition  Well_Orders.

Set Implicit Arguments.

(* end hide *)

(** ** Main Definitions

 *** Additive principal ordinals
 *)

(* begin snippet APDef *)

Definition AP : Ensemble Ord :=
  fun alpha =>
    zero < alpha /\
    (forall beta, beta < alpha -> beta + alpha = alpha).

(* end snippet APDef *)

(**  *** Exponential of basis omega
 *)

(* begin snippet phi0Def *)

Definition _phi0 := ord AP.

Notation phi0 := _phi0.

Notation "'omega^'" := phi0 (only parsing) : schutte_scope.

(* end snippet phi0Def *)

(**  *** Omega-towers
 *)

(* begin snippet omegaTower *)

Fixpoint omega_tower (i : nat) : Ord :=
  match i with
    0 =>  1
  | S j => phi0 (omega_tower j)
  end.

(* end snippet omegaTower *)

(** *** The limit ordinal [epsilon0]
 *)
(* begin snippet epsilon0Def *)

Definition epsilon0 := omega_limit omega_tower.

(* end snippet epsilon0Def *)

(** ** Proofs, proofs, proofs ... *)

(** ** About additive principals *)

(* begin snippet APOne:: no-out *)
Lemma AP_one : In AP 1.
(* end snippet APOne *)
Proof with auto with schutte.
  split.
  -  simpl (F 1) ...
  -  simpl (F 1); intros beta H.
     assert (H0: beta <= zero).
     { apply lt_succ_le_2 ... }
     rewrite (le_alpha_zero H0), zero_plus_alpha...
Qed.

(* begin snippet APOne_least_AP:: no-out *)
Lemma least_AP : least_member lt AP 1.
(* end snippet APOne_least_AP *)
Proof.
  repeat split.
  - simpl (F 1). auto with schutte.
  - intros beta H;  assert (beta = zero).
    { simpl (F 1) in H; apply le_alpha_zero,  lt_succ_le_2.
      assumption.
    }
    subst beta; rewrite zero_plus_alpha; reflexivity.
  - intros x  H0; tricho x (F 1) H3.
    + simpl (F 1) in H3; assert (x = zero).
    { now apply le_alpha_zero, lt_succ_le_2. }
     subst x; destruct H0; now case (@lt_irrefl zero).
    + subst x; now left.
    + right; auto.
Qed.

(* begin snippet APOne_AP_omega:: no-out *)
Lemma AP_omega : In AP omega.
(* end snippet APOne_AP_omega *)
Proof.
  repeat split.
  - apply lt_trans with (F 1).
    +  simpl (F 1) ; auto with schutte.
    + apply finite_lt_omega.
  - intros beta H; case (@lt_omega_finite _  H).
    intros;subst beta;apply finite_plus_infinite; auto with schutte.
Qed.

#[global] Hint Resolve zero_lt_omega : schutte.

Lemma AP_finite_eq_one : forall n: nat, AP n -> n = 1.
Proof.
  intro n;  case n.
  -  inversion 1.
     simpl in H0; case (@lt_irrefl zero);auto.
  -  intro n0;case n0; trivial.
     inversion_clear 1.
     generalize (H1 (F 1)); intros;
       absurd (F 1 + F (S (S n1)) = F (S (S n1))).
     +  rewrite <- plus_FF;simpl; intro H2.
        case (@lt_irrefl (succ (succ (F n1)))).
        pattern (succ (succ (F n1))) at 2;
          rewrite <- H2; auto with schutte.
     + apply H, finite_mono; auto with arith.
Qed.

(** Thus, omega is the second additive principal *)

(* begin snippet APOne_omega_second_AP:: no-out *)
Lemma omega_second_AP :
  least_member lt
               (fun alpha => 1 < alpha /\ In AP alpha)
               omega.
(* end snippet APOne_omega_second_AP *)
Proof with auto with schutte.
  split.
  - split.
    +  apply finite_lt_omega.
    + apply AP_omega.
  -  intros x  H0; case (@trichotomy x omega).
     + intro H1; case (lt_omega_finite  H1).
       intros; subst x.
       destruct  H0 as [H2 H3]; generalize (AP_finite_eq_one _ H3).
       intro;subst x0;now destruct  (@lt_irrefl (F 1)).
     + red; intuition.
Qed.

(* begin snippet APPlusClosed *)

Lemma AP_plus_closed (alpha beta gamma : Ord):
  In AP alpha -> beta < alpha -> gamma < alpha ->
  beta + gamma < alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof with auto with schutte.
  intros  H  H0 H1; case H;  intros H2 H3.
  generalize (@plus_mono_r  beta gamma alpha); intro H4.
  replace alpha with (beta+alpha) ...
  Qed.

(*||*)

(* end snippet APPlusClosed *)

Lemma AP_mult_Sn_closed (alpha beta: Ord)  :
  AP alpha -> beta < alpha -> forall n,  mult_Sn beta n  < alpha.
  intros H H0; induction n.
  - now simpl.
  -   simpl. now  apply AP_plus_closed.
Qed.

Lemma AP_mult_fin_r_closed  (alpha beta: Ord)  :
  AP alpha -> beta < alpha -> forall n,  beta * n  < alpha.
Proof.
  destruct n.
  - simpl; eapply le_lt_trans ; eauto with schutte.
  - simpl; now apply AP_mult_Sn_closed.
Qed.

(* begin hide *)

Section AP_Unbounded.
  Variable alpha : Ord.

  Let seq := (fix seq (n:nat)  :=
                match n with 0 => succ alpha
                        | S p => (seq p) + (seq p)
                end).

  Let beta := omega_limit seq.

  Remark mono_seq : forall i, seq i < seq (S i).
  Proof with eauto with schutte.
    induction i.
    - simpl;  pattern (succ alpha) at 1.
      rewrite <- alpha_plus_zero; apply plus_mono_r ...
    -   simpl in *.
        pattern (seq i + seq i) at 1; rewrite <- alpha_plus_zero;
        apply plus_mono_r ...
  Qed.

  Lemma mono_seq2 : forall i j, (i < j)%nat -> seq i < seq j.
  Proof with auto.
    induction  1.
    - apply mono_seq ...
    - apply lt_trans with (seq m).
      apply IHle.
      apply mono_seq ...
  Qed.

  Lemma mono_seq_weak2 : forall i j, (i <= j)%nat -> seq i <= seq j.
  Proof with eauto with schutte.
    intros i j H; destruct (le_lt_eq_dec _ _ H).
    - right; now apply mono_seq2.
    - subst j;  left ...

  Qed.

  #[local] Hint Resolve mono_seq mono_seq2 : schutte.

  Remark alpha_lt_beta : alpha < beta.
  Proof with auto with schutte.
    apply lt_trans with (seq 0).
    -  simpl ...
    - unfold beta;  apply lt_omega_limit ...
  Qed.

  Remark zero_lt_beta : zero < beta.
  Proof with eauto with schutte.
    apply le_lt_trans with alpha ...
    apply alpha_lt_beta.
  Qed.

  Section ksi_fixed.
    Variable ksi: Ord.
    Hypothesis lt_ksi : ksi < beta.

    Remark lt_beta_exists : exists n, ksi < seq n.
    Proof.
      case (@lt_omega_limit_lt_exists_lt ksi seq mono_seq); auto.
      intros;exists x;auto.
    Qed.

    Let n := some (fun n => ksi < seq n).

    Remark ksi_plus_seq_n : forall (m:nat), (n <= m)%nat -> ksi + seq m <= beta.
    Proof with eauto with schutte.
      intros m H; apply le_trans with (seq (S m)).
      -  simpl; apply plus_mono_weak_l.
         +  apply le_trans with (seq n).
            *  right; unfold n, some;
                 pattern (epsilon InHWit (fun n0 : nat => ksi < seq n0));
                 apply epsilon_ind.
               apply lt_beta_exists.
               elim H;  auto.
            *  destruct (le_lt_eq_dec n m H).
               right; apply mono_seq2;  auto.
               subst m;left; split ...
      -  right;apply lt_omega_limit.
         + apply seq_mono_intro ...
    Qed.

    Lemma ksi_plus_seq_n' : forall (m:nat), ksi + seq m <= beta.
    Proof.
      intro m ; destruct  (Nat.le_gt_cases n m) as [H | H].
      -  apply ksi_plus_seq_n;auto.
      -   apply le_trans with (ksi + seq n).
          +  apply plus_mono_r_weak;auto.
             apply mono_seq_weak2;  auto with arith.
          +  apply ksi_plus_seq_n;  auto with arith.
    Qed.

    Lemma ksi_plus_beta : ksi + beta <= beta.
    Proof.
      unfold beta at 1; unfold omega_limit.
      rewrite alpha_plus_sup.
      -  apply sup_least_upper_bound; eauto with schutte.
         +  apply R1 with ordinal (ge ksi).
            * apply plus_ordering; auto.
            *  apply seq_range_countable;auto.
            *  intro; split.
         +  intros y [z [H1 H2]]; subst y.
            destruct H1 as [x [_ H2]];  subst z; apply ksi_plus_seq_n'.
      - now exists (seq 0), 0.
      -  eauto with schutte.
    Qed.

    Lemma ksi_plus_beta_eq : ksi + beta = beta.
    Proof.
      apply le_antisym.
      -  apply ksi_plus_beta.
      -  apply le_plus_r;auto.
    Qed.

  End ksi_fixed.

  Lemma AP_unbounded_0 : alpha < beta /\ AP beta.
  Proof.
    split.
    -  apply alpha_lt_beta.
    -  split.
       + apply zero_lt_beta.
       +  intros; apply ksi_plus_beta_eq; eauto with schutte.
  Qed.

End AP_Unbounded.

(* end hide *)

(* begin snippet APUnbounded *)

Theorem AP_unbounded : Unbounded AP. (* .no-out *)
Proof. (* .no-out *)
  intro x.

  exists (omega_limit
            (fix seq (n : nat) : Ord :=
               match n with
               | O => succ x
               | S p => seq p + seq p
               end)). (* .no-out *)
  (* ... *)
  (* end snippet APUnbounded *)
  destruct (AP_unbounded_0 x); now split.
Qed.

(* begin hide *)

Section AP_closed.
  Variable M : Ensemble Ord.
  Hypothesis OM : Included M AP.
  Hypothesis inhM : Inhabited _ M.
  Hypothesis denM : countable M.

  Remark supM_gt0 : zero < |_| M.
  Proof.
    destruct inhM as [x H]; apply lt_le_trans with x.
    -  now  destruct (OM H).
    -  apply sup_upper_bound; auto with schutte.
  Qed.

  Lemma AP_sup : In AP (|_| M).
  Proof.
    split.
    - apply supM_gt0.
    -  intros ksi Hksi;
         destruct (@lt_sup_exists_lt M denM ksi Hksi)
         as [alpha [Malpha ksialpha]].
       apply le_antisym.
       +  rewrite alpha_plus_sup; auto.
          *  apply sup_mono; auto.
             { apply R1 with ordinal (ge ksi); auto.
               - apply plus_ordering; eauto with schutte.
               - split.
             }
             { intros x H; destruct  H as [beta [Mbeta ebeta]].
               case (@lt_or_ge beta alpha);auto with schutte.
               - exists alpha;    split;auto.
                 subst x; case (OM Mbeta).
                 intros H1 H2; right.
                 apply lt_le_trans with (ksi + alpha).
                 + apply plus_mono_r; eauto with schutte.
                 + left.
                   destruct (OM Malpha) as [H3 H4]; now apply H4.
               -  exists beta; split; auto.
                  left; subst x.
                  case (OM Mbeta);  intros H1 H2;  apply H2.
                  apply lt_le_trans with alpha;auto.
             }
       + apply le_plus_r;eauto with schutte.
  Qed.

End AP_closed.

(* end hide *)

(* begin snippet APClosed *)

Theorem AP_closed : Closed AP. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  split.
  -  apply AP_sup;auto.
  -  intros;  apply AP_sup;auto.
Qed.
(*||*)

Theorem AP_o_segment :  the_ordering_segment AP = ordinal. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros;apply segment_unbounded.
  eapply SA2.
  eapply ord_ok;eauto.
  generalize
    (ordering_unbounded_unbounded
       (A:=the_ordering_segment AP)
       (B:=AP)
       (f:=phi0)); intro H.
  generalize (H (ord_ok  AP)); intro H0;  rewrite <- H0.
  now  apply AP_unbounded.
Qed.
(*||*)
(* end snippet APClosed *)

(** ** Properties of [phi0] *)

Theorem normal_phi0 : normal phi0 AP.
Proof.
  apply TH_13_6R with ordinal.
  -  unfold _phi0; rewrite <- AP_o_segment; apply ord_ok.
  - apply AP_closed.
  - apply AP_unbounded.
Qed.

Lemma phi0_ordering :  ordering_function phi0 ordinal AP.
Proof.
  intros;   unfold _phi0; rewrite <- AP_o_segment;
    apply ord_ok.
Qed.

(* begin snippet APPhi0 *)

(*| .. coq:: no-out |*)

Lemma phi0_elim : forall P : (Ord->Ord)->Prop,
    (forall f: Ord->Ord,
        ordering_function f ordinal AP -> P f) ->
    P phi0.
Proof.
  intros P H; apply H, phi0_ordering.
Qed.

Lemma AP_phi0 (alpha : Ord) : In AP (phi0 alpha). (* .no-out *)
Proof. (* .no-out *)
  pattern phi0; apply phi0_elim.
  destruct 1 as [H H0 H1 H2];  apply H0;auto; split.
Qed.

Lemma phi0_zero : phi0 zero =  1. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  generalize (ordering_function_least_least  phi0_ordering),least_AP;
    intros H H0; rewrite (least_member_unicity AX1  H H0);eauto.
Qed.
(*||*)

Lemma phi0_mono (alpha beta : Ord) :
  alpha < beta ->  phi0 alpha < phi0 beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro H; pattern phi0; apply phi0_elim.
  intros;eapply ordering_function_mono;eauto with schutte.
Qed.
(*||*)

Lemma phi0_mono_weak (alpha beta : Ord) :
  alpha <= beta ->  phi0 alpha <= phi0 beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  destruct 1.
  -  subst beta; auto with schutte.
  -  right;apply phi0_mono;auto.
Qed.
(*||*)

Lemma phi0_mono_R (alpha beta : Ord) :
  phi0 alpha < phi0 beta -> alpha < beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  pattern phi0; apply phi0_elim.
  intros;eapply ordering_function_monoR; eauto.
  all : split.
Qed.
(*||*)

Lemma phi0_mono_R_weak (alpha beta: Ord):
    phi0 alpha <= phi0 beta -> alpha <= beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  pattern phi0; apply phi0_elim.
  intros f Hf; eapply ordering_function_mono_weakR;eauto.
  all : split.
Qed.
(*||*)

Lemma phi0_inj (alpha beta : Ord) :
  phi0 alpha = phi0 beta -> alpha = beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros; apply le_antisym; apply phi0_mono_R_weak;auto with schutte.
Qed.
(*||*)

Lemma phi0_positive (alpha : Ord):  zero < phi0 alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros;  apply lt_le_trans with (phi0 zero).
  rewrite phi0_zero; eauto with schutte arith.
  pattern phi0 ; apply phi0_elim.
  intros; eapply ordering_function_mono_weak; eauto with schutte.
Qed.
(*||*)

Lemma plus_lt_phi0 (ksi alpha: Ord):
    ksi < phi0 alpha ->  ksi + phi0 alpha = phi0 alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  pattern (phi0 alpha);  apply phi0_elim;  intros f Hf;
    assert (H: AP (f alpha)).
  {  destruct Hf as [H0 H1 H2 H3].
     apply H1 ; split. }
  destruct H;  auto.
Qed.
(*||*)

Lemma phi0_alpha_phi0_beta (alpha beta: Ord) :
  alpha < beta ->  phi0 alpha + phi0 beta = phi0 beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros.
  apply plus_lt_phi0; eauto with schutte.
  apply phi0_mono.
  auto.
Qed.
(*||*)

Lemma phi0_sup : forall U: Ensemble Ord,
    Inhabited _ U ->
    countable U ->
    phi0 (|_| U) = |_| (image U phi0). (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros U H0 H1;  case normal_phi0.
  destruct 2 as [H2 [H3 H4]]; symmetry; auto.
  apply H4; auto;  split.
Qed.
(*||*)

Lemma phi0_of_limit (alpha : Ord)  :
  is_limit alpha ->
  phi0 alpha = |_| (image (members alpha) phi0). (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro H; pattern alpha at 1; rewrite  (is_limit_sup_members H);
    destruct  normal_phi0 as [H0 H1].
  destruct H1 as [H1 H2] ;symmetry;auto.
  destruct H2 as [H2 H3]; apply H3.
  - intro; split.
  - exists zero; tricho zero alpha HH; auto.
    +  subst alpha; destruct H as [H _]; now destruct H.
    + destruct (not_lt_zero HH).
  - apply countable_members;auto.
Qed.
(*||*)

Lemma AP_to_phi0 (alpha : Ord) :
  AP alpha -> exists beta,  alpha = phi0 beta. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro H; pattern phi0;apply phi0_elim.
  destruct 1 as [H0 H1 H2 H3].
  case (H2 _ H); intros x [_ H4]; exists x; now rewrite H4.
Qed.
(*||*)

Lemma AP_plus_AP (alpha beta gamma : Ord) :
  zero < beta ->
  phi0 alpha + beta = phi0 gamma ->
  alpha < gamma /\  beta = phi0 gamma. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros H H0;  tricho alpha gamma H3.
  -  split;auto.
     tricho beta (phi0 gamma) H4.
     +  case (@lt_irrefl (phi0 gamma)).
        pattern (phi0 gamma) at 1; rewrite <- H0.
        * apply AP_plus_closed; auto.
          apply AP_phi0;  eauto with schutte.
          apply phi0_mono;auto.
     + auto.
     +  rewrite <- H0 in H4;  case (@lt_irrefl beta).
        eapply le_lt_trans;eauto.
        apply le_plus_r.
  -  subst gamma;  case (@lt_irrefl (phi0 alpha)).
     pattern (phi0 alpha) at 2;  rewrite <- H0.
     pattern (phi0 alpha) at 1; rewrite <- alpha_plus_zero.
     apply plus_mono_r;auto.
  - assert(H1 :  phi0 alpha <= phi0 gamma).
    { rewrite <- H0; apply le_plus_l. }
    case (le_not_gt H1);  apply phi0_mono;auto.
Qed.
(*||*)

Lemma is_limit_phi0 (alpha : Ord) :
  zero < alpha ->  is_limit (phi0 alpha). (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros  H; split.
  - intro H0; case (@lt_irrefl zero).
    apply lt_le_trans with alpha;auto.
    rewrite <- H0;  pattern phi0; apply phi0_elim.
    intros f H1; eapply ordering_le; [ eauto |].
    split.
  - intro H0; destruct H0 as [x H0].
    generalize (@AP_phi0 alpha).
    intro H1; destruct H1 as [H1 H2]; rewrite H0 in H2.
    assert (H3 : x < succ x) by auto with schutte.
    generalize (H2 _ H3);  intros H4;
      assert (H5 :zero < x).
    { tricho zero x H8.
      -  auto.
      -  subst x;  replace (succ zero) with (F 1) in H0.
         + rewrite <- phi0_zero in H0.
           case (@lt_irrefl (phi0 zero)).
           pattern (phi0 zero) at 2; rewrite <- H0.
           apply phi0_mono;auto.
         +  simpl;auto.
      -  case (@not_lt_zero x); auto.
    }
    assert (H6 : x < x + x).
    { pattern x at 1;rewrite <- alpha_plus_zero.
      apply plus_mono_r;auto.
    }
    generalize (succ_mono  H6);  rewrite <- H4.
    intros H7; apply lt_irrefl with (succ (x+x));  auto.
    now rewrite plus_of_succ in H7.
Qed.
(*||*)

Lemma omega_eqn : omega = phi0 1. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  destruct (AP_to_phi0 (AP_omega)) as [beta Hbeta]; rewrite Hbeta;
    tricho beta (F 1) H.
  -   destruct (finite_lt_inv 1 H ) as [i [H0 H1]].
      inversion H0.
      +  subst i beta; simpl in Hbeta; rewrite  phi0_zero in Hbeta.
         specialize (finite_lt_omega 1); intro H1; rewrite Hbeta in H1.
         destruct (lt_irrefl H1).
      + inversion H3.
  -  now subst.
  -  specialize (phi0_mono H); intro H0;
       rewrite <- Hbeta in H0.
     specialize (lt_omega_finite H0);intros [i Hi].
     specialize (@is_limit_phi0 (F 1));  intro H2.
     rewrite Hi in H2;   destruct (finite_not_limit i).
     apply H2, lt_succ.
Qed.
(*||*)

Lemma le_phi0 (alpha : Ord) : alpha <= phi0 alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  eapply (@ordering_le  phi0 ordinal AP).
  apply phi0_ordering.
  split.
Qed.
(*||*)
(* end snippet APPhi0 *)

(** ** Properties of [epsilon0] *)

Lemma epsilon0_fxp : phi0 epsilon0 = epsilon0.
Proof.
  unfold epsilon0, omega_limit; rewrite phi0_sup.
  assert (D1: countable (image (seq_range omega_tower) phi0)).
  { exists (fun alpha i =>  alpha = omega_tower i).
    split.
    -  red; destruct 1 as [x [H H0]].
       destruct H as [i [_ H]];   exists (S i);
         cbn; rewrite H; auto.
    - red;  destruct 1;  destruct H;  split.
    -  red; intros; congruence.
  }
  assert (D2: countable (seq_range omega_tower)).
  { apply Countable.seq_range_countable. }
  -  apply le_antisym.
     +  apply sup_mono; trivial.
        * destruct 1 as [x0 [[i [_ H]] H0]].
          exists (phi0 x0); split.
          {  exists (S i); split; auto; simpl; auto ; now f_equal. }
          left; auto.
     + apply sup_mono; trivial.
       intros alpha [i H];  exists (phi0 alpha); split; auto.
       exists alpha; split; auto.
       * exists i; auto.
       * apply le_phi0.
  - exists (phi0 zero), 0; simpl; rewrite phi0_zero; split; auto.
  - apply Countable.seq_range_countable.
Qed.

Lemma epsilon0_AP : AP epsilon0.
Proof.
  rewrite <- epsilon0_fxp;  apply AP_phi0.
Qed.

Lemma omega_tower_mono (i : nat) : omega_tower i < omega_tower (S i).
Proof.
  induction i;  simpl.
  -  rewrite succ_is_plus_1, zero_plus_alpha;
       rewrite <- omega_eqn;   apply finite_lt_omega.
  -  simpl in IHi; now apply phi0_mono.
Qed.

(* begin snippet ltPhi0 *)

Lemma lt_phi0 (alpha : Ord):
  alpha < epsilon0 -> alpha < phi0 alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  unfold epsilon0;  intros H.
  specialize (@omega_limit_least_gt alpha omega_tower omega_tower_mono H);
    intro H0.
  destruct H0 as [i [H0 H1]].
  destruct i as [|j].
  -   red in H0;  simpl in H0;
        assert (H2 : alpha = zero).
      {
        specialize (lt_succ_le_2  _ H0); intro H3; apply le_alpha_zero; auto.
      }
      subst alpha; rewrite phi0_zero; auto.
  - assert (H2 : omega_tower j <= alpha).
    {
      tricho  alpha (omega_tower j) H2.
      -   specialize (H1 _ H2);  assert False
          by (destruct H1; abstract lia); contradiction.
      -   left; auto.
      -   right;auto.
    }
    assert (omega_tower (S j) <= phi0 alpha).
    {   simpl.   now apply phi0_mono_weak. }
    apply lt_le_trans with (omega_tower (S j)); auto.
Qed.
(*||*)
(* end snippet ltPhi0 *)

(* begin snippet epsilon0Lfp *)

Theorem epsilon0_lfp : least_fixpoint lt phi0 epsilon0. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  split.
  - apply epsilon0_fxp.
  - intros alpha H; tricho alpha epsilon0 H0.
    + specialize (lt_phi0 H0); intro H1.
      rewrite  H in H1; destruct (lt_irrefl H1).
    + subst alpha; now left.
    + now right.
Qed.
(*||*)
(* end snippet epsilon0Lfp *)

Lemma phi0_lt_epsilon0 (alpha : Ord) :
  alpha < epsilon0 -> phi0 alpha < epsilon0.
Proof.
  intro; rewrite <- epsilon0_fxp; now apply phi0_mono.
Qed.

Lemma phi0_lt_epsilon0_R (alpha : Ord):
  phi0 alpha < epsilon0  -> alpha < epsilon0.
Proof.
  intro H; rewrite <- epsilon0_fxp in H; now  apply phi0_mono_R.
Qed.


(** * Peano

    ペアノの公理に従った自然数についての定義を行う。 *)

Require Import Basis .

(** 戦術を使う。 *)
Declare ML Module "ltac_plugin".
Set Default Proof Mode "Classic".

(** 記法を使う。 *)
Import Basis.Notation .

(** 自然数。

    ペアノの公理は、最初の自然数と後者関数により自然数を定義するものである。
    標準ライブラリはこれにより自然数を定義していて、このライブラリもこれを
    使う。 *)
Inductive nat : Type
  :=
  | O : nat
  | S : nat -> nat
  .

Definition nat_case_nodep
  {P : Type}
  (case_O : P)
  (case_S : nat -> P)
  (x : nat) : P .
Proof.
 refine (match x with O => _ | S xp => _ end) .
 -
  exact case_O .
 -
  exact (case_S xp) .
Defined.

Definition nat_case
  {P : nat -> Type}
  (case_O : P O)
  (case_S : forall xp, P (S xp))
  (x : nat) : P x .
Proof.
 refine (match x with O => _ | S xp => _ end) .
 -
  exact case_O .
 -
  exact (case_S xp) .
Defined.

Definition nat_rec
  {P : Type}
  (case_O : P)
  (case_S : P -> P)
  (x : nat) : P .
Proof.
 revert x .
 refine (fix go (x : nat) {struct x} : P := _) .
 refine (nat_case_nodep _ _ x) .
 -
  exact case_O .
 -
  refine (fun xp => _) .
  exact (case_S (go xp)) .
Defined.

Definition nat_rect
  {P : nat -> Type}
  (case_O : P O)
  (case_S : forall n, P n -> P (S n))
  (x : nat) : P x .
Proof.
 revert x .
 refine (fix go (x : nat) {struct x} : P x := _) .
 refine (nat_case _ _ x) .
 -
  exact case_O .
 -
  refine (fun xp => _) .
  exact (case_S xp (go xp)) .
Defined.

(** ** Functions *)

(** 後者関数の別名。 *)
Notation succ := S (only parsing) .

(** 前者関数。 [pred O = O] 。 *)
Definition pred : nat -> nat .
Proof.
 refine (nat_case_nodep _ _) .
 -
  exact O .
 -
  exact idmap .
Defined.

(** 加法。 *)
Definition add : nat -> nat -> nat .
Proof.
 refine (fun x => _) .
 refine (nat_rec _ _) .
 -
  exact x .
 -
  exact S .
Defined.

(** 乗法。 *)
Definition mul : nat -> nat -> nat .
Proof.
 refine (fun x => _) .
 refine (nat_rec _ _) .
 -
  exact O .
 -
  exact (add x) .
Defined.

(** 減法。結果が負の値になるときは、ゼロへ丸められる。 *)
Definition sub : nat -> nat -> nat .
Proof.
 refine (fun x => _) .
 refine (nat_rec _ _) .
 -
  exact x .
 -
  exact pred .
Defined.

(** ** Notations

    自然数の記法を定義する。 *)

(** 記法の設定を閉じ込めるモジュール。 *)
Module Notation .

  (** 記法が使われる文脈を設定する。 *)
  Delimit Scope nat_scope with nat.

  (** 文脈を開く。 *)
  Open Scope nat_scope .

  (** 文脈を型と結びつける。 *)
  Bind Scope nat_scope with nat.

  (** 加法の記法。 *)
  Notation "x + y" := (add x y)
    (at level 50, left associativity)
    : nat_scope
    .

  (** 乗法の記法。 *)
  Notation "x * y" := (mul x y)
    (at level 40, left associativity)
    : nat_scope
    .

  (** 減法の記法。 *)
  Notation "x - y" := (sub x y)
    (at level 50, left associativity)
    : nat_scope
    .

End Notation .

(** 参考文献:

    * https://github.com/coq/coq/blob/f4cf212efd98d01a6470ea7bfd1034d52e928906/theories/Init/Notations.v
    * https://github.com/coq/coq/blob/f4cf212efd98d01a6470ea7bfd1034d52e928906/theories/Init/Datatypes.v
    * https://github.com/coq/coq/blob/f4cf212efd98d01a6470ea7bfd1034d52e928906/theories/Init/Nat.v

    *)


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


(* definitie inductiva pentru o multime finita *)
Inductive day :=
  |monday : day
  |tuesday : day
  |wednesday : day
  |thursday : day
  |friday : day
  |saturday : day
  |sunday : day.

Inductive bool :=
  |true : bool
  |false : bool.

(*functii nerecursive*)
Definition equal (d1 d2 : day) : bool :=
  match d1, d2 with
    |monday, monday => true
    |tuesday, tuesday => true
    |wednesday, wednesday => true
    |thursday, thursday => true
    |friday, friday => true
    |saturday, saturday => true
    |sunday, sunday => true
    | _, _ => false
    end.

Definition not (b1 : bool) : bool :=
  match b1 with
    |true => false
    |false => true
  end.

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

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

Eval compute in (not true).
Eval compute in (and true false).
Eval compute in (or true false).

Definition nextDay (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => saturday
  | saturday => sunday
  | sunday => monday
  end.

Eval compute in (equal monday monday).
Eval compute in (equal friday monday).
Eval compute in (nextDay friday).

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

Check natural.
Check O.
Check (S O).
Check (S (S O)).

(* Functii recursive *)
Fixpoint plus (n1 n2 : natural) : natural :=
  match n1 with
    | O => n2
    | S m => S (plus m n2)
  end.

Fixpoint equalNaturals(n1 n2 : natural):bool:=
match n1 with
| O => match n2 with
       | O =>true
       | _ =>false
       end

| S x => match n2 with
          | O => false
          | S y => equalNaturals x y
          end

end.

Eval compute in (plus O (S O)).
Eval compute in (plus (S O) (S O)).
Eval compute in ( equalNaturals  O (S O)).
Eval compute in (equalNaturals O O).
Eval compute in (equalNaturals (S (S O)) (S (S O))).

Lemma a1_equal_a2:
  forall a1 a2,a1=a2 ->equalNaturals (S a1) (S a2)=true.
Proof.
    -induction a1.
      simpl.
      intros a2.
      * induction a2.
        trivial.


(** %\chapter{Encoding Mathematical Structures}% *)

Module DepRecords.

Require Import ssreflect ssrbool ssrnat ssrfun.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Encoding partial commutative monoids *)

Module PCMDef.

(**

We have already seen a use of a dependent pair type, exemplified by
the Coq's definition of the universal quantification.

*)

Print ex.

(**
[[
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex P
]]

*)

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    _ : valid_op unit_op
}.

(**
[[
mixin_of is defined
mixin_of_rect is defined
mixin_of_ind is defined
mixin_of_rec is defined
valid_op is defined
join_op is defined
unit_op is defined
]]
*)

Check valid_op.

(**
[[
valid_op
     : forall T : Type, mixin_of T -> T -> bool
]]
*)

Lemma r_unit T (pcm: mixin_of T) (t: T) : (join_op pcm t (unit_op pcm)) = t.
Proof.
case: pcm=>_ join unit Hc _ Hlu _ _ /=.

(**
[[
  T : Type
  t : T
  join : T -> T -> T
  unit : T
  Hc : commutative join
  Hlu : left_id unit join
  ============================
   join t unit = t
]]
*)

by rewrite Hc Hlu.
Qed.

(** ** An alternative definition *)

Inductive mixin_of' (T: Type) :=
  Mixin' (valid_op: T -> bool) (join_op : T -> T -> T) (unit_op: T) of
    commutative join_op &
    associative join_op &
    left_id unit_op join_op &
    forall x y, valid_op (join_op x y) -> valid_op x &
    valid_op unit_op.

(**

Although this definition seems more principled and is closer to what
we have seen in previous chapters, the record notation is more
convenient in this case, as it defined getters automatically as well
as allows one to express inheritance between data structures by means
of the coercion operator %\texttt{:>}%
operator%~\cite{Garillot-al:TPHOL09}%.%\footnote{In the next section
will show a different way to encode implicit inheritance, though.}%

** Packaging the structure from mixins
%\label{sec:packaging}%

*)

Section Packing.

Structure pack_type : Type := Pack {type : Type; _ : mixin_of type}.

(**

The dependent data structure [pack_type] declares two fields: the
field [type] of type [Type], which described the carrier type of the
PCM instance, and the actual PCM structure (without an explicit name
given) of type [mixin_of type]. That is, in order to construct an
instance of [pack_type], one will have to provide _both_ arguments:
the carrier set and a PCM structure for it.

*)

Local Coercion type : pack_type >-> Sortclass.

(**

Next, in the same section, we provide a number of abbreviations to
simplify the work with the PCM packed structure and prepare it to be
exported by clients.

*)
Variable cT: pack_type.

Definition pcm_struct : mixin_of cT :=
    let: Pack _ c := cT return mixin_of cT in c.

Definition valid := valid_op pcm_struct.
Definition join := join_op pcm_struct.
Definition unit := unit_op pcm_struct.

End Packing.

Module Exports.

Notation pcm := pack_type.
Notation PCMMixin := Mixin.
Notation PCM T m := (@Pack T m).

Notation "x \+ y" := (join x y) (at level 43, left associativity).
Notation valid := valid.
Notation Unit := unit.

Coercion type : pack_type >-> Sortclass.

(** * Properties of partial commutative monoids *)

Section PCMLemmas.
Variable U : pcm.

(**

For instance, the following lemma re-establishes the commutativity of
the [\+] operation:

*)

Lemma joinC (x y : U) : x \+ y = y \+ x.
Proof.
case: U x y=> tp [v j z Cj *]; apply Cj.
Qed.

(**

Notice that in order to make the proof to go through, we had to "push"
the PCM elements [x] and [y] to be the assumption of the goal before
case-analysing on [U]. This is due to the fact that the structure of
[U] affects the type of [x] and [y], therefore destructing it by means
of [case] would change the representation of [x] and [y] as well,
doing some rewriting and simplifications. Therefore, when [U] is being
decomposed, al values, whose type depends on it (i.e., [x] and [y])
should be in the scope of decomposition. The naming pattern [*] helped
us to give automatic names to all remaining assumptions, appearing
from decomposition of [U]'s second component before moving it to the
context before finishing the proof by applying the commutativity
"field" [Cj].

*)

Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
Proof.
by case: U x y z=>tp [v j z Cj Aj *]; apply: Aj.
Qed.

(*******************************************************************)
(**                     * Exercices 1 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [PCM Laws]
---------------------------------------------------------------------

Proove the rest of the PCM laws.
*)

Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
Proof.
by rewrite -!joinA; rewrite (@joinC y z).
Qed.

Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
Proof.
rewrite [y \+ (_ \+ _)]joinC.
rewrite (@joinC y z).
by rewrite joinA.
Qed.

Lemma validL (x y : U) : valid (x \+ y) -> valid x.
Proof.
by case: U x y =>tp [v j z Cj Aj l i w e]; apply: i.
Qed.

Lemma validR (x y : U) : valid (x \+ y) -> valid y.
Proof.
rewrite joinC; apply validL.
Qed.

Lemma unitL (x : U) : (@Unit U) \+ x = x.
Proof.
case: U x =>tp [v j z Cj Aj l i w e]; apply l.
Qed.

Lemma unitR (x : U) : x \+ (@Unit U) = x.
Proof.
rewrite joinC; apply unitL.
Qed.

Lemma valid_unit : valid (@Unit U).
Proof.
case: U => tp [a b c d e f g h]; apply h.
Qed.

(*******************************************************************)
(**                 * End of Exercices 1 *                         *)
(*******************************************************************)

End PCMLemmas.

End Exports.

End PCMDef.

Export PCMDef.Exports.

(** * Implementing inheritance hierarchies

We will now go even further and show how to build hierarchies of
mathematical structures using the same way of encoding inheritance. We
will use a _cancellative PCM_ as a running example.

*)

Module CancelPCM.

Record mixin_of (U : pcm) := Mixin {
  _ : forall a b c: U, valid (a \+ b) -> a \+ b = a \+ c -> b = c
}.

Structure pack_type : Type := Pack {pcmT : pcm; _ : mixin_of pcmT}.

Module Exports.

Notation cancel_pcm := pack_type.
Notation CancelPCMMixin := Mixin.
Notation CancelPCM T m:= (@Pack T m).

Coercion pcmT : pack_type >-> pcm.

Lemma cancel (U: cancel_pcm) (x y z: U):
  valid (x \+ y) -> x \+ y = x \+ z -> y = z.
Proof.
by case: U x y z=>Up [Hc] x y z; apply: Hc.
Qed.

End Exports.
End CancelPCM.

Export CancelPCM.Exports.

Lemma cancelC (U: cancel_pcm) (x y z : U) :
  valid (y \+ x \+ z) -> y \+ x = x \+ z -> y = z.
Proof.
by move/validL; rewrite ![y \+ _]joinC; apply: cancel.
Qed.

(**

* Instantiation and canonical structures

Now, as we have defined a PCM structure along with its specialized
version, a cancellative PCM, it is time to see how to _instantiate_
these abstract definitions with concrete datatypes, i.e., _prove_ the
later ones to be instances of a PCM.

** Defining arbitrary PCM instances

Natural numbers form a PCM, in particular, with addition as a join
operation and zero as a unit element. The validity predicate is
constant true, because the addition of two natural numbers is again a
valid natural number. Therefore, we can instantiate the PCM structure
for [nat] as follows, first by constructing the appropriate mixin.

*)

Definition natPCMMixin :=
  PCMMixin addnC addnA add0n (fun x y => @id true) (erefl _).

Definition NatPCM := PCM nat natPCMMixin.

(**

This definition will indeed work, although, being somewhat
unsatisfactory. For example, assume we want to prove the following
lemma for natural numbers treated as elements of a PCM, which should
trivially follow from the PCM properties of [nat] with addition and
zero:

[[
Lemma add_perm (a b c : nat) : a \+ (b \+ c) = a \+ (c \+ b).
]]

[[
The term "a" has type "nat" while it is expected to have type "PCMDef.type ?135".
]]

*)

Canonical natPCM := PCM nat natPCMMixin.

Print Canonical Projections.

(**
[[
...
nat <- PCMDef.type ( natPCM )
pred_of_mem <- topred ( memPredType )
pred_of_simpl <- topred ( simplPredType )
sig <- sub_sort ( sig_subType )
number <- sub_sort ( number_subType )
...
]]
*)

Lemma cancelNat : forall a b c: nat, true -> a + b = a + c -> b = c.
Proof.
move=> a b c; elim: a=>// n /(_ is_true_true) Hn _ H.
by apply: Hn; rewrite !addSn in H; move/eq_add_S: H.
Qed.

Definition cancelNatPCMMixin := CancelPCMMixin cancelNat.

Canonical cancelNatPCM := CancelPCM natPCM cancelNatPCMMixin.

Print Canonical Projections.

(**

Let us now see the canonical instances in action, so we can prove a
number of lemmas about natural numbers employing the general PCM
machinery.

*)

Section PCMExamples.

Variables a b c: nat.

Goal a \+ (b \+ c) =  c \+ (b \+ a).
by rewrite joinA [c \+ _]joinC [b \+ _]joinC.
Qed.

Goal c \+ a = a \+ b -> c = b.
by rewrite [c \+ _]joinC; apply: cancel.
Qed.

(**

It might look a bit cumbersome, though, to write the PCM join
operation [\+] instead of the boolean addition when specifying the
facts about natural numbers (even though they are treated as elements
of the appropriate PCM). Unfortunately, it is not trivial to encode
the mechanism, which will perform such conversion implicitly. Even
though Coq is capable of figuring out what PCM is necessary for a
particular type (if the necessary canonical instance is defined),
e.g., when seeing [(a b : nat)] being used, it infers the [natPCM],
alas, it's not powerful enough to infer that the by writing the
addition function [+] on natural numbers, we mean the PCM's
join. However, if necessary, in most of the cases the conversion like
this can be done by manual rewriting using the following trivial
"conversion" lemma.

*)

Lemma addn_join (x y: nat): x + y = x \+ y.
Proof. by []. Qed.

End PCMExamples.

(** ** Types with decidable equalities

The module [eqtype] of SSReflect's standard library provides a
definition of the equality mixin and packaged class of the familiar
shape, which, after some simplifications, boil to the following ones:

[[
Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Structure type := Pack {sort; _ : mixin_of sort}.

...

Notation EqMixin := Mixin.
Notation EqType T m := Pack T m.

End Equality.
]]

DEMO: check the corresponding files ssreflect-1.4/theories/eqtype.v
and ssreflect-1.4/theories/ssrnat.v

*)

(*******************************************************************)
(**                     * Exercices 2 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Partially-ordered sets]
---------------------------------------------------------------------

A partially ordered set order is a triple (T, \pre, \bot), such that T
is a carrier set, \pre is a relation on T and \bot is an element of T,
such that

- forall x in T, x \pre x (reflexivity);

- forall x, y in T, x \pre y \wedge y \pre x \implies x = y (antisymmetry);

- forall x, y, z in T, x \pre y \wedge y \pre z \implies x \pre z (transitivity).

Implement a data structure for partially-ordered sets using mixins and
packed classes. Prove the following laws:

Lemma poset_refl (x : T) : x <== x.
Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
*)

(* VERSION 2. pre : A -> A -> Prop *)

Module PosetDef.

Record my_mixin_of (T : Type) := MyMixin {
    pre_op : T -> T -> Prop;
    _ : forall x, pre_op x x;
    _ : forall x y, pre_op x y -> pre_op y x -> x = y;
    _ : forall x y z, pre_op x y -> pre_op y z -> pre_op x z
}.

Section MyPacking.

Structure pack_type : Type := Pack {type : Type; _ : my_mixin_of type}.

Local Coercion type : pack_type >-> Sortclass.

Variable cT: pack_type.

Definition poset_struct : my_mixin_of cT :=
    let: Pack _ c := cT return my_mixin_of cT in c.

Definition pre := pre_op poset_struct.

End MyPacking.

Module Exports.

Notation poset := pack_type.
Notation PosetMixin := MyMixin.
Notation Poset T m := (@Pack T m).

Notation "x <== y" := (pre x y) (at level 43, left associativity).
Notation pre := pre.

Coercion type : pack_type >-> Sortclass.

Section PosetLemmas.
Variable T : poset.

Lemma poset_refl (x : T) : x <== x.
Proof.
case: T x => tm [pre r e i x]; apply r.
Qed.

Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Proof.
case: T x y => tm [pre r e i x y H1 H2].
by apply e.
Qed.

Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
Proof.
case: T x y z => tm [pre r e i x y z H1 H2].
by apply: (i x y z).
Qed.

End PosetLemmas.

End Exports.

End PosetDef.

Export PosetDef.Exports.

(**
---------------------------------------------------------------------
Exercise [Canonical instances of partially ordered sets]
---------------------------------------------------------------------

Provide canonical instances of partially ordered sets for the
following types:

- [nat] and [<=];

- [prod], whose components are posets;

- functions [A -> B], whose codomain (range) [B] is a partially
  ordered set.

In order to provide a canonical instance for functions, you will need
to assume and make use of the following axiom of functional
extensionality:

*)

Require Import ssrnat eqtype.

Lemma leq_antisym : forall x y, x <= y -> y <= x -> x = y.
Proof.
move=> x y H1 H2.
move: (eqn_leq x y) => H.
apply/eqP.
rewrite H.
by apply /andP; split.
Qed.

Definition natPosetMixin :=
  PosetMixin leqnn leq_antisym (fun x y z => @leq_trans y x z).
Definition NatPoset := Poset nat natPosetMixin.
Canonical natPoset := Poset nat natPosetMixin.

Definition prodPre {A B : poset} (x y : A * B): Prop :=
  let: (xa, xb) := x in
  let: (ya, yb) := y in
  pre xa ya /\ pre xb yb.

Lemma prodPreNN {A B : poset} (x : A * B) : prodPre x x.
Proof.
case x=> xa xb; rewrite /prodPre.
split; apply poset_refl.
Qed.

Lemma prodPreAntisym {A B : poset} (x y : A * B): prodPre x y -> prodPre y x -> x = y.
Proof.
case x => xa xb.
case y => ya yb.
rewrite /prodPre.
case => H1 H2.
case => H3 H4.

move: (@poset_asym A xa ya) => H5.
apply H5 in H1.
Focus 2.
done.

move: (@poset_asym B xb yb) => H6.
apply H6 in H4.
Focus 2.
done.

by rewrite H1 H4.
Qed.

Lemma prodPreTrans {A B : poset} (x y z : A * B): prodPre x y -> prodPre y z -> prodPre x z.
Proof.
case x => xa xb.
case y => ya yb.
case z => za zb.
rewrite /prodPre.
case => H1 H2.
case => H3 H4.
split.
- apply: (poset_trans H1 H3).
apply: (poset_trans H2 H4).
Qed.

Definition prodPosetMixin {A B : poset} :=
  PosetMixin prodPreNN (@prodPreAntisym A B) prodPreTrans.

Definition ProdPoset {A B : poset} := Poset (prod A B) prodPosetMixin.
Canonical prodPoset {A B : poset} := Poset (prod A B) prodPosetMixin.

(*
- functions [A -> B], whose codomain (range) [B] is a partially
  ordered set.

In order to provide a canonical instance for functions, you will need
to assume and make use of the following axiom of functional
extensionality:
*)

Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

Definition funcPre {A : Type} {B : poset} (f1 f2 : A -> B): Prop :=
  forall x, pre (f1 x) (f2 x).

Lemma funcPreNN {A : Type} {B : poset} (f : A -> B) : funcPre f f.
Proof.
rewrite /funcPre.
move=> x.
move: (f x) => a.
apply: poset_refl.
Qed.

Lemma funcPreAntisym {A : Type} {B : poset} (x y : A -> B): funcPre x y -> funcPre y x -> x = y.
Proof.
rewrite /funcPre.
move=> H1 H2.
apply fext.
move=> a.
move: (H1 a) (H2 a).
apply: poset_asym.
Qed.

Lemma funcPreTrans {A : Type} {B : poset}
      (x y z : A -> B): funcPre x y -> funcPre y z -> funcPre x z.
Proof.
rewrite /funcPre.
move=> H1 H2.
move=> a.
move: (H1 a) (H2 a).
apply: poset_trans.
Qed.

Definition funcPosetMixin {A : Type} {B : poset} :=
  PosetMixin funcPreNN (@funcPreAntisym A B) funcPreTrans.

Definition FuncPoset {A : Type} {B : poset} := Poset (A -> B) funcPosetMixin.
Canonical funcPoset {A : Type} {B : poset} := Poset (A -> B) funcPosetMixin.

(*******************************************************************)
(**                 * End of Exercices 2 *                         *)
(*******************************************************************)

End DepRecords.