Require Export Parser.Monotonicity.
Require Export Parser.CommonRules.

Lemma monotonic_rule_1_map:
  forall A B (f: A -> B),
    monotonic_rule_1 (map_rule f).
Proof.
  unfold monotonic_rule_1, are_some_are_some_1, is_some_is_some, map_rule;
    repeat light || options || destruct_match.
Qed.

Lemma monotonic_rule_2_disj:
  forall A, monotonic_rule_2 (@disj_rule A).
Proof.
  unfold monotonic_rule_2, are_some_are_some_2, is_some_is_some, disj_rule;
    repeat light || options || destruct_match.
Qed.

Lemma monotonic_rule_2_combine:
  forall A1 A2 A (f: A1 -> A2 -> A), monotonic_rule_2 (combine_rule f).
Proof.
  unfold monotonic_rule_2, are_some_are_some_2, is_some_is_some, combine_rule;
    repeat light || options || destruct_match.
Qed.

Lemma monotonic_rule_1_id:
  forall A, monotonic_rule_1 (@id_rule A).
Proof.
  unfold monotonic_rule_1, are_some_are_some_1, is_some_is_some, combine_rule;
    repeat light || options || destruct_match.
Qed.

Lemma monotonic_rule_2_left:
  forall A1 A2, monotonic_rule_2 (@left_rule A1 A2).
Proof.
  unfold monotonic_rule_2, are_some_are_some_2, is_some_is_some;
    repeat light || options || destruct_match.
Qed.

Lemma monotonic_rule_2_right:
  forall A1 A2, monotonic_rule_2 (@right_rule A1 A2).
Proof.
  unfold monotonic_rule_2, are_some_are_some_2, is_some_is_some;
    repeat light || options || destruct_match.
Qed.

Lemma monotonic_rule_2_some:
  forall A1 A2 A (a: A), monotonic_rule_2 (@some_rule (A1 :: A2 :: nil) A a).
Proof.
  unfold monotonic_rule_2, are_some_are_some_2, is_some_is_some;
    repeat light || options || destruct_match.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.

(* Product Category *)

(** The product of two categories has as objects pairs of objects (first
component from the first category and the second component from the second
category) and as arrows pairs of arrows.
 *)

Local Open Scope morphism_scope.

Local Obligation Tactic := idtac.

Program Definition Prod_Cat (C C' : Category) : Category :=
{|
  Obj := C * C';

  Hom :=
    fun a b =>
      (((fst a) –≻ (fst b)) * ((snd a) –≻ (snd b)))%type;

  compose :=
    fun a b c f g =>
      (((fst g) ∘ (fst f)), ((snd g) ∘ (snd f)))%morphism;

  id := fun c => (id, id)
|}.

Next Obligation.
  cbn.
  intros.
  rewrite (assoc (fst _)).
  rewrite assoc.
  trivial.
Defined.

Next Obligation.
  cbn.
  intros C C' a b c d f g h.
  rewrite (assoc_sym (fst _)).
  rewrite assoc_sym.
  trivial.
Defined.

Next Obligation.
  cbn.
  intros.
  rewrite (id_unit_left (fst _)).
  rewrite id_unit_left.
  trivial.
Defined.

Next Obligation.
  cbn.
  intros.
  rewrite (id_unit_right (fst _)).
  rewrite id_unit_right.
  trivial.
Defined.

Notation "C × D" := (Prod_Cat C D) : category_scope.

Local Obligation Tactic := basic_simpl; auto.

Theorem Prod_compose_id
        (C D : Category)
        (a b c : C) (d : D)
        (f : a –≻ b) (g : b –≻ c)
  : (g ∘ f, id d)%morphism =
    @compose (_ × _) (_, _) (_, _) (_, _) (f, id d) (g, id d).
Proof.
  cbn; auto.
Qed.

Theorem Prod_id_compose
        (C D : Category)
        (a : C) (b c d : D)
        (f : b –≻ c) (g : c –≻ d)
  : (id a, g ∘ f)%morphism =
    @compose (_ × _) (_, _) (_, _) (_, _) (id a, f) (id a, g).
Proof.
  cbn; auto.
Qed.

Theorem Prod_cross_compose
        (C D : Category)
        (a b : C) (c d : D)
        (f : a –≻ b) (g : c –≻ d)
  : @compose
      (_ × _) (_, _) (_, _) (_, _)
      (@id _ a, g) (f, @id _ d)
    = @compose
        (_ × _) (_, _) (_, _) (_, _)
        (f, @id _ c) (@id _ b, g)
.
Proof.
  cbn; auto.
Qed.

Program Definition Cat_Proj1
        (C C' : Category) :
  ((C × C') –≻ C)%functor
  :=
    {|FO := fst; FA := fun _ _ f => fst f|}
.

Program Definition Cat_Proj2
        (C C' : Category) :
  ((C × C') –≻ C')%functor
  :=
    {|FO := snd; FA := fun _ _ f => snd f|}
.


From CoLoR Require Import more_list decidable_set list_set.
From Coq Require Import List Lia FunInd.
From Coq Require Recdef.

Module Type S.
  Parameter A : Type.
End S.

Module Make(AX:S)(X:decidable_set.ES with Definition A:=AX.A with Definition eq_A:=@eq AX.A).

  Module XSet :=  list_set.Make(X).

  Import XSet.
  Import X.
  Import AX.

  Lemma mem_bool_app :
    forall x l1 l2,
       (mem_bool eq_bool x (l1++l2)) = orb (mem_bool eq_bool x l1) (mem_bool eq_bool x l2).
  Proof.
    intros x l1.
    functional induction (mem_bool eq_bool x l1).

    simpl;reflexivity.
    simpl.
    intros l2;rewrite IHb0. auto with bool.
  Qed.

  Section S.
    Hypothesis order : A -> A -> bool.

    Function split (l : list A) (x: A) {struct l} : list A * list A   :=
      match l with
        | nil => (nil,nil)
        | y::l' =>
          let (l1,l2) := split l' x in
            if order y x
              then (y::l1,l2)
              else (l1,y::l2)
      end.

    Lemma split_length :
      forall x l,
        let (l1,l2) := split l x in
          List.length l1 + List.length l2 = List.length l.
    Proof.
      clear.
      intros x l.
      functional induction (split l x).
      reflexivity.
      simpl.
      rewrite e0 in IHp. lia.
      simpl;rewrite e0 in IHp. lia.
    Qed.
    Import Recdef.
    Function qs (l:list A) {measure length } : list A :=
      match l with
        | nil => nil
        | x::l' =>
          let (l1,l2) := split l' x in
            (qs l1)++x::(qs l2)
      end.
    Proof.
      abstract(intros;generalize (split_length x l');
        rewrite teq0;  simpl;  intros; lia).
      abstract(intros;generalize (split_length x l');
        rewrite teq0;  simpl;  intros; lia).
    Defined.

    Lemma split_mem_bool :
      forall x y l l1 l2, split l x = (l1,l2) ->
        mem_bool eq_bool y l = orb (mem_bool eq_bool y l1) (mem_bool eq_bool y l2).
    Proof.
      intros x y l;
        functional induction (split l x);
          intros l1' l2' H;injection H;clear H;intros h1 h2;subst;simpl.
      reflexivity.
      rewrite IHp with (1:=e0);auto with bool.
      rewrite IHp with (1:=e0);auto with bool.
      case (eq_bool y y0);case (mem_bool eq_bool y l1'); case (mem_bool eq_bool y l2);
        reflexivity.
    Qed.

    Lemma qs_valid : forall f l,
      more_list.mem_bool eq_bool f l = more_list.mem_bool eq_bool f (qs l).
    Proof.
      intros f l.
      functional induction (qs l).
      reflexivity.
      simpl.
      rewrite mem_bool_app.
      simpl.
      rewrite <- IHl0.
      rewrite <- IHl1.
      rewrite split_mem_bool with (1:=e0).
      case (eq_bool f x);case (mem_bool eq_bool f l1); case (mem_bool eq_bool f l2);
        reflexivity.
    Qed.
  End S.

  Lemma change_in :
    forall order f l,
      In f l ->
      more_list.mem_bool eq_bool f (qs order (remove_red l)) = true.
  Proof.
    intros order f l H.
    apply (more_list.in_impl_mem (@eq A)
     (fun a => eq_refl a)) in H.
     apply XSet.remove_red_included in H.
     generalize (more_list.mem_bool_ok _ _ eq_bool_ok f (remove_red l)).
     case_eq (more_list.mem_bool eq_bool f (remove_red l)).
     clear H;intros H _.
     2:clear -H;intros _ abs;contradiction.
     rewrite (qs_valid order) in H.
     exact H.
   Qed.
End Make.


From RelationalCalculus Require Export Basic_Notations1.
Require Import Logic.FunctionalExtensionality.
Require Import Logic.Classical_Prop.
Require Import Logic.IndefiniteDescription.
Require Import Logic.ProofIrrelevance.

(** %
\section{定義}
この章では, 関係を集合論的に定義した場合の定義, およびその定義で諸公理が成立することを示す. 公理名や記号などは \verb|Basic_Notations| と同じものを使用する.
% **)

Module Rel_Set <: Relation.

Definition Rel (A B : eqType) := A -> B -> Prop.

Definition inverse {A B : eqType} (alpha : Rel A B) : Rel B A
 := (fun (b : B)(a : A) => alpha a b).
Notation "a #" := (inverse a) (at level 20).
Definition composite {A B C : eqType} (alpha : Rel A B) (beta : Rel B C) : Rel A C
 := (fun (a : A)(c : C) => exists b : B, alpha a b /\ beta b c).
Notation "a '・' b" := (composite a b) (at level 50).
Definition residual {A B C : eqType} (alpha : Rel A B) (beta : Rel B C) : Rel A C
 := (fun (a : A)(c : C) => forall b : B, alpha a b -> beta b c).
Notation "a '△' b" := (residual a b) (at level 50).

Definition identity (A : eqType) : Rel A A := (fun a a0 : A => a = a0).
Notation "'Id'" := identity.
Definition empty (A B : eqType) : Rel A B := (fun (a : A)(b : B) => False).
Notation "'φ'" := empty.
Definition universal (A B : eqType) : Rel A B := (fun (a : A)(b : B) => True).
Notation "'∇'" := universal.

Definition include {A B : eqType} (alpha beta : Rel A B) : Prop
 := (forall (a : A)(b : B), alpha a b -> beta a b).
Notation "a '⊆' b" := (include a b) (at level 50).

Definition cupP {A B C D : eqType} (P : Rel C D -> Prop) (f : Rel C D -> Rel A B) : Rel A B
 := (fun (a : A)(b : B) => exists alpha : Rel C D, P alpha /\ (f alpha) a b).
Notation "'∪_{' p '}'  f" := (cupP p f) (at level 50).
Definition capP {A B C D : eqType} (P : Rel C D -> Prop) (f : Rel C D -> Rel A B) : Rel A B
 := (fun (a : A)(b : B) => forall alpha : Rel C D, P alpha -> (f alpha) a b).
Notation "'∩_{' p '}'  f" := (capP p f) (at level 50).

Definition cup {A B : eqType} (alpha beta : Rel A B)
 := ∪_{fun gamma : Rel A B => gamma = alpha \/ gamma = beta} id.
Notation "a '∪' b" := (cup a b) (at level 50).
Definition cap {A B : eqType} (alpha beta : Rel A B)
 := ∩_{fun gamma : Rel A B => gamma = alpha \/ gamma = beta} id.
Notation "a '∩' b" := (cap a b) (at level 50).
Definition rpc {A B : eqType} (alpha beta : Rel A B) : Rel A B
 := (fun (a : A)(b : B) => alpha a b -> beta a b).
Notation "a '>>' b" := (rpc a b) (at level 50).
Definition complement {A B : eqType} (alpha : Rel A B) := alpha >> φ A B.
Notation "a '^'" := (complement a) (at level 20).
Definition difference {A B : eqType} (alpha beta : Rel A B) := alpha ∩ beta ^.
Notation "a -- b" := (difference a b) (at level 50).

Notation "'i'" := unit_eqType.

(** %
\section{関数の定義}
% **)
Definition total_r {A B : eqType} (alpha : Rel A B) := (Id A) ⊆ (alpha ・ alpha #).
Definition univalent_r {A B : eqType} (alpha : Rel A B) := (alpha # ・ alpha) ⊆ (Id B).
Definition function_r {A B : eqType} (alpha : Rel A B)
 := (total_r alpha) /\ (univalent_r alpha).
Definition surjection_r {A B : eqType} (alpha : Rel A B)
 := (function_r alpha) /\ (total_r (alpha #)).
Definition injection_r {A B : eqType} (alpha : Rel A B)
 := (function_r alpha) /\ (univalent_r (alpha #)).
Definition bijection_r {A B : eqType} (alpha : Rel A B)
 := (function_r alpha) /\ (total_r (alpha #)) /\ (univalent_r (alpha #)).

(** %
\section{関係の公理}
今後の諸定理の証明は, 原則以下の公理群, およびそれらから導かれる補題のみを用いて行っていくことにする.
% **)

(** %
\subsection{Dedekind 圏の公理}
\begin{screen}
\begin{lemma}[comp\_id\_l, comp\_id\_r]
Let $\alpha :A \rel B$. Then,
$$
id_A \cdot \alpha = \alpha \cdot id_B = \alpha.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom1a := forall (A B : eqType)(alpha : Rel A B), Id A ・ alpha = alpha.
Lemma comp_id_l : axiom1a.
Proof.
move => A B alpha.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split.
elim => a0.
elim => H H0.
rewrite H.
apply H0.
move => H.
exists a.
split.
by [].
apply H.
Qed.

Definition axiom1b :=  forall (A B : eqType)(alpha : Rel A B), alpha ・ Id B = alpha.
Lemma comp_id_r : axiom1b.
Proof.
move => A B alpha.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split.
elim => b0.
elim => H H0.
rewrite -H0.
apply H.
move => H.
exists b.
split.
apply H.
by [].
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_assoc]
Let $\alpha :A \rel B$, $\beta :B \rel C$, and $\gamma :C \rel D$. Then,
$$
(\alpha \cdot \beta) \cdot \gamma = \alpha \cdot (\beta \cdot \gamma).
$$
\end{lemma}
\end{screen}
% **)
Definition axiom2 :=
 forall (A B C D : eqType)(alpha : Rel A B)(beta : Rel B C)(gamma : Rel C D),
 (alpha ・ beta) ・ gamma = alpha ・ (beta ・ gamma).
Lemma comp_assoc : axiom2.
Proof.
move => A B C D alpha beta gamma.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => d.
apply prop_extensionality_ok.
split.
elim => c.
elim => H H0.
elim H => b H1.
exists b.
split.
apply H1.
exists c.
split.
apply H1.
apply H0.
elim => b.
elim => H.
elim => c H0.
exists c.
split.
exists b.
split.
apply H.
apply H0.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_refl]
Let $\alpha :A \rel B$. Then,
$$
\alpha \sqsubseteq \alpha.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom3 := forall (A B : eqType)(alpha : Rel A B), alpha ⊆ alpha.
Lemma inc_refl : axiom3.
Proof.
by [rewrite /axiom3/include].
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_trans]
Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
\alpha \sqsubseteq \beta \land \beta \sqsubseteq \gamma \Rightarrow \alpha \sqsubseteq \gamma.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom4 := forall (A B : eqType)(alpha beta gamma : Rel A B),
 alpha ⊆ beta -> beta ⊆ gamma -> alpha ⊆ gamma.
Lemma inc_trans : axiom4.
Proof.
move => A B alpha beta gamma H H0 a b H1.
apply (H0 _ _ (H _ _ H1)).
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_antisym]
Let $\alpha , \beta :A \rel B$. Then,
$$
\alpha \sqsubseteq \beta \land \beta \sqsubseteq \alpha \Rightarrow \alpha = \beta.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom5 := forall (A B : eqType)(alpha beta : Rel A B),
 alpha ⊆ beta -> beta ⊆ alpha -> alpha = beta.
Lemma inc_antisym : axiom5.
Proof.
move => A B alpha beta H H0.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split.
apply H.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_empty\_alpha]
Let $\alpha :A \rel B$. Then,
$$
\phi_{AB} \sqsubseteq \alpha.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom6 := forall (A B : eqType)(alpha : Rel A B), φ A B ⊆ alpha.
Lemma inc_empty_alpha : axiom6.
Proof.
move => A B alpha a b.
apply False_ind.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_alpha\_universal]
Let $\alpha :A \rel B$. Then,
$$
\alpha \sqsubseteq \nabla_{AB}.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom7 := forall (A B : eqType)(alpha : Rel A B), alpha ⊆ ∇ A B.
Lemma inc_alpha_universal : axiom7.
Proof.
move => A B alpha a b H.
apply I.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_capP, inc\_cap]
\begin{verbatim}
\end{verbatim}
\begin{enumerate}
\item {\bf inc\_capP :} Let $\alpha :A \rel B$, $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
\alpha \sqsubseteq (\sqcap_{P(\beta)} f(\beta)) \Leftrightarrow \forall \beta :C \rel D, P(\beta) \Rightarrow \alpha \sqsubseteq f(\beta).
$$
\item {\bf inc\_cap :} Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
\alpha \sqsubseteq (\beta \sqcap \gamma) \Leftrightarrow \alpha \sqsubseteq \beta \land \alpha \sqsubseteq \gamma.
$$
\end{enumerate}
\end{lemma}
\end{screen}
% **)
Definition axiom8a :=
 forall (A B C D : eqType)
 (alpha : Rel A B)(f : Rel C D -> Rel A B)(P : Rel C D -> Prop),
 alpha ⊆ (∩_{P} f) <-> forall beta : Rel C D, P beta -> alpha ⊆ f beta.
Lemma inc_capP : axiom8a.
Proof.
move => A B C D alpha f P.
split; move => H.
move => beta H0 a b H1.
apply (H _ _ H1 _ H0).
move => a b H0 beta H1.
apply (H _ H1 _ _ H0).
Qed.
Definition axiom8b := forall (A B : eqType)(alpha beta gamma : Rel A B),
 alpha ⊆ (beta ∩ gamma) <-> (alpha ⊆ beta) /\ (alpha ⊆ gamma).
Lemma inc_cap : axiom8b.
Proof.
move => A B alpha beta gamma.
rewrite inc_capP.
split; move => H.
split; apply H.
by [left].
by [right].
move => delta H0.
case H0 => H1; rewrite H1; apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_cupP, inc\_cup]
\begin{verbatim}
\end{verbatim}
\begin{enumerate}
\item {\bf inc\_cupP :} Let $\alpha :A \rel B$, $f:(C \rel D) \to (A \rel B)$ and $P$ : predicate. Then,
$$
(\sqcup_{P(\beta)} f(\beta)) \sqsubseteq \alpha \Leftrightarrow \forall \beta :C \rel D, P(\beta) \Rightarrow f(\beta) \sqsubseteq \alpha.
$$
\item {\bf inc\_cup :} Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
(\beta \sqcup \gamma) \sqsubseteq \alpha \Leftrightarrow \beta \sqsubseteq \alpha \land \gamma \sqsubseteq \alpha.
$$
\end{enumerate}
\end{lemma}
\end{screen}
% **)
Definition axiom9a :=
 forall (A B C D : eqType)
 (alpha : Rel A B)(f : Rel C D -> Rel A B)(P : Rel C D -> Prop),
 (∪_{P} f) ⊆ alpha <-> forall beta : Rel C D, P beta -> f beta ⊆ alpha.
Lemma inc_cupP : axiom9a.
Proof.
move => A B C D alpha f P.
split.
move => H beta H0 a b H1.
apply H.
exists beta.
split.
apply H0.
apply H1.
move => H a b.
elim => beta.
elim => H0 H1.
apply (H beta H0 _ _ H1).
Qed.
Definition axiom9b := forall (A B : eqType)(alpha beta gamma : Rel A B),
 (beta ∪ gamma) ⊆ alpha <-> (beta ⊆ alpha) /\ (gamma ⊆ alpha).
Lemma inc_cup : axiom9b.
Proof.
move => A B alpha beta gamma.
rewrite inc_cupP.
split; move => H.
split; apply H.
by [left].
by [right].
move => delta H0.
case H0 => H1; rewrite H1; apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_rpc]
Let $\alpha , \beta , \gamma :A \rel B$. Then,
$$
\alpha \sqsubseteq (\beta \Rightarrow \gamma) \Leftrightarrow (\alpha \sqcap \beta) \sqsubseteq \gamma.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom10 := forall (A B : eqType)(alpha beta gamma : Rel A B),
 alpha ⊆ (beta >> gamma) <-> (alpha ∩ beta) ⊆ gamma.
Lemma inc_rpc : axiom10.
Proof.
move => A B alpha beta gamma.
split; move => H.
move => a b H0.
apply H.
apply H0.
by [left].
apply H0.
by [right].
move => a b H0 H1.
apply H.
move => delta.
case => H2; rewrite H2.
apply H0.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[inv\_invol]
Let $\alpha :A \rel B$. Then,
$$
(\alpha^\sharp)^\sharp = \alpha.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom11 := forall (A B : eqType)(alpha : Rel A B), (alpha #) # = alpha.
Lemma inv_invol : axiom11.
Proof.
by [move => A B alpha].
Qed.

(** %
\begin{screen}
\begin{lemma}[comp\_inv]
Let $\alpha :A \rel B$ and $\beta :B \rel C$. Then,
$$
(\alpha \cdot \beta)^\sharp = \beta^\sharp \cdot \alpha^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom12 := forall (A B C : eqType)(alpha : Rel A B)(beta : Rel B C),
 (alpha ・ beta) # = (beta # ・ alpha #).
Lemma comp_inv : axiom12.
Proof.
move => A B C alpha beta.
apply functional_extensionality.
move => c.
apply functional_extensionality.
move => a.
apply prop_extensionality_ok.
split; elim => b.
elim => H H0.
exists b.
split.
apply H0.
apply H.
elim => H H0.
exists b.
split.
apply H0.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_inv]
Let $\alpha , \beta :A \rel B$. Then,
$$
\alpha \sqsubseteq \beta \Rightarrow \alpha^\sharp \sqsubseteq \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom13 :=
 forall (A B : eqType)(alpha beta : Rel A B), alpha ⊆ beta -> alpha # ⊆ beta #.
Lemma inc_inv : axiom13.
Proof.
move => A B alpha beta H b a H0.
apply (H _ _ H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[dedekind]
Let $\alpha :A \rel B$, $\beta :B \rel C$, and $\gamma :A \rel C$. Then,
$$
(\alpha \cdot \beta) \sqcap \gamma \sqsubseteq (\alpha \sqcap (\gamma \cdot \beta^\sharp)) \cdot (\beta \sqcap (\alpha^\sharp \cdot \gamma)).
$$
\end{lemma}
\end{screen}
% **)
Definition axiom14 :=
 forall (A B C : eqType)(alpha : Rel A B)(beta : Rel B C)(gamma : Rel A C),
 ((alpha ・ beta) ∩ gamma)
 ⊆ ((alpha ∩ (gamma ・ beta #)) ・ (beta ∩ (alpha # ・ gamma))).
Lemma dedekind : axiom14.
Proof.
move => A B C alpha beta gamma a c H.
assert (exists b : B, alpha a b /\ beta b c).
apply H.
by [left].
elim H0 => b.
elim => H1 H2.
exists b.
repeat split.
move => delta H3.
case H3 => H4; rewrite H4.
apply H1.
unfold id.
exists c.
split.
apply H.
by [right].
apply H2.
move => delta H3.
case H3 => H4; rewrite H4.
apply H2.
unfold id.
exists a.
split.
apply H1.
apply H.
by [right].
Qed.

(** %
\begin{screen}
\begin{lemma}[inc\_residual]
Let $\alpha :A \rel B$, $\beta :B \rel C$, and $\gamma :A \rel C$. Then,
$$
\gamma \sqsubseteq (\alpha \rhd \beta) \Leftrightarrow \alpha^\sharp \cdot \gamma \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom15 :=
 forall (A B C : eqType)(alpha : Rel A B)(beta : Rel B C)(gamma : Rel A C),
 gamma ⊆ (alpha △ beta) <-> (alpha # ・ gamma) ⊆ beta.
Lemma inc_residual : axiom15.
Proof.
move => A B C alpha beta gamma.
split; move => H.
move => b c.
elim => a H0.
apply (H a).
apply H0.
apply H0.
move => a c H0 b H1.
apply H.
exists a.
split.
apply H1.
apply H0.
Qed.

(** %
\subsection{排中律}
\begin{screen}
Dedekind 圏の公理のほかに, 以下の ``排中律'' を仮定すれば, 与えられる圏は Schr$\ddot{\mbox{o}}$der 圏となり, Bool 代数の性質も満たされる. ちなみに剰余合成は補関係から定義可能なので, 本来 Schr$\ddot{\mbox{o}}$der 圏には剰余合成に関する公理は存在しない.
\begin{lemma}[complement\_classic]
Let $\alpha :A \rel B$. Then,
$$
\alpha \sqcup \alpha^- = \nabla_{AB}
$$
\end{lemma}
\end{screen}
% **)
Definition axiom16 := forall (A B : eqType)(alpha : Rel A B),
 alpha ∪ alpha ^ = ∇ A B.
Lemma complement_classic : axiom16.
Proof.
move => A B alpha.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split; move => H.
apply I.
case (classic (alpha a b)) => H0.
exists alpha.
split.
by [left].
apply H0.
exists (fun (a0 : A) (b0 : B) => alpha a0 b0 -> False).
split.
by [right].
apply H0.
Qed.

(** %
\subsection{単域}
\begin{screen}
1 点集合 $I$ が単域となるための条件は
$$
\phi_{II} \neq id_I \land id_I = \nabla_{II} \land \forall X, \nabla_{XI} \cdot \nabla_{IX} = \nabla_{XX}
$$
だが, Rel の定義から左 2 つは証明できるため, 右の式だけ仮定する.
\begin{lemma}[unit\_universal]
$$
\nabla_{AI} \cdot \nabla_{IA} = \nabla_{AA}
$$
\end{lemma}
\end{screen}
% **)
Definition axiom17 := forall (A : eqType), ∇ A i ・ ∇ i A = ∇ A A.
Lemma unit_universal : axiom17.
Proof.
move => A.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => a0.
apply prop_extensionality_ok.
split; move => H.
apply I.
exists tt.
by [].
Qed.

(** %
\subsection{選択公理}
\begin{screen}
この ``選択公理'' を仮定すれば, 排中律と単域の存在(厳密には全域性公理)を利用して点公理を導出できる. 証明には集合論の選択公理を用いる.
\begin{lemma}[axiom\_of\_choice]
Let $\alpha :A \rel B$ be a total relation. Then,
$$
\exists \beta :A \to B, \beta \sqsubseteq \alpha.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom18 := forall (A B : eqType)(alpha : Rel A B),
 total_r alpha -> exists beta : Rel A B, function_r beta /\ beta ⊆ alpha.
Lemma axiom_of_choice : axiom18.
Proof.
move => A B alpha.
rewrite /function_r/total_r/univalent_r/identity/include/composite/inverse.
move => H.
assert (forall a : A, {b : B | alpha a b}).
move => a.
apply constructive_indefinite_description.
move : (H a a (Logic.eq_refl a)).
elim => b H0.
exists b.
apply H0.
exists (fun (a : A)(b : B) => b = sval (X a)).
repeat split.
move => a a0 H0.
exists (sval (X a)).
by [rewrite H0].
move => b b0.
elim => a.
elim => H0 H1.
by [rewrite H0 H1].
move => a b H0.
rewrite H0.
apply proj2_sig.
Qed.

(** %
\subsection{関係の有理性}
\begin{screen}
集合の選択公理(\verb|Logic.IndefiniteDescription|)や証明の一意性 \\
(\verb|Logic.ProofIrrelevance|)を仮定すれば, 集合論上ならごり押しで証明できる. \\
旧ライブラリの頃は無理だと諦めて Axiom を追加していたが, Standard Library のインポートだけで解けた. 正直びっくり.
\begin{lemma}[rationality]
Let $\alpha :A \rel B$. Then,
$$
\exists R, \exists f:R \to A, \exists g:R \to B, \alpha = f^\sharp \cdot g \land f \cdot f^\sharp \sqcap g \cdot g^\sharp = id_R.
$$
\end{lemma}
\end{screen}
% **)

(** %
\hrulefill \\
この付近は, ごり押しのための補題. 命題の真偽を選択公理で bool 値に変換したり, 部分集合の元から上位集合の元を生成する \verb|sval| (\verb|proj1_sig|) の単射性を示したりしている.
% **)

Lemma is_true_inv0 : forall P : Prop, exists b : bool, P <-> is_true b.
Proof.
move => P.
case (classic P); move => H.
exists true.
split; move => H0.
by [].
apply H.
exists false.
split; move => H0.
apply False_ind.
apply (H H0).
discriminate H0.
Qed.
Definition is_true_inv : Prop -> bool.
move => P.
move : (is_true_inv0 P) => H.
apply constructive_indefinite_description in H.
apply H.
Defined.
Lemma is_true_id : forall P : Prop, is_true (is_true_inv P) <-> P.
Proof.
move => P.
unfold is_true_inv.
move : (constructive_indefinite_description (fun b : bool => P <-> is_true b) (is_true_inv0 P)) => x0.
apply (@sig_ind bool (fun b => (P <-> is_true b)) (fun y => is_true (let (x, _) := y in x) <-> P)).
move => x H.
apply iff_sym.
apply H.
Qed.
Lemma sval_inv : forall (A : Type)(P : A -> Prop)(x : sig P)(a : A), a = sval x -> exists (H : P a), x = exist P a H.
Proof.
move => A P x a H0.
rewrite H0.
exists (proj2_sig x).
apply (@sig_ind A P (fun y => y = exist P (sval y) (proj2_sig y))).
move => a0 H.
by [simpl].
Qed.
Lemma sval_injective : forall (A : Type)(P : A -> Prop)(x y : sig P), sval x = sval y -> x = y.
Proof.
move => A P x y H.
move : (sval_inv A P y (sval x) H).
elim => H0 H1.
rewrite H1.
assert (H0 = proj2_sig x).
apply proof_irrelevance.
rewrite H2.
apply (@sig_ind A P (fun y => y = exist P (sval y) (proj2_sig y))).
move => a0 H3.
by [simpl].
Qed.
(** %
\hrulefill
% **)

Definition axiom19 := forall (A B : eqType)(alpha : Rel A B),
 exists (R : eqType)(f : Rel R A)(g : Rel R B),
 function_r f /\ function_r g /\ alpha = f # ・ g /\ ((f ・ f #) ∩ (g ・ g #)) = Id R.
Lemma rationality : axiom19.
Proof.
move => A B alpha.
rewrite /function_r/total_r/univalent_r/cap/capP/identity/composite/inverse/include.
exists (sig_eqType (fun x : prod_eqType A B => is_true_inv (alpha (fst x) (snd x)))).
exists (fun x a => a = (fst (sval x))).
exists (fun x b => b = (snd (sval x))).
simpl.
repeat split.
move => x x0 H.
exists (fst (sval x)).
repeat split.
by [rewrite H].
move => a a0.
elim => x.
elim => H H0.
by [rewrite H H0].
move => x x0 H.
exists (snd (sval x)).
repeat split.
by [rewrite H].
move => b b0.
elim => x.
elim => H H0.
by [rewrite H H0].
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split; move => H.
assert (is_true (is_true_inv (alpha (fst (a,b)) (snd (a,b))))).
simpl.
apply is_true_id.
apply H.
exists (exist (fun x => (is_true (is_true_inv (alpha (fst x) (snd x))))) (a,b) H0).
by [simpl].
elim H => x.
elim => H0 H1.
rewrite H0 H1.
apply is_true_id.
apply (@sig_ind (A * B) (fun x => is_true (is_true_inv (alpha (fst x) (snd x)))) (fun x => is_true (is_true_inv (alpha (fst (sval x)) (snd (sval x)))))).
simpl.
by [move => x0].
apply functional_extensionality.
move => y.
apply functional_extensionality.
move => y0.
apply prop_extensionality_ok.
split; move => H.
apply sval_injective.
move : (H (fun a c : {x : A * B | is_true (is_true_inv (alpha (fst x) (snd x)))} => exists b : A, b = fst (sval a) /\ b = fst (sval c)) (or_introl Logic.eq_refl)).
move : (H (fun a c : {x : A * B | is_true (is_true_inv (alpha (fst x) (snd x)))} => exists b : B, b = snd (sval a) /\ b = snd (sval c)) (or_intror Logic.eq_refl)).
unfold id.
clear H.
elim => b.
elim => H H0.
elim => a.
elim => H1 H2.
rewrite (surjective_pairing (sval y0)) -H0 -H2 H H1.
apply surjective_pairing.
rewrite H.
move => beta H0.
case H0 => H1; rewrite H1; unfold id.
exists (fst (sval y0)).
repeat split.
exists (snd (sval y0)).
repeat split.
Qed.

(** %
\subsection{直和と直積}
\begin{screen}
任意の直和に対して, 入射対が存在することを仮定する.
\begin{lemma}[pair\_of\_inclusions]
$\exists j:A \to A+B, \exists k:B \to A+B,$
$$
j \cdot j^\sharp = id_A \land k \cdot k^\sharp = id_B \land j \cdot k^\sharp = \phi_{AB} \land j^\sharp \cdot j \sqcup k^\sharp \cdot k = id_{A+B}.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom20 :=
 forall (A B : eqType), exists (j : Rel A (sum_eqType A B))(k : Rel B (sum_eqType A B)),
 j ・ j # = Id A /\ k ・ k # = Id B /\ j ・ k # = φ A B /\
 (j # ・ j) ∪ (k # ・ k) = Id (sum_eqType A B).
Lemma pair_of_inclusions : axiom20.
Proof.
move => A B.
exists (fun (a : A)(x : sum_eqType A B) => x = inl a).
exists (fun (b : B)(x : sum_eqType A B) => x = inr b).
repeat split.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => a0.
apply prop_extensionality_ok.
split; move => H.
elim H => x.
elim => H0 H1.
rewrite H0 in H1.
by [injection H1].
exists (inl a).
repeat split.
by [rewrite H].
apply functional_extensionality.
move => b.
apply functional_extensionality.
move => b0.
apply prop_extensionality_ok.
split; move => H.
elim H => x.
elim => H0 H1.
rewrite H0 in H1.
by [injection H1].
exists (inr b).
repeat split.
by [rewrite H].
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split; move => H.
elim H => x.
elim => H0 H1.
rewrite H0 in H1.
discriminate H1.
apply False_ind.
apply H.
apply functional_extensionality.
move => x.
apply functional_extensionality.
move => x0.
apply prop_extensionality_ok.
split.
elim => alpha.
elim => H0 H1.
case H0 => H2; rewrite H2 in H1.
elim H1 => a.
elim => H3 H4.
by [rewrite H3 H4].
elim H1 => b.
elim => H3 H4.
by [rewrite H3 H4].
assert ((exists a : A, x = inl a) \/ (exists b : B, x = inr b)).
move : x.
apply sum_ind.
move => a.
left.
by [exists a].
move => b.
right.
by [exists b].
case H.
elim => a H0 H1.
exists (fun x x0 => exists a0 : A, (x = inl a0 /\ x0 = inl a0)).
split.
by [left].
exists a.
by [rewrite -H1 H0].
elim => b H0 H1.
exists (fun x x0 => exists b0 : B, (x = inr b0 /\ x0 = inr b0)).
split.
by [right].
exists b.
by [rewrite -H1 H0].
Qed.

(** %
\begin{screen}
任意の直積に対して, 射影対が存在することを仮定する. \\
実は有理性公理(Axiom 19)があれば直積の公理は必要ないのだが, Axiom 19 の準用では直積が ``存在する'' ことまでしか示してくれないので, ``直積として \verb|prod_eqType A B| を用いてよい'' ことを公理の中に含めたものを用意しておく.
\begin{lemma}[pair\_of\_projections]
$\exists p:A \times B \to A, \exists q:A \times B \to B,$
$$
p^\sharp \cdot q = \nabla_{AB} \land p \cdot p^\sharp \sqcap q \cdot q^\sharp = id_{A \times B}.
$$
\end{lemma}
\end{screen}
% **)
Definition axiom21 :=
 forall (A B : eqType), exists (p : Rel (prod_eqType A B) A)(q : Rel (prod_eqType A B) B),
 p # ・ q = ∇ A B /\ (p ・ p #) ∩ (q ・ q #) = Id (prod_eqType A B) /\ univalent_r p /\ univalent_r q.
Lemma pair_of_projections : axiom21.
Proof.
move => A B.
exists (fun (x : prod_eqType A B)(a : A) => a = (fst x)).
exists (fun (x : prod_eqType A B)(b : B) => b = (snd x)).
split.
apply functional_extensionality.
move => a.
apply functional_extensionality.
move => b.
apply prop_extensionality_ok.
split; move => H.
apply I.
exists (a,b).
by [simpl].
split.
apply functional_extensionality.
move => x.
apply functional_extensionality.
move => x0.
apply prop_extensionality_ok.
split; move => H.
move : (H (fun a c : prod_eqType A B => exists b : A, b = fst a /\ b = fst c) (or_introl Logic.eq_refl)).
move : (H (fun a c : prod_eqType A B => exists b : B, b = snd a /\ b = snd c) (or_intror Logic.eq_refl)).
unfold id.
clear H.
elim => b.
elim => H H0.
elim => a.
elim => H1 H2.
rewrite (surjective_pairing x0) -H0 -H2 H H1.
apply surjective_pairing.
rewrite H.
move => alpha H0.
case H0 => H1; rewrite H1; unfold id.
exists (fst x0).
repeat split.
exists (snd x0).
repeat split.
split.
move => a a0.
elim => x.
elim => H H0.
by [rewrite H H0].
move => b b0.
elim => x.
elim => H H0.
by [rewrite H H0].
Qed.

End Rel_Set.


Require Import Coq.ZArith.ZArith.

Require Import Byte.
Require Import ByteData.
Require Import Fetch.

Definition disk_subset (sub super: Disk) :=
  forall (offset: N) (byte: Byte),
    sub offset = Found byte -> super offset = Found byte.

Infix "⊆" := disk_subset (at level 50).

Lemma subset_fmap_existence :
  forall (A: Type) (sub super: Disk) (offset: N) (fn: Byte -> A) (val: A),
    sub ⊆ super ->
    sub offset _fmap_ fn = Found val ->
    super offset _fmap_ fn = Found val.
Proof.
  intros.
  destruct (sub offset) eqn: Heq; [
    | discriminate H0
    | discriminate H0].
  apply H in Heq. rewrite <- Heq in H0. assumption.
Qed.

Lemma subset_fflatmap_existence :
  forall (A: Type) (sub super: Disk) (offset: N)
         (fn: Byte -> @Fetch A) (val: A),
    sub ⊆ super ->
    sub offset _fflatmap_ fn = Found val ->
    super offset _fflatmap_ fn = Found val.
Proof.
  intros.
  destruct (sub offset) eqn: Heq; [
    | discriminate H0
    | discriminate H0].
  apply H in Heq. rewrite <- Heq in H0. assumption.
Qed.

Lemma subset_shift:
  forall (amount: N) (sub super: Disk),
    sub ⊆ super ->
      (shift sub amount) ⊆ (shift super amount).
Proof.
  intros amount sub super H.
  unfold shift. unfold disk_subset.
  intros offset byte.
  apply H.
Qed.

Lemma subset_shift_found:
  forall (amount offset: N) (sub super: Disk) (val: Byte),
    sub ⊆ super ->
      (shift sub amount) offset = Found val ->
        (shift super amount) offset = Found val.
Proof.
  intros.
  apply subset_shift with (super := super) in H0; assumption.
Qed.


Require Export LUB_spec_AX.

Module seq(N:Num_w).

Import N.
Module Export XX:=lub_spec_AX(N).

Section section_sequences.
Variable S : subset.
Variable Hdec : forall alpha beta : HRw,
       beta [>] alpha -> {s : HRw | S s /\ s [>] alpha} + {upper_bound S beta}.
Variables s0 b0 : HRw.
Variable Hs0 : S s0.
Variable Hb0S : upper_bound S b0.

Definition fs := fun (alpha beta : HRw) (Hab : beta [>] alpha) (sn_1 : HRw) =>
      match Hdec alpha beta Hab with
      | inleft Hs => proj1_sig Hs
      | inright _ => sn_1
      end.

Definition fb := fun (alpha beta : HRw) (Hab : beta [>] alpha) (bn_1 : HRw) =>
      match Hdec alpha beta Hab with
      | inleft Hs => (bn_1 [+] proj1_sig Hs) [+] (-w alpha)
      | inright _ => beta
      end.

Lemma s_b_alpha_beta_lemma : forall
(n : A)
(HlimH0 : std n /\ 0 <= n)
(sn : HRw)
(bn : HRw)
(Hbs : S sn /\ upper_bound S bn)
(alphan : HRw)
(betan : HRw)
(Habn : betan [>] alphan),
S (fs alphan betan Habn sn) /\ upper_bound S (fb alphan betan Habn bn).
Proof.
intros.
unfold fs,fb; simpl.
elim (Hdec alphan betan Habn).
intros a; case a; simpl.
intros x (HSx, Hxa).
split.
assumption.
apply HRwgt_upper_bound_2 with bn.
abstract (solve [intuition]).
assert (Hr:(bn [+] (x [+] (-w alphan))) [=] ((bn [+] x) [+] (-w alphan))) by ring.
setoid_rewrite <- Hr.
setoid_replace bn with (bn[+] [0]) at 2 by ring.
apply HRwgt_HRwplus_l.
apply HRwgt_HRwplus_inv_r with alphan.
ring_simplify; assumption.
abstract (intros;solve [intuition]).
Qed.

Definition Psb n HlimH0 sn bn :=
S sn /\ upper_bound S bn /\ (bn [+] (-w sn)) [=] (power two_third n HlimH0 [*] (b0 [+] (-w s0))).

Lemma lemma : forall
(n : A)
(HlimH0 : std n /\ 0 <= n)
(alphan : HRw)
(betan : HRw)
(sn : HRw)
(bn : HRw)
(Hs : S sn)
(Hb : upper_bound S bn)
(Hpower : (bn [+] (-w sn)) [=] (power two_third n HlimH0 [*] (b0 [+] (-w s0))))
(Habn : betan [>] alphan)
(Halphan : alphan = ((two_third [*] sn) [+] (one_third [*] bn)))
(Hbetan : betan = ((one_third [*] sn) [+] (two_third [*] bn)))
(Hx0 : std (n + 1) /\ 0 <= (n + 1)),

S (fs alphan betan Habn sn) /\
upper_bound S (fb alphan betan Habn bn) /\
(fb alphan betan Habn bn [+] (-w fs alphan betan Habn sn)) [=]
(power two_third (n + 1) Hx0 [*] (b0 [+] (-w s0))).
Proof.
intros.
assert (S (fs alphan betan Habn sn) /\
upper_bound S (fb alphan betan Habn bn)).

solve [eapply s_b_alpha_beta_lemma; eauto; intuition].
split.
intuition.
split.
intuition.

unfold fs, fb; elim (Hdec alphan betan Habn).
intros a; elim a; intros sa Hsa; simpl.

setoid_rewrite Halphan.
ring_simplify.
unfold HRwminus; setoid_replace (((-w bn) [*] one_third) [+] bn) with (two_third [*] bn)
by (setoid_rewrite HRwplus_comm;setoid_rewrite (HRwmult_comm (-w bn)); setoid_rewrite <- HRwminus_one_third; ring_simplify; solve [trivial | apply HRwequal_refl]).
assert (Hr: ((two_third [*] bn) [+] (-w (two_third [*] sn)))[=](two_third [*] (bn [+] -w sn))) by ring.
setoid_rewrite Hr.
setoid_rewrite Hpower.
unfold power; rewrite nat_like_induction_r2 with (H:=HlimH0).
ring_simplify; unfold HRwminus.
apply HRwequal_refl.

intros Hup.
setoid_rewrite Hbetan.
ring_simplify; unfold HRwminus.
assert (Hr:((one_third [*] sn) [+] (-w sn))[=] (-w two_third [*] sn)).
assert (Hr2:((-w two_third) [*] sn)[=](-w (two_third [*] sn))) by ring.
setoid_rewrite Hr2.
setoid_rewrite <- HRwminus_one_third; ring_simplify; solve [trivial | apply HRwequal_refl].
setoid_rewrite Hr.
assert (Hr2:(((-w two_third) [*] sn) [+] (two_third [*] bn))[=](two_third [*] (bn [+] -w sn))) by ring.
setoid_rewrite Hr2.
setoid_rewrite Hpower.
unfold power; rewrite nat_like_induction_r2 with (H:=HlimH0).
ring_simplify; unfold HRwminus.
apply HRwequal_refl.
Qed.

Definition def_s_b_alpha_beta :
    forall k:A, forall Hk:(std k /\ 0 <= k),
{sn:HRw & {bn:HRw & Psb k Hk sn bn}}.
Proof.
intros k HlimkH0k.
apply (nat_like_induction
 (fun (x:A) => (forall Hx:std x /\ 0<=x, {sn:HRw & {bn:HRw & Psb x Hx sn bn}}))).
clear HlimkH0k k.
intros.
exists s0.
exists b0.

abstract (
split; [assumption |idtac];
split; [assumption |idtac];
unfold power; rewrite nat_like_induction_r1; ring
) using aproof1.

clear HlimkH0k k.
intros n HlimH0 Hx.

generalize (Hx HlimH0) ; clear Hx.
intros
 (sn,(bn, (Hs, (Hb,Hpower)))).

pose (alphan:=((two_third [*] sn)) [+] (one_third [*] bn)).
pose (betan:=((one_third [*] sn) [+] (two_third [*] bn))).

assert (Habn: betan [>] alphan) by (clear HlimH0 Hpower; abstract (apply step_thirds; intuition) using aproof2).

exists (* sn+1 *) (fs alphan betan Habn sn).
exists (* bn+1 *) (fb alphan betan Habn bn).
abstract (eapply lemma; eapply Hpower || intuition) using aproof3.

apply HlimkH0k.
Defined.

Lemma Hsn_increasing_aux :
forall ssA, forall HssA : ssA = (fun k0 Hk0 =>  proj1_sig(projT1 (def_s_b_alpha_beta k0 Hk0))),
forall bbA, forall HbbA : bbA = (fun k0 Hk0 => proj1_sig (projT1 (projT2 (def_s_b_alpha_beta k0 Hk0)))),
forall n, forall Hn, forall Hn1,  ssA n Hn <= ssA (n+1) Hn1.
Proof.
intros ssA HssA bbA HbbA n Hn.
rewrite HssA.
unfold def_s_b_alpha_beta at 2.
intros.
rewrite nat_like_induction_r2 with (H:=Hn).
unfold def_s_b_alpha_beta.

pose (NLI :=
(nat_like_induction
        (fun x : A =>
         forall Hx : std x /\ 0 <= x, {sn : HRw & {bn : HRw & Psb x Hx sn bn}})
        (fun Hx : std 0 /\ 0 <= 0 =>
         existT (fun sn : HRw => {bn : HRw & Psb 0 Hx sn bn}) s0
           (existT (fun bn : HRw => Psb 0 Hx s0 bn) b0 (aproof1 Hx)))
        (fun (n0 : A) (HlimH0 : std n0 /\ 0 <= n0)
           (Hx : forall Hx : std n0 /\ 0 <= n0,
                 {sn : HRw & {bn : HRw & Psb n0 Hx sn bn}}) =>
         let (sn, s) := Hx HlimH0 in
         let (bn, p) := s in
         match p with
         | conj Hs (conj Hb Hpower) =>
             fun Hx0 : std (n0 + 1) /\ 0 <= n0 + 1 =>
             existT (fun sn0 : HRw => {bn0 : HRw & Psb (n0 + 1) Hx0 sn0 bn0})
               (fs ((two_third [*] sn) [+] (one_third [*] bn))
                  ((one_third [*] sn) [+] (two_third [*] bn))
                  (aproof2 sn bn Hs Hb) sn)
               (existT
                  (fun bn0 : HRw =>
                   Psb (n0 + 1) Hx0
                     (fs ((two_third [*] sn) [+] (one_third [*] bn))
                        ((one_third [*] sn) [+] (two_third [*] bn))
                        (aproof2 sn bn Hs Hb) sn) bn0)
                  (fb ((two_third [*] sn) [+] (one_third [*] bn))
                     ((one_third [*] sn) [+] (two_third [*] bn))
                     (aproof2 sn bn Hs Hb) bn)
                  (aproof3 n0 HlimH0 sn bn Hs Hb Hpower
                     (aproof2 sn bn Hs Hb) Hx0))
         end) n Hn Hn)).

change (
(proj1_sig
  (projT1
     NLI) <=
proj1_sig
  (projT1
     ((let (sn, s) := NLI in
       let (bn, p) := s in
       match p with
       | conj Hs (conj Hb Hpower) =>
           fun Hx : std (n + 1) /\ 0 <= n + 1 =>
           existT (fun sn0 : HRw => {bn0 : HRw & Psb (n + 1) Hx sn0 bn0})
             (fs ((two_third [*] sn) [+] (one_third [*] bn))
                ((one_third [*] sn) [+] (two_third [*] bn))
                (aproof2 sn bn Hs Hb) sn)
             (existT
                (fun bn0 : HRw =>
                 Psb (n + 1) Hx
                   (fs ((two_third [*] sn) [+] (one_third [*] bn))
                      ((one_third [*] sn) [+] (two_third [*] bn))
                      (aproof2 sn bn Hs Hb) sn) bn0)
                (fb ((two_third [*] sn) [+] (one_third [*] bn))
                   ((one_third [*] sn) [+] (two_third [*] bn))
                   (aproof2 sn bn Hs Hb) bn)
                (aproof3 n Hn sn bn Hs Hb Hpower (aproof2 sn bn Hs Hb) Hx))
       end) Hn1))
)).
destruct NLI.
destruct s.
destruct p.
destruct a.

replace
  (projT1
     (existT (fun sn : HRw => {bn : HRw & Psb n Hn sn bn}) x
        (existT (fun bn : HRw => Psb n Hn x bn) x0 (conj s (conj u h))))) with x by auto.

replace
(projT1
     (existT (fun sn0 : HRw => {bn0 : HRw & Psb (n + 1) Hn1 sn0 bn0})
        (fs ((two_third [*] x) [+] (one_third [*] x0))
           ((one_third [*] x) [+] (two_third [*] x0)) (aproof2 x x0 s u) x)
        (existT
           (fun bn0 : HRw =>
            Psb (n + 1) Hn1
              (fs ((two_third [*] x) [+] (one_third [*] x0))
                 ((one_third [*] x) [+] (two_third [*] x0)) (aproof2 x x0 s u)
                 x) bn0)
           (fb ((two_third [*] x) [+] (one_third [*] x0))
              ((one_third [*] x) [+] (two_third [*] x0)) (aproof2 x x0 s u) x0)
           (aproof3 n Hn x x0 s u h (aproof2 x x0 s u) Hn1))))
with
(fs ((two_third [*] x) [+] (one_third [*] x0))
           ((one_third [*] x) [+] (two_third [*] x0)) (aproof2 x x0 s u) x)
by auto.

unfold fs.
destruct (Hdec ((two_third [*] x) [+] (one_third [*] x0))
      ((one_third [*] x) [+] (two_third [*] x0)) (aproof2 x x0 s u)).
generalize s1; intros (sn1, (hsn1a,hsn1b)).
simpl.
assert (sn1 [>] x).
assert (t:=two_thirds_one_third x).
setoid_rewrite t.
eapply HRwgt_trans.
apply hsn1b.
setoid_rewrite (HRwplus_comm (two_third [*] x)).
apply R2_4.
apply HRw1_3.
apply u; apply s.
apply lt_le; apply HRwgt_Zgt; assumption.
apply le_refl.
Qed.

Definition Q:A-> Prop := fun (a:A) => std a /\ leA a0 a.

Instance Q_morph : Proper (equalA ==> Basics.impl) Q.
Proof.
repeat red.
unfold Q.
intros x y Heq H'.
destruct H'.
split; rewrite <- Heq; assumption.
Qed.

Definition R: forall ssA:forall a, Q a->A, forall x, forall a, Q a->Prop :=
fun (ssA:forall a, Q a->A) (x:A) (a:A) (h:Q a) => leA (ssA a h) x.

Definition allDep (Q: A -> Prop) (R:forall x, forall a, Q a->Prop) (x:A) (a:A):=
 forall p:(Q a), (R x a p).

Parameter ssA_args_id :
  forall ssA:forall a, Q a->A, (forall x y, equalA x y -> forall p:Q x, forall q:Q y, equalA (ssA x p) (ssA y q)).
Check ssA_args_id.
(* proving this would require dependent rewriting : *)
(* Error: build_signature: no constraint can apply on a dependent argument *)

(*
Lemma ssA_args_id' :
  forall ssA:forall a, Q a->A, forall HssA : ssA = (fun k0 Hk0 => proj1_sig (projT1 (def_s_b_alpha_beta k0 Hk0))),(forall x y, equalA x y -> forall p:Q x, forall q:Q y, equalA (ssA x p) (ssA y q)).
Proof.
intros.
rewrite HssA.
destruct (def_s_b_alpha_beta x p) as [s_x [b_x Hx]].
destruct (def_s_b_alpha_beta y q) as [s_y [b_y Hy]].
destruct s_x.
destruct s_y.

simpl.
unfold Psb in Hx,Hy.
assert  (S (exist (fun x1 : A => P x1) x0 p0) /\
     upper_bound S b_x /\ forall p:(std x /\ 0<=x), b_x [+] (-w exist (fun x1 : A => P x1) x0 p0) =w power two_third x p [*] (b0 [+] (-w s0))).
admit. (* in a comment *)
assert  (S (exist (fun x1 : A => P x1) x1 p1) /\
     upper_bound S b_x /\ forall q:(std y /\ 0<=y), b_x [+] (-w exist (fun x1 : A => P x1) x0 p0) =w power two_third y q [*] (b0 [+] (-w s0))).
admit. (* in a comment *)
decompose [and] H1.
decompose [and] H2.
rewrite H in H6.
unfold def_s_b_alpha_beta.
simpl.
*)

Instance allDep_morph (ssA:forall a, Q a->A)(* (Q: A -> Prop) (R:forall x, forall a, Q a->Prop)*)(v:A) : Proper (equalA ==> iff) (@allDep Q (R ssA) v).
Proof.
repeat red; unfold allDep, R.
intros x y H.
split.
intros.
assert (Q x) by (rewrite H; assumption).
rewrite <- (ssA_args_id ssA x y H).
eapply H1.

unfold allDep ,R; intros.
assert (Q y) by (rewrite <- H; assumption).
rewrite (ssA_args_id ssA).
eapply H1.
assumption.
Existential 1:= H2.
Existential 1 := H2.
Qed.

Lemma thm_Hsn_increasing :
forall ssA, forall HssA : ssA = (fun k0 Hk0 => proj1_sig (projT1 (def_s_b_alpha_beta k0 Hk0))),
forall bbA, forall HbbA : bbA = (fun k0 Hk0 => proj1_sig (projT1 (projT2 (def_s_b_alpha_beta k0 Hk0)))),
forall n, forall Hn:std n/\0<= n, forall m, forall (Hm:std m/\0<= m),
  m <= n -> ssA m Hm <= ssA n Hn.
Proof.
intros ssA HssA bbA HbbA n Hn m Hm.
apply (nat_like_induction
  (fun x:A => forall Hx:std x/\ 0<=x,
  m <= x -> ssA m Hm <= ssA x Hx)).
intros.
assert (m==0) by (apply le_id; solve [intuition]).
generalize Hm.
assert (HallDep: (allDep Q (R ssA) (ssA 0 Hx) m)).
rewrite H1.
unfold allDep, Q, R; intros.
rewrite (proof_irr _ Hx p).
apply le_refl.
apply HallDep.
intros n0 Hn0 IH Hx Hmn0.
(* here we actually know that  m <= n0+1, *)
assert (Hstd:std (m + - (n0+1))).
apply ANS2a'.
apply Hm.
apply ANS2a_minus.
apply ANS2a'.
apply Hn0.
apply ANS1'.

elim (std_A0_dec (m + - (n0+1)) Hstd). (* occurs in thm_Hsn_increasing, because we need m <= n0 \/ m=n0+1 from  m <= n0+1 *)
intros Hdec'; elim Hdec'.
intros.
apply le_trans with (ssA n0 Hn0).
assert (m<= n0).
apply le_plus_inv with (- (n0+1) +1).
rewrite plus_assoc.
setoid_replace (n0 + (-(n0+1) +1)) with 0 by ring.
apply lt_le_2.
assumption.
apply IH.
assumption.
apply Hsn_increasing_aux with (bbA:=bbA); solve [assumption].

intros.
assert (m==n0+1).
setoid_replace (n0+1) with (0+(n0+1)) by ring.
setoid_replace m with ((m + - (n0 + 1)) + (n0 +1 )) by ring.
rewrite b.
reflexivity.

generalize Hm.
assert (HallDep: (allDep Q (R ssA) (ssA (n0+1) Hx) m)).
rewrite H.
unfold allDep, Q, R; intros.
rewrite (proof_irr _ Hx p).
apply le_refl.
apply HallDep.

intros.
assert (Hf:False).
apply contradict_lt_le with (s:=0) (x:=m + - (n0+1)).
assumption.
apply le_plus_inv with (n0+1).
ring_simplify.
assumption.
solve [intuition].
assumption.
Qed.

End section_sequences.

End seq.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Init.Byte.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.Byte.
Require Import Cava.Util.List.
Require Import HmacSpec.SHA256.
Import ListNotations.
Local Open Scope N_scope.

(* Specification of HMAC as described by RFC 2104, using SHA-256 as the hash
   function: https://datatracker.ietf.org/doc/html/rfc2104 *)

(* From section 2:

   We assume H to be a cryptographic hash function where data is hashed by
   iterating a basic compression function on blocks of data. We denote by B the
   byte-length of such blocks (B=64 for all the above mentioned examples of hash
   functions), and by L the byte-length of hash outputs (L=16 for MD5, L=20 for
   SHA-1).
 *)
Definition B : nat := 64. (* block size for SHA-256  = 512 bits = 64 bytes *)
Definition L : nat := 32. (* output size for SHA-256 = 256 bits = 32 bytes *)

(* From section 2:

   We define two fixed and different strings ipad and opad as follows (the 'i'
   and 'o' are mnemonics for inner and outer):

   ipad = the byte 0x36 repeated B times
   opad = the byte 0x5C repeated B times.
 *)
Definition ipad : list byte := repeat x36 B.
Definition opad : list byte := repeat x5c B.

(* From section 2 :

  To compute HMAC over the data `text' we perform

     H(K XOR opad, H(K XOR ipad, text))

  Namely:
    (1) append zeros to the end of K to create a B byte string
        (e.g., if K is of length 20 bytes and B=64, then K will be
         appended with 44 zero bytes 0x00)
    (2) XOR (bitwise exclusive-OR) the B byte string computed in step
        (1) with ipad
    (3) append the stream of data 'text' to the B byte string resulting
        from step (2)
    (4) apply H to the stream generated in step (3)
    (5) XOR (bitwise exclusive-OR) the B byte string computed in
        step (1) with opad
    (6) append the H result from step (4) to the B byte string
        resulting from step (5)
    (7) apply H to the stream generated in step (6) and output
        the result
 *)
Section HMAC_SHA256.
  Context (K data : list byte).

  (* From section 3:

     The key for HMAC can be of any length (keys longer than B bytes are
     first hashed using H). *)
  Definition K0 : list byte := if (length K <=? B)%nat
                               then K
                               else sha256 K.

  (* step 1 *)
  Definition padded_key : list byte := K0 ++ (repeat x00 (B - length K0)).

  Definition XOR (x y : list byte) := map2 byte_xor x y.

  Definition H (x y : list byte) := sha256 (x ++ y).

  Definition hmac_sha256 :=
    (* steps 2-4 *)
    let inner := H (XOR padded_key ipad) data in
    (* steps 5-7 *)
    H (XOR padded_key opad) inner.
End HMAC_SHA256.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e255m765_8limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e382m105_12limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Morphisms.
Import ProperNotations.
Require Import SetoidClass.
Require notation categories prods_pullbacks functors natural_transformations monads adjunctions kleisli.

Module Make(Import M: notation.T).
 Module Export functor_categories_exp := kleisli.Make(M).

Axiom proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2.

Definition Functor_Category (catC catD: Category) (F G: obj catC -> obj catD)
                            (trans : forall (a: obj catC), (arrow catD (G a) (F a))): Category.
Proof. refine (@mk_Category  {pFunctF: {F: obj catC -> obj catD  &
                                (forall (a b: obj catC) (f: arrow catC b a), (arrow catD (F b) (F a)))} &
                                (Functor catC catD (projT1 pFunctF) (projT2 pFunctF))}
                             (fun FunctF FunctG =>
                                NaturalTransformation catC catD
                                                     (projT1 (projT1 FunctF)) (projT1 (projT1 FunctG))
                                                     (projT2 (projT1 FunctF)) (projT2 (projT1 FunctG))
                                                     (projT2 FunctF) (projT2 FunctG))
                             (fun FunctF =>
                                IdentityNaturalTransformation catC catD
                                                              (projT1 (projT1 FunctF))
                                                              (projT2 (projT1 FunctF))
                                                              (projT2 FunctF))
                             (fun FunctF FunctG FunctH nt1 nt2 =>
                                Compose_NaturalTransformations _ _ _ _ _ _ _ _
                                                               (projT2 FunctF)
                                                               (projT2 FunctG)
                                                               (projT2 FunctH)
                                                               (nt1)
                                                               (nt2))
                             _ _ _ ).
        - intros. simpl in *. Admitted.

(*
Lemma NaturalTransformations2_eq: forall   (catC catD: Category)
                                           (F G     : obj catC -> obj catD)
                                           (FunctF  : @Functor2 catC catD F)
                                           (FunctG  : @Functor2 catC catD G)
                                           (nt1 nt2 : @NaturalTransformation2 catC catD F G FunctF FunctG),
(forall a: obj catC, (@trans2 _ _ _ _ _ _ nt1 a) = (@trans2  _ _ _ _ _ _ nt2 a)) ->
(forall (a b: obj catC) (f: arrow catC b a), (@comm_diag2 _ _ _ _ _ _ nt1 a b f) = (@comm_diag2  _ _ _ _ _ _ nt2 a b f)) ->
nt1 = nt2.
*)

Definition Functor_Category2 (catC catD: Category) (F G: obj catC -> obj catD)
                             (trans : forall (a: obj catC), (arrow catD (G a) (F a))): Category.
Proof. refine (@mk_Category  {F: obj catC -> obj catD  & (Functor2 catC catD F)}
                             (fun FunctF FunctG =>
                                NaturalTransformation2 catC catD
                                                     (projT1 FunctF) (projT1 FunctG)
                                                     (projT2 FunctF) (projT2 FunctG))
                             (fun FunctF =>
                                IdentityNaturalTransformation2 catC catD
                                                               (projT1 FunctF)
                                                               (projT2 FunctF))
                             (fun FunctF FunctG FunctH nt1 nt2 =>
                                Compose_NaturalTransformations2 _ _ _ _ _
                                                               (projT2 FunctF)
                                                               (projT2 FunctG)
                                                               (projT2 FunctH)
                                                               (nt1)
                                                               (nt2))
                             _ _ _ ).
        - intros. destruct f, g, h, a, b, c, d in *. simpl in *.
          unfold Compose_NaturalTransformations2, assoc. simpl.
          generalize trans2.
          assert ((fun a : obj catC => trans3 a o (trans4 a o trans5 a)) =
                  (fun a : obj catC => (trans3 a o trans4 a) o trans5 a)).
          { admit. } rewrite H.
          f_equal.
 eq_ind, eq_ind_r, eq_sym. simpl.
          subst.
          rewrite assoc.
          destruct f, f0, f1, f2. simpl in *.
          remember mk_Category.
          unfold Compose_NaturalTransformations2. simpl.
          remember mk_Category.

          unfold Compose_NaturalTransformations2, eq_ind, eq_rect, assoc. simpl.
          rewrite <- assoc.

unfold assoc. simpl. rewrite assoc.
          repeat destruct Compose_NaturalTransformations2.
          rewrite (proof_irrelevance trans6 trans7).

 simpl.

 auto. easy.

 Admitted.

(* to complete: prove that Functor categories exist.
   required   : associativity of natural transformation composition
*)

End Make.


From Hammer Require Import Hammer.

Require Export NZAxioms.
Require Import ZArith.
Require Import Zpow_facts.
Require Import DoubleType.
Require Import CyclicAxioms.

Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig.

Local Open Scope Z_scope.

Local Notation wB := (base ZnZ.digits).

Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99).

Definition eq (n m : t) := [| n |] = [| m |].
Definition zero := ZnZ.zero.
Definition one := ZnZ.one.
Definition two := ZnZ.succ ZnZ.one.
Definition succ := ZnZ.succ.
Definition pred := ZnZ.pred.
Definition add := ZnZ.add.
Definition sub := ZnZ.sub.
Definition mul := ZnZ.mul.

Local Infix "=="  := eq (at level 70).
Local Notation "0" := zero.
Local Notation S := succ.
Local Notation P := pred.
Local Infix "+" := add.
Local Infix "-" := sub.
Local Infix "*" := mul.

Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred
ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic.
Ltac zify :=
unfold eq, zero, one, two, succ, pred, add, sub, mul in *;
autorewrite with cyclic.
Ltac zcongruence := repeat red; intros; zify; congruence.

Instance eq_equiv : Equivalence eq.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.eq_equiv".
unfold eq. firstorder.
Qed.

Local Obligation Tactic := zcongruence.

Program Instance succ_wd : Proper (eq ==> eq) succ.
Program Instance pred_wd : Proper (eq ==> eq) pred.
Program Instance add_wd : Proper (eq ==> eq ==> eq) add.
Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul.

Theorem gt_wB_1 : 1 < wB.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.gt_wB_1".
unfold base. apply Zpower_gt_1; unfold Z.lt; auto with zarith.
Qed.

Theorem gt_wB_0 : 0 < wB.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.gt_wB_0".
pose proof gt_wB_1; auto with zarith.
Qed.

Lemma one_mod_wB : 1 mod wB = 1.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.one_mod_wB".
rewrite Zmod_small. reflexivity. split. auto with zarith. apply gt_wB_1.
Qed.

Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.succ_mod_wB".
intro n. rewrite <- one_mod_wB at 2. now rewrite <- Zplus_mod.
Qed.

Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.pred_mod_wB".
intro n. rewrite <- one_mod_wB at 2. now rewrite Zminus_mod.
Qed.

Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |].
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.NZ_to_Z_mod".
intro n; rewrite Zmod_small. reflexivity. apply ZnZ.spec_to_Z.
Qed.

Theorem pred_succ : forall n, P (S n) == n.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.pred_succ".
intro n. zify.
rewrite <- pred_mod_wB.
replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod.
Qed.

Theorem one_succ : one == succ zero.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.one_succ".
zify; simpl Z.add. now rewrite one_mod_wB.
Qed.

Theorem two_succ : two == succ one.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.two_succ".
reflexivity.
Qed.

Section Induction.

Variable A : t -> Prop.
Hypothesis A_wd : Proper (eq ==> iff) A.
Hypothesis A0 : A 0.
Hypothesis AS : forall n, A n <-> A (S n).

Let B (n : Z) := A (ZnZ.of_Z n).

Lemma B0 : B 0.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.B0".
unfold B. apply A0.
Qed.

Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1).
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.BS".
intros n H1 H2 H3.
unfold B in *. apply AS in H3.
setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). assumption.
zify.
rewrite 2 ZnZ.of_Z_correct; auto with zarith.
symmetry; apply Zmod_small; auto with zarith.
Qed.

Theorem Zbounded_induction :
(forall Q : Z -> Prop, forall b : Z,
Q 0 ->
(forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) ->
forall n, 0 <= n -> n < b -> Q n)%Z.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.Zbounded_induction".
intros Q b Q0 QS.
set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)).
assert (H : forall n, 0 <= n -> Q' n).
apply natlike_rec2; unfold Q'.
destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split.
intros n H IH. destruct IH as [[IH1 IH2] | IH].
destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1].
right; auto with zarith.
left. split; [auto with zarith | now apply (QS n)].
right; auto with zarith.
unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3].
assumption. now apply Z.le_ngt in H3.
Qed.

Lemma B_holds : forall n : Z, 0 <= n < wB -> B n.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.B_holds".
intros n [H1 H2].
apply Zbounded_induction with wB.
apply B0. apply BS. assumption. assumption.
Qed.

Theorem bi_induction : forall n, A n.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.bi_induction".
intro n. setoid_replace n with (ZnZ.of_Z (ZnZ.to_Z n)).
apply B_holds. apply ZnZ.spec_to_Z.
red. symmetry. apply ZnZ.of_Z_correct.
apply ZnZ.spec_to_Z.
Qed.

End Induction.

Theorem add_0_l : forall n, 0 + n == n.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.add_0_l".
intro n. zify.
rewrite Z.add_0_l. apply Zmod_small. apply ZnZ.spec_to_Z.
Qed.

Theorem add_succ_l : forall n m, (S n) + m == S (n + m).
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.add_succ_l".
intros n m. zify.
rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0.
rewrite <- (Z.add_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l.
rewrite (Z.add_comm 1 [| m |]); now rewrite Z.add_assoc.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.sub_0_r".
intro n. zify. rewrite Z.sub_0_r. apply NZ_to_Z_mod.
Qed.

Theorem sub_succ_r : forall n m, n - (S m) == P (n - m).
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.sub_succ_r".
intros n m. zify. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l.
now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z
by ring.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.mul_0_l".
intro n. now zify.
Qed.

Theorem mul_succ_l : forall n m, (S n) * m == n * m + m.
Proof. hammer_hook "NZCyclic" "NZCyclic.NZCyclicAxiomsMod.mul_succ_l".
intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
now rewrite Z.mul_add_distr_r, Z.mul_1_l.
Qed.

Definition t := t.

End NZCyclicAxiomsMod.


(*|
################################################
Removing the last element of a sized list in Coq
################################################

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

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

Consider the following type definition of a sized list:
|*)

Inductive listn : nat -> Type -> Type :=
| nil: forall {A : Set}, listn 0 A
| cons: forall {n : nat} {A : Set}, A -> listn n A -> listn (S n) A.

(*|
This is essentially the `Vect
<https://github.com/idris-lang/Idris-dev/blob/master/libs/base/Data/Vect.idr>`__
type in Idris.

I am trying to define the ``init`` function for ``listn``, which
removes the last element.

My attempted implementation was virtually identical to the definition
of ``init`` in Idris. Here it is in Idris:

.. code-block:: idris

    init : Vect (S len) elem -> Vect len elem
    init (x::[])    = []
    init (x::y::ys) = x :: init (y::ys)

Transcribed into Coq:
|*)

Fail Fixpoint init {n : nat} {A : Set} (l : listn (S n) A): listn n A :=
  match l with
  | cons x nil => nil
  | cons x (cons y ys) => cons x (init (cons y ys))
  end. (* .fails *)

(*| ...but this fails with: |*)

Fail Fixpoint init {n : nat} {A : Set} (l : listn (S n) A): listn n A :=
  match l with
  | cons x nil => nil
  | cons x (cons y ys) => cons x (init (cons y ys))
  end. (* .unfold .messages *)

(*|
I take it that Coq isn't able to see that the case necessarily implies
that ``n`` is zero. This is a problem I keep running into – Coq isn't
able to see the relationship between ``n`` and the list itself.

Hence my questions:

- How can ``init`` be implemented in Coq?
- Why does the Idris definition work in Idris but not in Coq? What is
  Idris doing behind the scenes that Coq isn't?
|*)

(*|
Answer
******

By itself, Coq is not very good for writing this kind of code, but you
can use the `Equations plugin
<https://github.com/mattam82/Coq-Equations>`__ to make it simpler.
Nevertheless, let us see how we can do it without external
dependencies:
|*)

Require Import Coq.Vectors.Vector.
(* Vector.t is equivalent to your listn type *)

Arguments nil {A}.
Arguments cons {A} _ {n}.

Fixpoint init {n : nat} {A : Set} (xs : Vector.t A (S n)): Vector.t A n :=
  match xs in Vector.t _ m return Vector.t A (pred m) with
  | nil => nil
  | cons x xs =>
      match xs in Vector.t _ m return Vector.t A m -> Vector.t A m with
      | nil      => fun _  => nil
      | cons _ _ => fun xs => cons x (init xs)
      end xs
  end.

(*|
This definition differs from yours in a few ways. First, we need to
annotate the return type of ``match`` to explain how it depends on the
length of the vector. The ``in Vector.t _ m`` part says that the
return type is *generic* on the length of the vector -- we *cannot*
assume that the length is of the form ``S n``.

Second, we have to enumerate all cases of the data type: ``match`` is
*always* exhaustive in Coq, even if some of the branches are
unreachable due to typing information. Thus, I've included a case for
``nil`` in the first match.

Third, Coq cannot recognize that ``init (cons y ys)`` is a valid
recursive call. We fix this by giving ``cons y ys`` a name, ``xs``,
before destructing it, and using ``init xs`` instead. There is a
subtlelty, however. In ``cons x xs``, the type of ``xs`` is ``Vector.t
A m`` for *some* ``m``, which may or may not be a successor, so we
cannot call ``init`` directly. Instead, we first destruct ``xs``, and
perform the recursive call only on the ``cons`` branch. But because
``match`` is generic on its length argument, Coq does not see a
connection between the length of ``xs`` inside and outside of
``match``. The solution is to perform what Adam Chlipala calls the
*convoy pattern*: we make match return a function rather than a plain
vector, and pass ``xs`` as an argument outside of the match. This way,
the connection between the two lengths is not lost.

I don't know much about Idris, but my guess is that its type-checking
algorithm is more complicated than Coq's, which is why it can tell
that the analogous definition is valid. Coq's rules are quite simple
(and limited), to be honest.
|*)


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

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependent
    interface [MSetWeakInterface.S] using lists without redundancy. *)

Require Import MSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists

   First, we provide sets as lists which are (morally) without redundancy.
   The specs are proved under the additional condition of no redundancy.
   And the functions returning sets are proved to preserve this invariant. *)

(** ** The set operations. *)

Module Ops (X: DecidableType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) : bool := if l then true else false.

  Fixpoint mem (x : elt) (s : t) : bool :=
    match s with
    | nil => false
    | y :: l =>
           if X.eq_dec x y then true else mem x l
    end.

  Fixpoint add (x : elt) (s : t) : t :=
    match s with
    | nil => x :: nil
    | y :: l =>
        if X.eq_dec x y then s else y :: add x l
    end.

  Definition singleton (x : elt) : t := x :: nil.

  Fixpoint remove (x : elt) (s : t) : t :=
    match s with
    | nil => nil
    | y :: l =>
        if X.eq_dec x y then l else y :: remove x l
    end.

  Definition fold (B : Type) (f : elt -> B -> B) : t -> B -> B :=
    fold_left (flip f).

  Definition union (s : t) : t -> t := fold add s.

  Definition diff (s s' : t) : t := fold remove s' s.

  Definition inter (s s': t) : t :=
    fold (fun x s => if mem x s' then add x s else s) s nil.

  Definition subset (s s' : t) : bool := is_empty (diff s s').

  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s).

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (s : t) : list elt := s.

  Definition choose (s : t) : option elt :=
     match s with
      | nil => None
      | x::_ => Some x
     end.

End Ops.

(** ** Proofs of set operation specifications. *)

Module MakeRaw (X:DecidableType) <: WRawSets X.
  Include Ops X.

  Section ForNotations.
  Notation NoDup := (NoDupA X.eq).
  Notation In := (InA X.eq).

  (* TODO: modify proofs in order to avoid these hints *)
  Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv).
  Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv).
  Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv).
  Hint Resolve eqr eqtrans.
  Hint Immediate eqsym.

  Definition IsOk := NoDup.

  Class Ok (s:t) : Prop := ok : NoDup s.

  Hint Unfold Ok.
  Hint Resolve ok.

  Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }.

  Ltac inv_ok := match goal with
   | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:Ok nil |- _ => clear H; inv_ok
   | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok.
  Ltac constructors := repeat constructor.

  Fixpoint isok l := match l with
   | nil => true
   | a::l => negb (mem a l) && isok l
  end.

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

  Lemma In_compat : Proper (X.eq==>eq==>iff) In.
  Proof.
  repeat red; intros. subst. rewrite H; auto.
  Qed.

  Lemma mem_spec : forall s x `{Ok s},
   mem x s = true <-> In x s.
  Proof.
  induction s; intros.
  split; intros; inv. discriminate.
  simpl; destruct (X.eq_dec x a); split; intros; inv; auto.
  right; rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma isok_iff : forall l, Ok l <-> isok l = true.
  Proof.
  induction l.
  intuition.
  simpl.
  rewrite andb_true_iff.
  rewrite negb_true_iff.
  rewrite <- IHl.
  split; intros H. inv.
  split; auto.
  apply not_true_is_false. rewrite mem_spec; auto.
  destruct H; constructors; auto.
  rewrite <- mem_spec; auto; congruence.
  Qed.

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

  Lemma add_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition.
  left; eauto.
  inv; auto.
  Qed.

  Global Instance add_ok s x `(Ok s) : Ok (add x s).
  Proof.
  induction s.
  simpl; intuition.
  intros; inv. simpl.
  destruct X.eq_dec; auto.
  constructors; auto.
  intro; inv; auto.
  rewrite add_spec in *; intuition.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec as [|Hnot]; inv; rewrite !InA_cons, ?IHs; intuition.
  elim H. setoid_replace a with y; eauto.
  elim H3. setoid_replace x with y; eauto.
  elim Hnot. eauto.
  Qed.

  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
  Proof.
  induction s; simpl; intros.
  auto.
  destruct X.eq_dec; inv; auto.
  constructors; auto.
  rewrite remove_spec; intuition.
  Qed.

  Lemma singleton_ok : forall x : elt, Ok (singleton x).
  Proof.
  unfold singleton; simpl; constructors; auto. intro; inv.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros. inv; auto. left; auto.
  Qed.

  Lemma empty_ok : Ok empty.
  Proof.
  unfold empty; constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; red; intros; inv.
  Qed.

  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
  Proof.
  unfold Empty; destruct s; simpl; split; intros; auto.
  intro; inv.
  discriminate.
  elim (H e); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
  Proof.
  unfold elements; intuition.
  Qed.

  Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s).
  Proof.
  unfold elements; auto.
  Qed.

  Lemma fold_spec :
   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s').
  Proof.
  induction s; simpl; auto; intros; inv; unfold flip; auto with *.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction s; simpl in *; unfold flip; intros; auto; inv.
  intuition; inv.
  rewrite IHs, add_spec, InA_cons; intuition.
  Qed.

  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
  Proof.
  unfold inter, fold, flip.
  set (acc := nil (A:=elt)).
  assert (Hacc : Ok acc) by constructors.
  clearbody acc; revert acc Hacc.
  induction s; simpl; auto; intros. inv.
  apply IHs; auto.
  destruct (mem a s'); auto with *.
  Qed.

  Lemma inter_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  unfold inter, fold, flip; intros.
  set (acc := nil (A:=elt)) in *.
  assert (Hacc : Ok acc) by constructors.
  assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc).
   intuition; unfold acc in *; inv.
  rewrite IFF; clear IFF. clearbody acc.
  revert acc Hacc x s' Hs Hs'.
  induction s; simpl; intros.
  intuition; inv.
  inv.
  case_eq (mem a s'); intros Hm.
  rewrite IHs, add_spec, InA_cons; intuition.
  rewrite mem_spec in Hm; auto.
  left; split; auto. rewrite H1; auto.
  rewrite IHs, InA_cons; intuition.
  rewrite H2, <- mem_spec in H3; auto. congruence.
  Qed.

  Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip; auto; intros. inv; auto with *.
  Qed.

  Lemma diff_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip.
  intuition; inv.
  intros. inv.
  rewrite IHs', remove_spec, InA_cons; intuition.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   subset s s' = true <-> Subset s s'.
  Proof.
  unfold subset, Subset; intros.
  rewrite is_empty_spec.
  unfold Empty; intros.
  intuition.
  specialize (H a). rewrite diff_spec in H; intuition.
  rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition.
  rewrite diff_spec in H0; intuition.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   equal s s' = true <-> Equal s s'.
  Proof.
  unfold Equal, equal; intros.
  rewrite andb_true_iff, !subset_spec.
  unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt), choose s = Some x -> In x s.
  Proof.
  destruct s; simpl; intros; inversion H; auto.
  Qed.

  Definition choose_spec2 : forall s : t, choose s = None -> Empty s.
  Proof.
  destruct s; simpl; intros.
  intros x H0; inversion H0.
  inversion H.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) {Hs : Ok s}, cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_spec' : forall s x f,
   In x (filter f s) -> In x s.
  Proof.
  induction s; simpl.
  intuition; inv.
  intros; destruct (f a); inv; intuition; right; eauto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  induction s; simpl.
  intuition; inv.
  intros.
  destruct (f a) eqn:E; rewrite ?InA_cons, IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in E; auto. congruence.
  Qed.

  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
  Proof.
  induction s; simpl.
  auto.
  intros; inv.
  case (f a); auto.
  constructors; auto.
  contradict H0.
  eapply filter_spec'; eauto.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  unfold For_all; induction s; simpl.
  intuition. inv.
  intros; inv.
  destruct (f a) eqn:F.
  rewrite IHs; intuition. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'; try discriminate.
  intros.
  rewrite <- F, <- (H' a); auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  unfold Exists; induction s; simpl.
  split; [discriminate| intros (x & Hx & _); inv].
  intros.
  destruct (f a) eqn:F.
  split; auto.
  exists a; auto.
  rewrite IHs; firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (fst (partition f s)) (filter f s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_ok1' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (fst (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Lemma partition_ok2' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (snd (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok1' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok2' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Definition eq := Equal.
  Instance eq_equiv : Equivalence eq := _.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of lists without redundancy. *)

Module Make (X: DecidableType) <: WSets with Module E := X.
 Module Raw := MakeRaw X.
 Include WRaw2Sets X Raw.
End Make.


(** * Notations and utilities for Decidability.

Except for some comments and minor additins at the end, this material
is taken from Gert Smolka's Base Library for ICL

   - Version: 30 June 2014 Author: Gert Smolka, Saarland University
   - Acknowlegments: Sigurd Schneider, Dominik Kirst *)

(*

This file defines some abbreviations and notation:
 dec
 eq_dec
 decision
 decide

(1) (dec P)  is a Type     for P: Prop
     it abbreviates {P}+{~P}

(2) (eq_dec T) is a Type   for T:Type
    Notation for (forall x y : T, dec (x=y))
              ie (forall x y : T, {(x=y)} + {~(x=y)}

for various T, can construct (below) inhabitants of eq_dec_T.
For example
  nat_eq_dec   : (eq_dec nat)
  bool_eq_dec  : (eq_dec bool)

So, eg, nat_eq_dec takes two arguments, returns a sumbool

(nat_eq_dec 3 7) is an element of {3=7}+{~ 3 =7}
(nat_eq_dec 3 7) : {3=7}+{~ 3 =7}

(3)   (decision P D)  is a value    for P:Prop and D: dec P
    specifically, (decision P D) has type (dec P)

  indeed, (decision P D) is precisely D.
  but with implit arguments, ie
  Arguments decision P {D}
  the effect is that, eg,
  (decision (x=y)) has type {x=y}+{~x=y}

  explictly would have [for x y : nat, say]
  (@decision (x=y) (nat_eq_dec x y)) : {x=y}+{~ x=y}
  since (x=y): Prop and (nat_eq_dec x y): (eq_dec nat)

  The value that (decision P D) names is either
  a proof of P or a proof of ~P.

  So in programming we can match on it, ie do things like
     [ if (decision (x=y) then ... else ... ]

Definition dumb' (n m: nat) : nat :=
  if decision (x=y) then x else y.

Definition dumb (n m: nat) : nat :=
  if @decision (x=y) (@nat_eq_dec x y) then x else y.

(4)  decide P is a tactic
     means (destruct (decision P))

  another form
  decide p as i
  means (destruct (decision P)) as I
*)
Require Export Bool.
Require Export Omega.
Require Export List.
Require Export Morphisms.

(* This is unset at the end of this file *)
Global Set Implicit Arguments.
Global Unset Strict Implicit.

(** *** General decidability abstraction over any Prop *)

Definition dec (P : Prop) : Type := {P} + {~ P}.

(** *** When the dec Pop is equality *)

Notation "'eq_dec' T" := (forall x y : T, dec (x=y)) (at level 70).

(** Register dec as a type class *)

Existing Class dec.

(** *** A trick using implicit arguments *)

Definition decision (P : Prop) (D : dec P) : dec P := D.
Arguments decision P {D}.

(** ** A tactic for using decidable Props*)

Tactic Notation "decide" constr(p) :=
  destruct (decision p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (decision p) as i.

(** ** Hints for auto concerning dec *)

Hint Extern 4 =>
match goal with
  | [  |- dec ?p ] => exact (decision p)
end.

(** *** Improves type class inference *)

Hint Extern 4 =>
match goal with
  | [  |- dec ((fun _ => _) _) ] => simpl
end : typeclass_instances.

(** ** Register instance rules for dec *)

Instance True_dec :  dec True :=
  left I.

Instance False_dec :  dec False :=
  right (fun A => A).

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec. tauto.
Defined.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Defined.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Defined.

(* Coq standard modules make "not" and "iff" opaque for type class
inference, can be seen with Print HintDb typeclass_instances. *)

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. auto.
Defined.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. auto.
Qed.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  intros x y. hnf. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  intros x y. hnf. decide equality.
Defined.

Instance nat_le_dec (x y : nat) : dec (x <= y) :=
  le_dec x y.

(** ** Propositional connectives *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_prop_iff (X Y : Prop) :
  (X <-> Y) -> dec X -> dec Y.
Proof.
  unfold dec; tauto.
Defined.

(** * Decidability laws for lists *)

Export ListNotations.
Notation "| A |" := (length A) (at level 65).
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
(* Notation "A === B" := (equi A B) (at level 70). *)

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  intros D. apply list_eq_dec. exact D.
Defined.

Instance list_in_dec (X : Type) (x : X) (A : list X) :
  eq_dec X -> dec (x el A).
Proof.
  intros D. apply in_dec. exact D.
Defined.

Lemma list_sigma_forall X A (p : X -> Prop) (p_dec : forall x, dec (p x)) :
  {x | x el A /\ p x} + {forall x, x el A -> ~ p x}.
Proof.
  induction A as [|x A]; simpl.
  - tauto.
  - destruct IHA as [[y [D E]]|D].
    + eauto.
    + destruct (p_dec x) as [E|E].
      * eauto.
      * right. intros y [[]|F]; auto.
Defined.

Arguments list_sigma_forall {X} A p {p_dec}.

Instance list_forall_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (forall x, x el A -> p x).
Proof.
  intros p_dec.
  destruct (list_sigma_forall A (fun x => ~ p x)) as [[x [D E]]|D].
  - right. auto.
  - left. intros x E. apply dec_DN; auto.
Defined.

Instance list_exists_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (exists x, x el A /\ p x).
Proof.
  intros p_dec.
  destruct (list_sigma_forall A p) as [[x [D E]]|D].
  - unfold dec. eauto.
  - right. intros [x [E F]]. exact (D x E F).
Defined.

Lemma list_exists_DM X A  (p : X -> Prop) :
  (forall x, dec (p x)) ->
  ~ (forall x, x el A -> ~ p x) -> exists x, x el A /\ p x.
Proof.
  intros D E.
  destruct (list_sigma_forall A p) as [F|F].
  + destruct F as [x F]. eauto.
  + contradiction (E F).
Qed.

Lemma list_exists_not_incl X (A B : list X) :
  eq_dec X ->
  ~ A <<= B -> exists x, x el A /\ ~ x el B.
Proof.
  intros D E.
  apply list_exists_DM; auto.
  intros F. apply E. intros x G.
  apply dec_DN; auto.
Qed.

Lemma list_cc X (p : X -> Prop) A :
  (forall x, dec (p x)) ->
  (exists x, x el A /\ p x) -> {x | x el A /\ p x}.
Proof.
  intros D E.
  destruct (list_sigma_forall A p) as [[x [F G]]|F].
  - eauto.
  - exfalso. destruct E as [x [G H]]. apply (F x); auto.
Defined.

Global Unset Implicit Arguments.

(** * Connecting sumbool decision function with booleans *)

(** *** dd additions *)

Definition sumbool_to_bool :
  forall P Q : Prop, {P} + {Q} -> bool :=
  fun P Q sb => if sb then true else false.

Arguments sumbool_to_bool {P} {Q} _.

Lemma sumbool_to_bool_correct_left P Q  sb :
  (@sumbool_to_bool P Q sb) = true -> P.
Proof.
 intros H.
    unfold sumbool_to_bool in H.
    destruct sb as [y | n]; easy.
Qed.

Lemma sumbool_to_bool_correct_right P Q sb :
  (@sumbool_to_bool P Q sb) = false -> Q.
Proof.
  intros H.
  unfold sumbool_to_bool in H.
  destruct sb as [y | n]; easy.
Qed.

(** NB: don't expect iff in the above.
Suppose P = Q !

But in the case Q is ~P we do get iff:
*)

Definition dec_to_bool :
  forall P : Prop, {P} + {~ P} -> bool :=
  fun P sb => @sumbool_to_bool P (~P) sb.

Arguments dec_to_bool {P} _.

Lemma dec_to_bool_correct P sb :
  (@dec_to_bool P sb) = true <-> P.
Proof.
  split.
  - unfold dec_to_bool.
    apply sumbool_to_bool_correct_left.
  - intros H.
    apply not_false_is_true; intros H1.
    assert (H2:= sumbool_to_bool_correct_right P (~P) sb H1).
    easy.
Qed.

Lemma dec_to_bool_correct' P sb :
  (@dec_to_bool P sb) = false <-> (P -> False).
Proof.
  assert (H1:= dec_to_bool_correct P sb).
  assert (H2:= not_true_iff_false (dec_to_bool sb)).
  firstorder.
Qed.


Require Export Iron.Language.SystemF2Effect.Type.

(********************************************************************)
(* Constants *)
Inductive const : Type :=
  | CUnit   : const
  | CNat    : nat   -> const
  | CBool   : bool  -> const.
Hint Constructors const.

Fixpoint typeOfConst (c : const) : ty :=
  match c with
  | CUnit     => TUnit
  | CNat  _   => TNat
  | CBool _   => TBool
  end.

(* Primitive Operators *)
Inductive op1 : Type :=
  | OSucc   : op1
  | OIsZero : op1.
Hint Constructors op1.

(* Values *)
Inductive val : Type :=
  | VVar     : nat   -> val
  | VLoc     : nat   -> val
  | VLam     : ty    -> exp -> val
  | VLAM     : ki    -> exp -> val
  | VConst   : const -> val

(* Expressions *)
with     exp : Type :=
  | XVal     : val -> exp
  | XLet     : ty  -> exp -> exp -> exp
  | XApp     : val -> val -> exp
  | XAPP     : val -> ty  -> exp

  (* Pure operators *)
  | XOp1     : op1 -> val -> exp

  (* Store operators *)
  | XPrivate : exp -> exp
  | XExtend  : ty  -> exp -> exp

  | XAlloc   : ty  -> val -> exp
  | XRead    : ty  -> val -> exp
  | XWrite   : ty  -> val -> val -> exp.

Hint Constructors val.
Hint Constructors exp.

(********************************************************************)
(* Induction principle for expressions. *)
Lemma exp_mutind : forall
    (PX : exp -> Prop)
    (PV : val -> Prop)
 ,  (forall n,                                     PV (VVar   n))
 -> (forall l,                                     PV (VLoc   l))
 -> (forall t x,        PX x                    -> PV (VLam   t x))
 -> (forall k x,        PX x                    -> PV (VLAM   k x))
 -> (forall c,                                     PV (VConst c))
 -> (forall v,          PV v                    -> PX (XVal   v))
 -> (forall t x1 x2,    PX x1 -> PX x2          -> PX (XLet   t x1 x2))
 -> (forall v1 v2,      PV v1 -> PV v2          -> PX (XApp   v1 v2))
 -> (forall v t,        PV v                    -> PX (XAPP   v  t))
 -> (forall o v,        PV v                    -> PX (XOp1 o   v))
 -> (forall x,          PX x                    -> PX (XPrivate x))
 -> (forall t x,        PX x                    -> PX (XExtend  t x))
 -> (forall r v,        PV v                    -> PX (XAlloc r v))
 -> (forall r v,        PV v                    -> PX (XRead  r v))
 -> (forall r v1 v2,    PV v1 -> PV v2          -> PX (XWrite r v1 v2))
 ->  forall x, PX x.
Proof.
 intros PX PV.
 intros hVar hLoc hLam hLAM hConst
        hVal hLet hApp hAPP hOp1
        hPrivate hExtend
        hAlloc hRead hWrite.
 refine (fix  IHX x : PX x := _
         with IHV v : PV v := _
         for  IHX).

 (* expressions *)
 case x; intros.
 apply hVal.     apply IHV.
 apply hLet.     apply IHX. apply IHX.
 apply hApp.     apply IHV. apply IHV.
 apply hAPP.     apply IHV.
 apply hOp1.     apply IHV.
 apply hPrivate. apply IHX.
 apply hExtend.  apply IHX.
 apply hAlloc.   apply IHV.
 apply hRead.    apply IHV.
 apply hWrite.   apply IHV. apply IHV.

 (* values *)
 case v; intros.
 apply hVar.
 apply hLoc.
 apply hLam. apply IHX.
 apply hLAM. apply IHX.
 apply hConst.
Qed.