(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup perm finalg matrix.
From mathcomp Require boolp.
From mathcomp Require Import Rstruct.
Require Import Reals.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop fdist.
Require Import proba.

(******************************************************************************)
(*        Conditional probabilities over joint finite distributions           *)
(*                                                                            *)
(*       \Pr_P [ A | B ] == conditional probability of A given B where P is a *)
(*                          joint distribution                                *)
(*  jfdist_cond0 PQ a a0 == The conditional distribution derived from PQ      *)
(*                          given a; PQ is a joint distribution               *)
(*                          {fdist A * B}, a0 is a proof that                 *)
(*                          fdist_fst PQ a != 0, the result is a              *)
(*                          distribution {fdist B}                            *)
(*      jfdist_cond PQ a == The conditional distribution derived from PQ      *)
(*                          given a; same as fdist_cond0 when                 *)
(*                          fdist_fst PQ a != 0.                              *)
(*           PQ `(| a |) == notation jfdist_cond PQ a                         *)
(*                                                                            *)
(******************************************************************************)

Reserved Notation "\Pr_ P [ A | B ]" (at level 6, P, A, B at next level,
  format "\Pr_ P [ A  |  B ]").
Reserved Notation "\Pr_[ A | B ]" (at level 6, A, B at next level,
  format "\Pr_[ A  |  B ]").
Reserved Notation "P `(| a ')'" (at level 6, a at next level, format "P `(| a )").

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.
Local Open Scope proba_scope.
Local Open Scope fdist_scope.

Section conditional_probability.
Variables (A B : finType) (P : {fdist A * B}).
Implicit Types (E : {set A}) (F : {set B}).

Definition jcPr E F := Pr P (E `* F) / Pr (P`2) F.

Local Notation "\Pr_[ E | F ]" := (jcPr E F).

Lemma jcPrE E F : \Pr_[E | F] = `Pr_P [E `*T | T`* F].
Proof. by rewrite /jcPr -Pr_setTX setTE /cPr EsetT setIX !(setIT,setTI). Qed.

Lemma jcPrET E : \Pr_[E | setT] = Pr P`1 E.
Proof. by rewrite jcPrE TsetT cPrET -Pr_XsetT EsetT. Qed.

Lemma jcPrE0 E : \Pr_[E | set0] = 0.
Proof. by rewrite jcPrE Tset0 cPrE0. Qed.

Lemma jcPr_ge0 E F : 0 <= \Pr_[E | F].
Proof. by rewrite jcPrE. Qed.

Lemma jcPr_le1 E F : \Pr_[E | F] <= 1.
Proof. by rewrite jcPrE; exact: cPr_max. Qed.

Lemma jcPr_gt0 E F : 0 < \Pr_[E | F] <-> \Pr_[E | F] != 0.
Proof. by rewrite !jcPrE; apply cPr_gt0. Qed.

Lemma Pr_jcPr_gt0 E F : 0 < Pr P (E `* F) <-> 0 < \Pr_[E | F].
Proof.
split.
- rewrite -{1}(setIT E) -{1}(setIT F) (setIC F) -setIX jcPrE.
  by move/Pr_cPr_gt0; rewrite -setTE -EsetT.
- move=> H; rewrite -{1}(setIT E) -{1}(setIT F) (setIC F) -setIX.
  by apply/Pr_cPr_gt0; move: H; rewrite jcPrE -setTE -EsetT.
Qed.

Lemma jcPr_cplt E F : Pr (P`2) F != 0 -> \Pr_[ ~: E | F] = 1 - \Pr_[E | F].
Proof.
by move=> PF0; rewrite 2!jcPrE EsetT setCX cPr_cplt ?EsetT // setTE Pr_setTX.
Qed.

Lemma jcPr_diff E1 E2 F : \Pr_[E1 :\: E2 | F] = \Pr_[E1 | F] - \Pr_[E1 :&: E2 | F].
Proof.
rewrite jcPrE DsetT cPr_diff jcPrE; congr (_ - _).
by rewrite 2!EsetT setIX setTI -EsetT jcPrE.
Qed.

Lemma jcPr_union_eq E1 E2 F :
  \Pr_[E1 :|: E2 | F] = \Pr_[E1 | F] + \Pr_[E2 | F] - \Pr_[E1 :&: E2 | F].
Proof. by rewrite jcPrE UsetT cPr_union_eq !jcPrE IsetT. Qed.

Section total_probability.
Variables (I : finType) (E : {set A}) (F : I -> {set B}).
Let P' := fdistX P.
Hypothesis dis : forall i j, i != j -> [disjoint F i & F j].
Hypothesis cov : cover (F @: I) = [set: B].

Lemma jtotal_prob_cond : Pr P`1 E = \sum_(i in I) \Pr_[E | F i] * Pr P`2 (F i).
Proof.
rewrite -Pr_XsetT -EsetT.
rewrite (@total_prob_cond _ _ _ _ (fun i => T`* F i)); last 2 first.
  - move=> i j ij; rewrite -setI_eq0 !setTE setIX setTI.
    by move: (dis ij); rewrite -setI_eq0 => /eqP ->; rewrite setX0.
  - (* TODO: lemma? *) apply/setP => -[a b]; rewrite inE /cover.
    apply/bigcupP => /=.
    move: cov; rewrite /cover => /setP /(_ b).
    rewrite !inE => /bigcupP[b'].
    move/imsetP => [i _ ->{b'} bFi].
    exists (T`* F i).
      by apply/imsetP; exists i.
    by rewrite inE.
by apply eq_bigr => i _; rewrite -Pr_setTX -setTE; congr (_ * _); rewrite jcPrE.
Qed.

End total_probability.

End conditional_probability.
Notation "\Pr_ P [ E | F ]" := (jcPr P E F) : proba_scope.

Section jPr_Pr.
Variables (U : finType) (P : fdist U) (A B : finType).
Variables (X : {RV P -> A}) (Y : {RV P -> B}) (E : {set A}) (F : {set B}).

Lemma jPr_Pr : \Pr_(`p_[% X, Y]) [E | F] = `Pr[X \in E |Y \in F].
Proof.
rewrite /jcPr Pr_fdistmap_RV2/= cpr_eq_setE /cPr; congr (_ / _).
rewrite Pr_fdist_snd setTE Pr_fdistmap_RV2/=.
rewrite (_ : [set x | X x \in [set: A]] = setT) ?setTI//.
by apply/setP => x; rewrite !inE.
Qed.

End jPr_Pr.

Section bayes.
Variables (A B : finType) (PQ : {fdist A * B}).
Let P := PQ`1. Let Q := PQ`2. Let QP := fdistX PQ.
Implicit Types (E : {set A}) (F : {set B}).

Lemma jBayes E F : \Pr_PQ[E | F] = \Pr_QP [F | E] * Pr P E / Pr Q F.
Proof.
rewrite 2!jcPrE Bayes /Rdiv -2!mulRA.
rewrite EsetT Pr_XsetT setTE Pr_setTX /cPr; congr ((_ / _) * (_ / _)).
  by rewrite EsetT setTE [in RHS]setIX Pr_fdistX setIX.
by rewrite setTE Pr_fdistX.
Qed.

Lemma jBayes_extended (I : finType) (E : I -> {set A}) (F : {set B}) :
  (forall i j, i != j -> [disjoint E i & E j]) ->
  cover [set E i | i in I] = [set: A] ->
  forall i,
  \Pr_PQ [E i | F] = (\Pr_QP [F | E i] * Pr P (E i)) /
                     \sum_(j in I) \Pr_ QP [F | E j] * Pr P (E j).
Proof.
move=> dis cov i; rewrite jBayes; congr (_ / _).
move: (@jtotal_prob_cond _ _ QP I F E dis cov).
rewrite {1}/QP fdistX1 => ->.
by apply eq_bigr => j _; rewrite -/QP {2}/QP fdistX2.
Qed.

End bayes.

Section conditional_probability_prop3.
Variables (A B C : finType) (P : {fdist A * B * C}).

Lemma jcPr_TripC12 (E : {set A}) (F : {set B }) (G : {set C}) :
  \Pr_(fdistC12 P)[F `* E | G] = \Pr_P[E `* F | G].
Proof. by rewrite /jcPr Pr_fdistC12 fdistC12_snd. Qed.

Lemma jcPr_fdistA_AC (E : {set A}) (F : {set B}) (G : {set C}) :
  \Pr_(fdistA (fdistAC P))[E | G `* F] = \Pr_(fdistA P)[E | F `* G].
Proof.
rewrite /jcPr 2!Pr_fdistA Pr_fdistAC; congr (_ / _).
by rewrite fdistA_AC_snd -Pr_fdistX fdistXI.
Qed.

Lemma jcPr_fdistA_C12 (E : {set A}) (F : {set B}) (G : {set C}) :
  \Pr_(fdistA (fdistC12 P))[F | E `* G] = \Pr_(fdistA (fdistX (fdistA P)))[F | G `* E].
Proof.
rewrite /jcPr; congr (_ / _).
  by rewrite Pr_fdistA Pr_fdistC12 Pr_fdistA -[in RHS]Pr_fdistX fdistXI Pr_fdistA.
rewrite -/(fdist_proj13 _) -(fdistXI (fdist_proj13 P)) -Pr_fdistX fdistXI; congr Pr.
(* TODO: lemma? *)
by rewrite /fdist_proj13 /fdistX /fdist_snd /fdistA !fdistmap_comp.
Qed.

End conditional_probability_prop3.

Section product_rule.

Section main.
Variables (A B C : finType) (P : {fdist A * B * C}).
Implicit Types (E : {set A}) (F : {set B}) (G : {set C}).

Lemma jproduct_rule_cond E F G :
  \Pr_P [E `* F | G] = \Pr_(fdistA P) [E | F `* G] * \Pr_(fdist_proj23 P) [F | G].
Proof.
rewrite /jcPr; rewrite !mulRA; congr (_ * _); last by rewrite fdist_proj23_snd.
rewrite -mulRA -/(fdist_proj23 _) -Pr_fdistA.
case/boolP : (Pr (fdist_proj23 P) (F `* G) == 0) => H; last by rewrite mulVR ?mulR1.
suff -> : Pr (fdistA P) (E `* (F `* G)) = 0 by rewrite mul0R.
by rewrite Pr_fdistA; exact/Pr_fdist_proj23_domin/eqP.
Qed.

End main.

Section variant.
Variables (A B C : finType) (P : {fdist A * B * C}).
Implicit Types (E : {set A}) (F : {set B}) (G : {set C}).

Lemma product_ruleC E F G :
  \Pr_P [ E `* F | G] = \Pr_(fdistA (fdistC12 P)) [F | E `* G] * \Pr_(fdist_proj13 P) [E | G].
Proof. by rewrite -jcPr_TripC12 jproduct_rule_cond. Qed.

End variant.

Section prod.
Variables (A B : finType) (P : {fdist A * B}).
Implicit Types (E : {set A}) (F : {set B}).

Lemma jproduct_rule E F : Pr P (E `* F) = \Pr_P[E | F] * Pr (P`2) F.
Proof.
have [/eqP PF0|PF0] := boolP (Pr (P`2) F == 0).
  rewrite jcPrE /cPr -{1}(setIT E) -{1}(setIT F) -setIX.
  rewrite Pr_domin_setI; last by rewrite -Pr_fdistX Pr_domin_setX // fdistX1.
  by rewrite setIC Pr_domin_setI ?(div0R,mul0R) // setTE Pr_setTX.
rewrite -{1}(setIT E) -{1}(setIT F) -setIX product_rule.
rewrite -EsetT setTT cPrET Pr_setT mulR1 jcPrE.
rewrite /cPr {1}setTE {1}EsetT.
by rewrite setIX setTI setIT setTE Pr_setTX -mulRA mulVR ?mulR1.
Qed.

End prod.

End product_rule.

Lemma jcPr_fdistmap_r (A B B' : finType) (f : B -> B') (d : {fdist A * B})
    (E : {set A}) (F : {set B}): injective f ->
  \Pr_d [E | F] = \Pr_(fdistmap (fun x => (x.1, f x.2)) d) [E | f @: F].
Proof.
move=> injf; rewrite /jcPr; congr (_ / _).
- rewrite (@Pr_fdistmap _ _ (fun x => (x.1, f x.2))) /=; last first.
    by move=> [? ?] [? ?] /= [-> /injf ->].
  congr (Pr _ _); apply/setP => -[a b]; rewrite !inE /=.
  apply/imsetP/andP.
  - case=> -[a' b']; rewrite inE /= => /andP[a'E b'F] [->{a} ->{b}]; split => //.
    apply/imsetP; by exists b'.
  - case=> aE /imsetP[b' b'F] ->{b}; by exists (a, b') => //; rewrite inE /= aE.
by rewrite /fdist_snd fdistmap_comp (@Pr_fdistmap _ _ f) // fdistmap_comp.
Qed.
Arguments jcPr_fdistmap_r [A] [B] [B'] [f] [d] [E] [F] _.

Lemma jcPr_fdistmap_l (A A' B : finType) (f : A -> A') (d : {fdist A * B})
    (E : {set A}) (F : {set B}): injective f ->
  \Pr_d [E | F] = \Pr_(fdistmap (fun x => (f x.1, x.2)) d) [f @: E | F].
Proof.
move=> injf; rewrite /jcPr; congr (_ / _).
- rewrite (@Pr_fdistmap _ _ (fun x => (f x.1, x.2))) /=; last first.
    by move=> [? ?] [? ?] /= [/injf -> ->].
  congr (Pr _ _); apply/setP => -[a b]; rewrite !inE /=.
  apply/imsetP/andP.
  - case=> -[a' b']; rewrite inE /= => /andP[a'E b'F] [->{a} ->{b}]; split => //.
    apply/imsetP; by exists a'.
  - by case=> /imsetP[a' a'E] ->{a} bF; exists (a', b) => //; rewrite inE /= a'E.
by rewrite /fdist_snd !fdistmap_comp.
Qed.
Arguments jcPr_fdistmap_l [A] [A'] [B] [f] [d] [E] [F] _.

Lemma Pr_jcPr_unit (A : finType) (E : {set A}) (P : {fdist A}) :
  Pr P E = \Pr_(fdistmap (fun a => (a, tt)) P) [E | setT].
Proof.
rewrite /jcPr (Pr_set1 _ tt).
rewrite (_ : _`2 = fdist1 tt) ?fdist1xx ?divR1; last first.
  rewrite /fdist_snd fdistmap_comp; apply/fdist_ext; case.
  by rewrite fdistmapE fdist1xx (eq_bigl xpredT) // FDist.f1.
rewrite /Pr big_setX /=; apply eq_bigr => a _; rewrite (big_set1 _ tt) /=.
rewrite fdistmapE (big_pred1 a) // => a0; rewrite inE /=.
by apply/eqP/eqP => [[] -> | ->].
Qed.

Section jfdist_cond0.
Variables (A B : finType) (PQ : {fdist A * B}) (a : A).
Hypothesis Ha : PQ`1 a != 0.

Let f := [ffun b => \Pr_(fdistX PQ) [[set b] | [set a]]].

Let f0 b : 0 <= f b. Proof. rewrite ffunE; exact: jcPr_ge0. Qed.

Let f1 : \sum_(b in B) f b = 1.
Proof.
under eq_bigr do rewrite ffunE.
by rewrite /jcPr -big_distrl /= PrX_snd mulRV // Pr_set1 fdistX2.
Qed.

Definition jfdist_cond0 : {fdist B} := locked (FDist.make f0 f1).

Lemma jfdist_cond0E b : jfdist_cond0 b = \Pr_(fdistX PQ) [[set b] | [set a]].
Proof. by rewrite /jfdist_cond0; unlock; rewrite ffunE. Qed.

End jfdist_cond0.
Arguments jfdist_cond0 {A} {B} _ _ _.

Section jfdist_cond.
Variables (A B : finType) (PQ : {fdist A * B}) (a : A).
Let Ha := PQ`1 a != 0.

Let sizeB : #|B| = #|B|.-1.+1.
Proof.
case HB: #|B| => //.
by move: (fdist_card_neq0 PQ); rewrite card_prod HB muln0 ltnn.
Qed.

Definition jfdist_cond :=
  match boolP Ha with
  | AltTrue H => jfdist_cond0 PQ _ H
  | AltFalse _ => fdist_uniform sizeB
  end.

Lemma jfdist_condE (H : Ha) b : jfdist_cond b = \Pr_(fdistX PQ) [[set b] | [set a]].
Proof.
by rewrite /jfdist_cond; destruct boolP; [rewrite jfdist_cond0E|rewrite H in i].
Qed.

Lemma jfdist_cond_dflt (H : ~~ Ha) : jfdist_cond = fdist_uniform sizeB.
Proof.
by rewrite /jfdist_cond; destruct boolP => //; rewrite i in H.
Qed.

End jfdist_cond.
Notation "P `(| a ')'" := (jfdist_cond P a).

Lemma cPr_1 (U : finType) (P : fdist U) (A B : finType)
  (X : {RV P -> A}) (Y : {RV P -> B}) a : `Pr[X = a] != 0 ->
  \sum_(b <- fin_img Y) `Pr[ Y = b | X = a ] = 1.
Proof.
rewrite -pr_eq_set1 pr_inE' Pr_set1 -{1}(fst_RV2 _ Y) => Xa0.
set Q := `p_[% X, Y] `(| a ).
rewrite -(FDist.f1 Q) [in RHS](bigID (mem (fin_img Y))) /=.
rewrite [X in _ = _ + X](eq_bigr (fun=> 0)); last first.
  move=> b bY.
  rewrite /Q jfdist_condE // /jcPr /Pr !(big_setX,big_set1) /= fdistXE fdistX2 fst_RV2.
  rewrite -!pr_eqE' !pr_eqE.
  rewrite /Pr big1 ?div0R // => u.
  rewrite inE => /eqP[Yub ?].
  exfalso.
  move/negP : bY; apply.
  by rewrite mem_undup; apply/mapP; exists u => //; rewrite mem_enum.
rewrite big_const iter_addR mulR0 addR0.
rewrite big_uniq; last by rewrite /fin_img undup_uniq.
apply eq_bigr => b; rewrite mem_undup => /mapP[u _ bWu].
rewrite /Q jfdist_condE // fdistX_RV2.
by rewrite jcPrE -cpr_inE' cpr_eq_set1.
Qed.

Lemma jcPr_1 (A B : finType) (P : {fdist A * B}) a : P`1 a != 0 ->
  \sum_(b in B) \Pr_(fdistX P)[ [set b] | [set a] ] = 1.
Proof.
move=> Xa0; rewrite -(FDist.f1 (P `(| a ))); apply eq_bigr => b _.
by rewrite jfdist_condE.
Qed.

Lemma jfdist_cond_prod (A B : finType) (P : fdist A) (W : A -> fdist B) (a : A) :
  (P `X W)`1 a != 0 -> W a = (P `X W) `(| a ).
Proof.
move=> a0; apply/fdist_ext => b.
rewrite jfdist_condE // /jcPr setX1 !Pr_set1 fdistXE fdistX2 fdist_prod1.
rewrite fdist_prodE /= /Rdiv mulRAC mulRV ?mul1R //.
by move: a0; rewrite fdist_prod1.
Qed.

Lemma jcPr_fdistX_prod (A B : finType) (P : fdist A) (W : A -> fdist B) a b :
  P a <> 0 -> \Pr_(fdistX (P `X W))[ [set b] | [set a] ] = W a b.
Proof.
move=> Pxa.
rewrite /jcPr setX1 fdistX2 2!Pr_set1 fdistXE fdist_prod1.
by rewrite fdist_prodE /= /Rdiv mulRAC mulRV ?mul1R //; exact/eqP.
Qed.

Section fdist_split.
Variables (A B : finType).

Definition fdist_split (PQ : {fdist A * B}) := (PQ`1, fun x => PQ `(| x )).

Lemma fdist_prodK : cancel fdist_split (uncurry (@fdist_prod A B)).
Proof.
move=> PQ; apply/fdist_ext => ab; rewrite fdist_prodE.
have [Ha|Ha] := eqVneq (PQ`1 ab.1) 0.
  rewrite Ha mul0R; apply/esym/(dominatesE (Prod_dominates_Joint PQ)).
  by rewrite fdist_prodE Ha mul0R.
rewrite jfdist_condE // -fdistX2 mulRC.
rewrite -(Pr_set1 _ ab.1) -jproduct_rule setX1 Pr_set1 fdistXE.
by case ab.
Qed.

End fdist_split.


(* This file contains all basic definitions from Section 4. *)

Require Export Arith.
Require Export Relations.

CoInductive term : Set :=
| bot : term
| var : nat -> term
| app : term -> term -> term
| abs : term -> term.

CoInductive par_clos (R : relation term) : relation term :=
| par_clos_base : forall x y, R x y -> par_clos R x y
| par_clos_bot : par_clos R bot bot
| par_clos_var : forall n, par_clos R (var n) (var n)
| par_clos_app : forall x y x' y', par_clos R x x' -> par_clos R y y' -> par_clos R (app x y) (app x' y')
| par_clos_abs : forall x y, par_clos R x y -> par_clos R (abs x) (abs y).

(* equality (identity) of infinitary terms *)
Definition term_eq := par_clos (fun _ _ => False).

Notation "A == B" := (term_eq A B) (at level 70).
Notation "A != B" := (~(term_eq A B)) (at level 70).

Definition morphism (R : relation term) := forall x y, R x y -> forall x' y', x == x' -> y == y' -> R x' y'.

CoFixpoint shift d c t : term :=
  match t with
    | bot => bot
    | var n => var (if c <=? n then n + d else n)
    | app t1 t2 => app (shift d c t1) (shift d c t2)
    | abs t1 => abs (shift d (c+1) t1)
  end.

Definition shift_closed (R : relation term) :=
  forall d c t t', R t t' -> R (shift d c t) (shift d c t').

CoFixpoint subst n s t : term :=
  match t with
  | bot => bot
  | var m => if n <? m then var (m - 1) else if n =? m then shift n 0 s else var m
  | app t1 t2 => app (subst n s t1) (subst n s t2)
  | abs t' => abs (subst (n+1) s t')
  end.

Notation "A [ N := B ]" := (subst N B A) (at level 50).

Definition subst_closed (R : relation term) :=
  forall x x' n y, R x x' -> R (x[n := y]) (x'[n := y]).

Inductive beta_redex : relation term :=
| beta_redex_c : forall x y t1 t2, x == (app (abs t1) t2) -> y == (t1[0 := t2]) ->
                                   beta_redex x y.

Inductive comp_clos (R : relation term) : relation term :=
| comp_clos_base : forall x y, R x y -> comp_clos R x y
| comp_clos_app_l : forall x y x' y', comp_clos R x x' -> y == y' -> comp_clos R (app x y) (app x' y')
| comp_clos_app_r : forall x y x' y', comp_clos R y y' -> x == x' -> comp_clos R (app x y) (app x' y')
| comp_clos_abs : forall x y, comp_clos R x y -> comp_clos R (abs x) (abs y).

(* beta reduction step *)
Definition step_beta := comp_clos beta_redex.

Inductive star (R : relation term) : relation term :=
| star_refl : forall x y, x == y -> star R x y
| star_step : forall x y z, R x y -> star R y z -> star R x z.

(* finitary beta reduction *)
Definition red_beta := star step_beta.

CoInductive inf_clos (R : relation term) : relation term :=
| inf_clos_bot : forall s, R s bot -> inf_clos R s bot
| inf_clos_var : forall s n, R s (var n) -> inf_clos R s (var n)
| inf_clos_app : forall s x y x' y', R s (app x y) -> inf_clos R x x' -> inf_clos R y y' ->
                                     inf_clos R s (app x' y')
| inf_clos_abs : forall s x x', R s (abs x) -> inf_clos R x x' -> inf_clos R s (abs x').

Definition aux_clos (R : relation term) := inf_clos (inf_clos (star R)).

(* infinitary beta reduction *)
Definition inf_beta := inf_clos red_beta.

(* weak head reduction step *)
Inductive step_wh : relation term :=
| wh_base : forall x y, beta_redex x y -> step_wh x y
| wh_step : forall x x' y y', step_wh x x' -> y == y' -> step_wh (app x y) (app x' y').

Definition red_wh := star step_wh.
Definition inf_wh := inf_clos red_wh.

Definition is_abs t := match t with abs _ => True | _ => False end.

Definition is_rnf (t : term) :=
  match t with
  | bot => False
  | var _ => True
  | abs _ => True
  | app x y => forall z, inf_beta x z -> ~(is_abs z)
  end.

Definition has_rnf t := exists t', is_rnf t' /\ inf_beta t t'.
Definition root_active t := ~(has_rnf t).

Definition sim (U : term -> Prop) := par_clos (fun x y => U x /\ U y).

Definition meaningless (U : term -> Prop) :=
  (forall x y, U x -> inf_beta x y -> U y) /\
  (forall x y n, U x -> U (x[n := y])) /\
  (forall x d c, U x -> U (shift d c x)) /\
  (forall x y, U (abs x) -> U (app (abs x) y)) /\
  (forall x, root_active x -> U x) /\
  (forall x y, U x -> sim U x y -> U y).

Definition strongly_meaningless (U : term -> Prop) :=
  meaningless U /\ forall x y, U y -> inf_beta x y -> U x.

Definition bot_redex (U : term -> Prop) (x y : term) := U x /\ x != bot /\ y == bot.
Definition beta_bot_redex U x y := beta_redex x y \/ bot_redex U x y.
Definition step_bot U := comp_clos (bot_redex U).
Definition step_beta_bot U := comp_clos (beta_bot_redex U).
Definition red_beta_bot U := star (step_beta_bot U).
Definition inf_beta_bot U := inf_clos (red_beta_bot U).
Definition par_beta_bot U := par_clos (beta_bot_redex U).
Definition par_bot U := par_clos (bot_redex U).

Definition nf (R : relation term) (t : term) := forall s, ~(R t s).
Hint Unfold nf.

Definition nf_beta := nf step_beta.
Definition nf_beta_bot U := nf (step_beta_bot U).

(************************************************************************)
(* Assumed axioms: constructive indefinite description (see cases.v)
   and some specializations of the excluded middle. *)

Axiom is_rnf_xm : forall t, is_rnf t \/ ~(is_rnf t).
Axiom has_rnf_xm : forall t, has_rnf t \/ ~(has_rnf t).
Axiom strongly_meaningless_xm : forall U, strongly_meaningless U -> forall t, U t \/ ~(U t).


Set Implicit Arguments.
(** * Possibly terminating streams

    We conceptualize the traditional unix pipeline programs as
    transformations on streams. These streams are neither traditional
    lists, which must terminate, nor traditional coinductive streams,
    which must not, so we use a hybrid of the two. *)

CoInductive pt_stream (A : Type) : Type :=
| nil : pt_stream A
| cons : A -> pt_stream A -> pt_stream A.

(** pt_streams are equal when they're bisimulationally-equivalent
    infinite streams or the same finite stream. *)
CoInductive pt_stream_eq (A : Type) : pt_stream A -> pt_stream A -> Prop :=
| pt_stream_eq_nil : pt_stream_eq (nil A) (nil A)
| pt_stream_eq_cons : forall {a} {tl1} {tl2}, pt_stream_eq tl1 tl2 -> pt_stream_eq (cons a tl1) (cons a tl2).

(** Concatenate two streams *)
CoFixpoint app {A : Type} (fst : pt_stream A) (snd : pt_stream A) : pt_stream A :=
  match fst with
  | nil _ => snd
  | cons a tl => cons a (app tl snd)
  end.


(** * RIS.algebra : algebraic structures. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import tools.

(** * Definitions *)
Section algebra.
  (** Let [A] be some type equipped with an equivalence relation [⩵] and a partial order [≦]. *)
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  (** We introduce some notations. *)
  Class Un := un : A.
  Notation " 𝟭 " := un.

  Class Zero := zero : A.
  Notation " 𝟬 " := zero.

  Class Product := prod : A -> A -> A.
  Infix " · " := prod (at level 40).

  Class Join := join : A -> A -> A.
  Infix " ∪ " := join (at level 45).

  Class Star := star : A -> A.
  Notation " e ⋆ " := (star e) (at level 35).

  (** ** Basic properties *)
  Class Associative (prod : A -> A -> A) :=
    associative : (forall a b c : A, prod a (prod b c) ⩵ prod (prod a b) c).
  Class Commutative (prod : A -> A -> A) :=
    commutative : (forall a b : A, prod a b ⩵ prod b a).
  Class Idempotent (prod : A -> A -> A) :=
    idempotent : (forall a : A, prod a a ⩵ a).
  Class Unit (prod : A -> A -> A) (unit : A) :=
    {
      left_unit : forall a : A, prod unit a ⩵ a;
      right_unit : forall a : A, prod a unit ⩵ a
    }.
  Class Absorbing (prod : A -> A -> A) (z : A) :=
    {
      left_absorbing : forall a : A, prod z a ⩵ z;
      right_absorbing : forall a : A, prod a z ⩵ z
    }.

  (** ** Basic structures *)
  Class Monoid (prod : A -> A -> A) (unit : A) :=
    {
      mon_congr :> Proper (eqA ==> eqA ==> eqA) prod;
      mon_assoc :> Associative prod;
      mon_unit :> Unit prod unit;
    }.

  Class Semilattice (join : A -> A -> A) :=
    {
      lat_congr :> Proper (eqA ==> eqA ==> eqA) join;
      lat_assoc :> Associative join;
      lat_comm :> Commutative join;
      lat_idem :> Idempotent join;
    }.

  Class Lattice (m j : A -> A -> A) :=
    {
      lat_meet_congr :> Proper (eqA ==> eqA ==> eqA) m;
      lat_meet_assoc :> Associative m;
      lat_meet_comm :> Commutative m;
      lat_join_congr :> Proper (eqA ==> eqA ==> eqA) j;
      lat_join_assoc :> Associative j;
      lat_join_comm :> Commutative j;
      lat_join_meet : forall a b, j a (m a b) ⩵ a;
      lat_meet_join : forall a b, m a (j a b) ⩵ a;
    }.

  Class SemiRing (prod add : A -> A -> A) (u z : A) :=
    {
      semiring_prod :> Monoid prod u;
      semiring_add :> Monoid add z;
      semiring_comm :> Commutative add;
      semiring_zero :> Absorbing prod z;
      semiring_left_distr : forall a b c, prod a (add b c) ⩵ add (prod a b) (prod a c);
      semiring_right_distr : forall a b c, prod (add a b) c ⩵ add (prod a c) (prod b c);
    }.

  (** ** Join semi-lattices *)
  Section order.
    Context {j : Join}.
    Context {S : Semilattice join}.

    Definition leqA : relation A := (fun x y => y ⩵ x ∪ y).
    Infix " ≦ " := leqA (at level 80).

    Global Instance preA : PreOrder leqA.
    Proof.
      destruct S as [p ass comm id];unfold leqA.
      split.
      - intro x;symmetry;apply id.
      - intros x y z e1 e2.
        rewrite e2 at 2.
        rewrite (ass x y z),<- e1.
        apply e2.
    Qed.

    Global Instance partialA : PartialOrder eqA leqA.
    Proof.
      destruct S as [p ass comm id].
      intros x y;unfold Basics.flip,leqA;split.
      - intros E;split.
        + rewrite E,(id y);reflexivity.
        + rewrite E;symmetry;apply id.
      - intros (E1&E2).
        rewrite E1.
        rewrite E2 at 1.
        apply comm.
    Qed.

    Lemma refactor e f g h : (e ∪ f) ∪ (g ∪ h) ⩵ (e ∪ g) ∪ (f ∪ h).
    Proof.
      rewrite (lat_assoc (e∪f) g h).
      rewrite <- (lat_assoc e f g).
      rewrite (@lat_comm _ S f g).
      rewrite (lat_assoc e g f).
      rewrite (lat_assoc (e∪g) f h).
      reflexivity.
    Qed.

    Global Instance proper_join_inf : Proper (leqA ==> leqA ==> leqA) join.
    Proof.
      intros x y I x' y' I';unfold leqA in *.
      rewrite I,I' at 1;apply refactor.
    Qed.

    Lemma inf_cup_left a b : a ≦ a ∪ b.
    Proof. unfold leqA; rewrite (lat_assoc _ _ _),(lat_idem _);reflexivity. Qed.

    Lemma inf_cup_right a b : b ≦ a ∪ b.
    Proof. rewrite (lat_comm a b);apply inf_cup_left. Qed.

    Lemma inf_join_inf a b c : a ≦ c -> b ≦ c -> a ∪ b ≦ c.
    Proof. intros;rewrite <- (lat_idem c); apply proper_join_inf;assumption. Qed.

    Context {z : Zero} {u : Unit join zero}.

    Lemma zero_minimal x : zero ≦ x.
    Proof. unfold leqA;symmetry ;apply left_unit. Qed.

  End order.

  Infix " ≦ " := leqA (at level 80).

  (** ** Kleene algebra and Boolean algebra *)
  Class KleeneAlgebra (j: Join) (p: Product) (z: Zero) (u:Un) (s:Star) :=
    {
      ka_star_congr :> Proper (eqA ==> eqA) star;
      ka_semiring :> SemiRing prod join un zero;
      ka_idem :> Idempotent join;
      ka_star_unfold : forall a, 𝟭 ∪ a · a ⋆ ≦ a⋆ ;
      ka_star_left_ind : forall a b, a · b ≦ b -> a ⋆ · b ≦ b;
      ka_star_right_ind : forall a b, a · b ≦ a -> a · b ⋆ ≦ a;
    }.

  Class BooleanAlgebra (t f : A) (n : A -> A) (c d: A -> A -> A) :=
    {
      proper_c :> Proper (eqA ==> eqA ==> eqA) c;
      proper_d :> Proper (eqA ==> eqA ==> eqA) d;
      proper_n :> Proper (eqA ==> eqA) n;
      ba_conj_comm :> Commutative c;
      ba_disj_comm :> Commutative d;
      ba_true : forall a, c a t ⩵ a;
      ba_false : forall a, d a f ⩵ a;
      ba_conj_disj : forall x y z, c x (d y z) ⩵ d (c x y) (c x z);
      ba_disj_conj : forall x y z, d x (c y z) ⩵ c (d x y) (d x z);
      ba_neg_conj : forall a, c a (n a) ⩵ f;
      ba_neg_disj : forall a, d a (n a) ⩵ t;
    }.

End algebra.
Arguments Zero: clear implicits.
Arguments Un: clear implicits.
Arguments Product: clear implicits.
Arguments Join: clear implicits.
Arguments Star: clear implicits.
Notation " 𝟭 " := un.
Notation " 𝟬 " := zero.
Infix " · " := prod (at level 40).
Infix " ∪ " := join (at level 45).
Notation " e ⋆ " := (star e) (at level 35).

Arguments KleeneAlgebra : clear implicits.
Arguments KleeneAlgebra A eqA {j p z u s}.
Arguments SemiRing : clear implicits.
Arguments Semilattice : clear implicits.
Arguments BooleanAlgebra : clear implicits.
Arguments BooleanAlgebra {A} eqA t f n c d.
Arguments leqA : clear implicits.
Arguments leqA {A} eqA {j}.

(** * Facts about boolean algebra *)
Section booleanAlgebra.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).
  Context {top bot : A} {neg : A -> A} {conj disj : A -> A -> A}.
  Context `{BooleanAlgebra A eqA top bot neg conj disj}.

  Notation " ⊤ " := top.
  Notation " ⊥ " := bot.
  Notation " ¬ " := neg.
  Infix " ∧ " := conj (at level 40).
  Infix " ∨ " := disj (at level 45).

  (** When we defined boolean algebra before, we relied on
  Huntington's 1904 axiomatization, which differs from the usual way
  they are defined, but is much more concise. We now show that this
  axiomatization indeed implies all the properties we expect of a
  boolean algebra. The following subsection is a straightforward
  adaptation of the proofs detailed on the wikipedia page of boolean
  algebra:
  #en.wikipedia.org/wiki/Boolean_algebra_(structure)#.*)

  (** ** Elementary properties *)
  Lemma UId1 o : (forall x, x ∨ o ⩵ x) -> o ⩵ ⊥.
  Proof.
    intros hyp.
    rewrite <- (ba_false o).
    rewrite (ba_disj_comm _ _).
    apply hyp.
  Qed.

  Lemma Idm1 x : x ∨ x ⩵ x.
  Proof.
    rewrite <- (ba_true (x∨x)),<-(ba_neg_disj x).
    rewrite <- ba_disj_conj,ba_neg_conj.
    apply ba_false.
  Qed.

  Lemma Bnd1 x : x ∨ ⊤ ⩵ ⊤.
  Proof.
    rewrite <- (ba_true (x∨⊤)),(ba_conj_comm _ _).
    rewrite <- (ba_neg_disj x) at 1.
    rewrite <- ba_disj_conj,ba_true.
    apply ba_neg_disj.
  Qed.

  Lemma Abs1 x y : x ∨ (x ∧ y) ⩵ x.
  Proof.
    rewrite <- (ba_true x) at 1.
    rewrite <- ba_conj_disj,(ba_disj_comm _ _),Bnd1.
    apply ba_true.
  Qed.

  Lemma UId2 o : (forall x, x ∧ o ⩵ x) -> o ⩵ ⊤.
  Proof.
    intros hyp.
    rewrite <- (ba_true o).
    rewrite (ba_conj_comm _ _).
    apply hyp.
  Qed.

  Lemma Idm2 x : x ∧ x ⩵ x.
  Proof.
    rewrite <- (ba_false (x∧x)),<-(ba_neg_conj x).
    rewrite <- ba_conj_disj,ba_neg_disj.
    apply ba_true.
  Qed.

  Lemma Bnd2 x : x ∧ ⊥ ⩵ ⊥.
  Proof.
    rewrite <- (ba_false (x∧⊥)),(ba_disj_comm _ _).
    rewrite <- (ba_neg_conj x) at 1.
    rewrite <- ba_conj_disj,ba_false.
    apply ba_neg_conj.
  Qed.

  Lemma Abs2 x y : x ∧ (x ∨ y) ⩵ x.
  Proof.
    rewrite <- (ba_false x) at 1.
    rewrite <- ba_disj_conj,(ba_conj_comm _ _),Bnd2.
    apply ba_false.
  Qed.

  Lemma UNg x x' : x ∨ x' ⩵ ⊤ -> x ∧ x' ⩵ ⊥ -> x' ⩵ ¬ x.
  Proof.
    intros h1 h2.
    rewrite <- (ba_true x'),<-(ba_neg_disj x),ba_conj_disj,(ba_conj_comm x' _),(ba_conj_comm x' _).
    rewrite h2.
    rewrite <- (ba_neg_conj x),(ba_conj_comm _ _),<-ba_conj_disj.
    rewrite h1.
    apply ba_true.
  Qed.

  Lemma DNg x : ¬(¬ x) ⩵ x.
  Proof.
    symmetry;apply UNg.
    - rewrite (ba_disj_comm _ _);apply ba_neg_disj.
    - rewrite (ba_conj_comm _ _);apply ba_neg_conj.
  Qed.

  Lemma A1 x y : x ∨ (¬ x ∨ y) ⩵ ⊤.
  Proof.
    rewrite <- (ba_true (x∨_)),(ba_conj_comm _ _),<-(ba_neg_disj x).
    rewrite <- ba_disj_conj.
    rewrite Abs2;reflexivity.
  Qed.

  Lemma A2 x y : x ∧ (¬ x ∧ y) ⩵ ⊥.
  Proof.
    rewrite <- (ba_false (x∧_)),(ba_disj_comm _ _),<-(ba_neg_conj x).
    rewrite <- ba_conj_disj.
    rewrite Abs1;reflexivity.
  Qed.

  Lemma B1 x y : (x ∨ y)∨(¬x∧¬y)⩵⊤.
  Proof.
    rewrite ba_disj_conj.
    rewrite (ba_disj_comm _ (¬x)), (ba_disj_comm _ (¬y)).
    rewrite (ba_disj_comm x y) at 2.
    rewrite <- (DNg x) at 2.
    rewrite <- (DNg y) at 3.
    repeat rewrite A1.
    apply ba_true.
  Qed.

  Lemma B2 x y : (x ∧ y)∧(¬x∨¬y)⩵⊥.
  Proof.
    rewrite ba_conj_disj.
    rewrite (ba_conj_comm _ (¬x)), (ba_conj_comm _ (¬y)).
    rewrite (ba_conj_comm x y) at 2.
    rewrite <- (DNg x) at 2.
    rewrite <- (DNg y) at 3.
    repeat rewrite A2.
    apply ba_false.
  Qed.

  Lemma C1 x y : (x ∨ y)∧ (¬x∧¬y)⩵⊥.
  Proof.
    rewrite (ba_conj_comm (x∨_) _),ba_conj_disj.
    rewrite (ba_conj_comm _ x),(ba_conj_comm _ y).
    rewrite (ba_conj_comm _ (¬y)) at 2.
    repeat rewrite A2.
    apply ba_false.
  Qed.

  Lemma C2 x y : (x ∧ y)∨ (¬x∨¬y)⩵⊤.
  Proof.
    rewrite (ba_disj_comm (x∧_) _),ba_disj_conj.
    rewrite (ba_disj_comm _ x),(ba_disj_comm _ y).
    rewrite (ba_disj_comm _ (¬y)) at 2.
    repeat rewrite A1.
    apply ba_true.
  Qed.

  Lemma DMg1 x y : ¬ (x∨y) ⩵ ¬ x ∧ ¬ y.
  Proof.
    symmetry;apply UNg.
    - apply B1.
    - apply C1.
  Qed.

  Lemma DMg2 x y : ¬ (x∧y) ⩵ ¬ x ∨ ¬ y.
  Proof.
    symmetry;apply UNg.
    - apply C2.
    - apply B2.
  Qed.

  Lemma D1 x y z : (x∨(y∨z))∨¬x⩵⊤.
  Proof.
    rewrite (ba_disj_comm _ (¬x)).
    rewrite <- (DNg x) at 2.
    apply A1.
  Qed.

  Lemma D2 x y z : (x∧(y∧z))∧¬x⩵⊥.
  Proof.
    rewrite (ba_conj_comm _ (¬x)).
    rewrite <- (DNg x) at 2.
    apply A2.
  Qed.

  Lemma E1 x y z : y∧(x∨(y∨z))⩵ y.
  Proof.
    rewrite ba_conj_disj,Abs2,(ba_disj_comm _).
    apply Abs1.
  Qed.

  Lemma E2 x y z : y∨(x∧(y∧z))⩵ y.
  Proof.
    rewrite ba_disj_conj,Abs1,(ba_conj_comm _).
    apply Abs2.
  Qed.

  Lemma F1 x y z : (x∨(y∨z))∨¬y ⩵ ⊤.
  Proof.
    rewrite (ba_disj_comm _ (¬ _)).
    rewrite <- ba_true,(ba_conj_comm _ _),<-(ba_neg_disj y) at 1.
    rewrite (ba_disj_comm y),<-ba_disj_conj,E1,(ba_disj_comm _ y).
    apply ba_neg_disj.
  Qed.

  Lemma F2 x y z : (x∧(y∧z))∧¬y ⩵ ⊥.
  Proof.
    rewrite (ba_conj_comm _ (¬ _)).
    rewrite <- ba_false,(ba_disj_comm _ _),<-(ba_neg_conj y) at 1.
    rewrite (ba_conj_comm y),<-ba_conj_disj,E2,(ba_conj_comm _ y).
    apply ba_neg_conj.
  Qed.

  Lemma G1 x y z : (x ∨(y∨z))∨¬z⩵⊤.
  Proof. rewrite (ba_disj_comm y z);apply F1. Qed.

  Lemma G2 x y z : (x ∧(y∧z))∧¬z⩵⊥.
  Proof. rewrite (ba_conj_comm y z);apply F2. Qed.

  Lemma H1 x y z : ¬ ((x∨y)∨z)∧x⩵⊥.
  Proof.
    rewrite DMg1,DMg1.
    rewrite (ba_conj_comm _).
    rewrite <- ba_false,(ba_disj_comm _).
    rewrite <- (ba_neg_conj x) at 1.
    rewrite <- ba_conj_disj,(ba_conj_comm _ (¬z)),E2.
    apply ba_neg_conj.
  Qed.

  Lemma H2 x y z : ¬ ((x∧y)∧z)∨x⩵⊤.
  Proof.
    rewrite DMg2,DMg2.
    rewrite (ba_disj_comm _).
    rewrite <- ba_true,(ba_conj_comm _).
    rewrite <- (ba_neg_disj x) at 1.
    rewrite <- ba_disj_conj,(ba_disj_comm _ (¬z)),E1.
    apply ba_neg_disj.
  Qed.

  Lemma I1 x y z : ¬ ((x∨y)∨z)∧y⩵⊥.
  Proof. rewrite (ba_disj_comm x y);apply H1. Qed.

  Lemma I2 x y z : ¬ ((x∧y)∧z)∨y⩵⊤.
  Proof. rewrite (ba_conj_comm x y);apply H2. Qed.

  Lemma J1 x y z : ¬((x∨y)∨z)∧z⩵⊥.
  Proof. rewrite DMg1,(ba_conj_comm _),(ba_conj_comm (¬ _));apply A2. Qed.

  Lemma J2 x y z : ¬((x∧y)∧z)∨z⩵⊤.
  Proof. rewrite DMg2,(ba_disj_comm _),(ba_disj_comm (¬ _));apply A1. Qed.

  Lemma K1 x y z : (x∨(y∨z))∨¬((x∨y)∨z)⩵⊤.
  Proof.
    repeat rewrite DMg1.
    repeat rewrite ba_disj_conj.
    rewrite D1,F1,G1.
    repeat rewrite ba_true;reflexivity.
  Qed.

  Lemma K2 x y z : (x∧(y∧z))∧¬((x∧y)∧z)⩵⊥.
  Proof.
    repeat rewrite DMg2.
    repeat rewrite ba_conj_disj.
    rewrite D2,F2,G2.
    repeat rewrite ba_false;reflexivity.
  Qed.

  Lemma L1 x y z : (x∨(y∨z))∧¬((x∨y)∨z) ⩵ ⊥.
  Proof.
    rewrite (ba_conj_comm _).
    repeat rewrite ba_conj_disj.
    rewrite H1,I1,J1.
    repeat rewrite ba_false;reflexivity.
  Qed.

  Lemma L2 x y z : (x∧(y∧z))∨¬((x∧y)∧z) ⩵ ⊤.
  Proof.
    rewrite (ba_disj_comm _).
    repeat rewrite ba_disj_conj.
    rewrite H2,I2,J2.
    repeat rewrite ba_true;reflexivity.
  Qed.

  Lemma Ass1 x y z : x∨(y∨z)⩵(x∨y)∨z.
  Proof.
    rewrite <- (DNg ((x∨y)∨z));apply UNg.
    - rewrite (ba_disj_comm _);apply K1.
    - rewrite (ba_conj_comm _);apply L1.
  Qed.

  Lemma Ass2 x y z : x∧(y∧z)⩵(x∧y)∧z.
  Proof.
    rewrite <- (DNg ((x∧y)∧z));apply UNg.
    - rewrite (ba_disj_comm _);apply L2.
    - rewrite (ba_conj_comm _);apply K2.
  Qed.

  (** ** Boolean algebra as other structures*)
  Global Instance BooleanAlgebra_Join_Lattice : @Lattice A eqA conj disj.
  Proof.
    split.
    - apply H.
    - intros x y z;apply Ass2.
    - apply ba_conj_comm.
    - apply H.
    - intros x y z;apply Ass1.
    - apply ba_disj_comm.
    - apply Abs1.
    - apply Abs2.
  Qed.

  Global Instance BooleanAlgebra_Join_Semilattice : Semilattice A eqA disj.
  Proof.
    split.
    - apply H.
    - apply lat_join_assoc.
    - apply lat_join_comm.
    - intros a;apply Idm1.
  Qed.

  Global Instance BooleanAlgebra_Meet_Semilattice : Semilattice A eqA conj.
  Proof.
    split.
    - apply H.
    - apply lat_meet_assoc.
    - apply lat_meet_comm.
    - intros a;apply Idm2.
  Qed.

  Global Instance BooleanAlgebra_Meet_Monoid : @Monoid A eqA conj top.
  Proof.
    split.
    - apply H.
    - apply lat_meet_assoc.
    - split.
      + intro a;etransitivity;[apply lat_meet_comm|apply ba_true].
      + apply ba_true.
  Qed.

  Global Instance BooleanAlgebra_Join_Monoid : @Monoid A eqA disj bot.
  Proof.
    split.
    - apply H.
    - apply lat_join_assoc.
    - split.
      + intro a;etransitivity;[apply lat_join_comm|apply ba_false].
      + apply ba_false.
  Qed.

  Global Instance BooleanAlgebra_Semiring : SemiRing A eqA conj disj top bot.
  Proof.
    split.
    - eapply BooleanAlgebra_Meet_Monoid;eassumption.
    - eapply BooleanAlgebra_Join_Monoid;eassumption.
    - apply lat_join_comm.
    - split.
      + intros a;rewrite (ba_conj_comm _);apply Bnd2.
      + intros a;apply Bnd2.
    - apply ba_conj_disj.
    - intros x y z;rewrite (ba_conj_comm _),ba_conj_disj.
      repeat rewrite (ba_conj_comm z);reflexivity.
  Qed.

End booleanAlgebra.

(** * Kleene algebras *)
Section ka_facts.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context {j: Join A}{p: Product A}{z: Zero A}{u:Un A}{s:Star A}.
  Context {ka: KleeneAlgebra A eqA}.

  Infix " ≦ " := (leqA eqA) (at level 80).

  Global Instance proper_prod_inf : Proper (leqA eqA ==> leqA eqA ==> leqA eqA) prod.
  Proof.
    intros e f I e' f' I'.
    unfold leqA in *.
    rewrite I' at 1.
    rewrite semiring_left_distr.
    rewrite I at 1.
    rewrite semiring_right_distr.
    rewrite <- (mon_assoc _ _ _).
    rewrite <- semiring_left_distr.
    rewrite <- I'.
    reflexivity.
  Qed.

  Global Instance join_semilattice : Semilattice A eqA join.
  Proof. split;apply ka. Qed.

  Lemma ka_star_unfold_eq a : a⋆ ⩵ 𝟭 ∪ a · a ⋆.
  Proof.
    apply antisymmetry.
    - etransitivity;[|apply ka_star_left_ind with (a0:=a)].
      + rewrite (semiring_left_distr _ _ _).
        rewrite right_unit.
        apply inf_cup_left.
      + rewrite (semiring_left_distr _ _ _).
        rewrite right_unit.
        apply inf_join_inf.
        * rewrite <- inf_cup_right.
          rewrite <- ka_star_unfold.
          rewrite (semiring_left_distr _ _ _).
          rewrite <- inf_cup_left.
          rewrite right_unit.
          reflexivity.
        * rewrite <- ka_star_unfold at 2.
          rewrite <- inf_cup_right.
          rewrite (semiring_left_distr _ _ _).
          rewrite <- inf_cup_right.
          reflexivity.
    - apply ka_star_unfold.
  Qed.

  Lemma ka_star_dup a : a ⋆ · a ⋆ ⩵ a ⋆.
  Proof.
    apply antisymmetry.
    - apply ka_star_left_ind.
      rewrite ka_star_unfold_eq at 2.
      apply inf_cup_right.
    - rewrite ka_star_unfold_eq at 1.
      apply inf_join_inf.
      + rewrite ka_star_unfold_eq.
        rewrite (semiring_left_distr _ _ _).
        rewrite (semiring_right_distr _ _ _).
        rewrite <- inf_cup_left.
        rewrite <- inf_cup_left.
        rewrite left_unit.
        reflexivity.
      + apply proper_prod_inf;[|reflexivity].
        rewrite ka_star_unfold_eq.
        rewrite <- inf_cup_right.
        rewrite ka_star_unfold_eq.
        rewrite (semiring_left_distr _ _ _).
        rewrite <- inf_cup_left.
        rewrite right_unit.
        reflexivity.
  Qed.

  Lemma one_inf_star e : 𝟭 ≦ e⋆.
  Proof. rewrite ka_star_unfold_eq;apply inf_cup_left. Qed.

  Lemma star_incr e : e ≦ e⋆.
  Proof. rewrite ka_star_unfold_eq, <- one_inf_star,right_unit;apply inf_cup_right. Qed.

  Global Instance proper_star_inf : Proper (leqA eqA ==> leqA eqA) star.
  Proof.
    intros e f I.
    transitivity (e⋆·𝟭);[rewrite right_unit;reflexivity|].
    rewrite (one_inf_star f).
    apply ka_star_left_ind.
    rewrite I,(star_incr f),ka_star_dup at 1;reflexivity.
  Qed.

  Lemma ka_star_star a : a⋆ ⩵ (a ⋆)⋆.
  Proof.
    apply antisymmetry.
    - apply proper_star_inf.
      rewrite ka_star_unfold_eq.
      rewrite <- inf_cup_right.
      rewrite ka_star_unfold_eq.
      rewrite (semiring_left_distr _ _ _).
      rewrite right_unit.
      apply inf_cup_left.
    - rewrite ka_star_unfold_eq at 1.
      apply inf_join_inf.
      + rewrite ka_star_unfold_eq.
        apply inf_cup_left.
      + apply ka_star_right_ind.
        rewrite ka_star_dup.
        reflexivity.
  Qed.

  Lemma ka_star_unfold_right a : 𝟭 ∪ a⋆ · a ≦ a⋆.
  Proof.
    apply inf_join_inf.
    - rewrite ka_star_unfold_eq.
      apply inf_cup_left.
    - rewrite <- ka_star_dup at 2.
      apply proper_prod_inf.
      + reflexivity.
      + rewrite ka_star_unfold_eq,ka_star_unfold_eq.
        rewrite semiring_left_distr,right_unit.
        rewrite <- inf_cup_right.
        apply inf_cup_left.
  Qed.

  Lemma star_join e f : (e ∪ f)⋆ ⩵ e ⋆ ∪ f⋆·(e·f⋆)⋆.
  Proof.
    apply antisymmetry.
    - transitivity ((e ∪ f) ⋆ · un);[rewrite right_unit;reflexivity|].
      transitivity ((e ∪ f) ⋆ · (e ⋆ ∪ f ⋆ · (e · f ⋆) ⋆)).
      + apply proper_prod_inf;[reflexivity|].
        etransitivity;[|apply inf_cup_left].
        apply one_inf_star.
      + apply ka_star_left_ind.
        rewrite semiring_left_distr.
        repeat rewrite semiring_right_distr.
        repeat apply inf_join_inf.
        * etransitivity;[|apply inf_cup_left].
          rewrite (star_incr e) at 1.
          rewrite ka_star_dup;reflexivity.
        * etransitivity;[|apply inf_cup_right].
          apply proper_prod_inf;[apply star_incr|].
          rewrite <- (one_inf_star f),right_unit;reflexivity.
        * etransitivity;[|apply inf_cup_right].
          rewrite <- (one_inf_star f) at 3;rewrite left_unit.
          rewrite <- (ka_star_dup (e·f⋆)) at 2.
          rewrite <- (star_incr (e·f⋆)) at 2.
          rewrite (mon_assoc _ _ _).
          reflexivity.
        * etransitivity;[|apply inf_cup_right].
          rewrite (mon_assoc _ _ _).
          apply proper_prod_inf;[|reflexivity].
          rewrite (star_incr f) at 1;rewrite ka_star_dup;reflexivity.
    - apply inf_join_inf.
      + apply proper_star_inf,inf_cup_left.
      + rewrite <- (ka_star_dup (e∪f)).
        apply proper_prod_inf;[apply proper_star_inf,inf_cup_right|].
        rewrite (ka_star_star (e∪f)).
        apply proper_star_inf.
        rewrite <- (ka_star_dup (e∪f)).
        apply proper_prod_inf;[|apply proper_star_inf,inf_cup_right].
        rewrite <- star_incr;apply inf_cup_left.
  Qed.

  Lemma un_star : un⋆ ⩵ un.
  Proof.
    apply antisymmetry.
    - transitivity (un⋆·un);[rewrite right_unit;reflexivity|].
      apply ka_star_left_ind;rewrite left_unit;reflexivity.
    - apply star_incr.
  Qed.

  Lemma star_switch_side e : e⋆·e ⩵ e· e⋆.
  Proof.
    apply antisymmetry.
    - transitivity (e⋆·e·e⋆).
      + rewrite <- one_inf_star at 3.
        rewrite right_unit;reflexivity.
      + rewrite <- (mon_assoc _ _ _).
        apply ka_star_left_ind.
        rewrite (star_incr e) at 2.
        rewrite ka_star_dup;reflexivity.
    - transitivity (e⋆·e·e⋆).
      + rewrite <- one_inf_star at 2.
        rewrite left_unit;reflexivity.
      + apply ka_star_right_ind.
        rewrite (star_incr e) at 2.
        rewrite ka_star_dup;reflexivity.
  Qed.

  Definition Σ l := fold_right (fun e f => join e f) zero l.

  Lemma Σ_distr_l e L : e · Σ L ⩵ Σ (map (prod e) L).
  Proof.
    induction L;simpl.
    - apply right_absorbing.
    - rewrite <- IHL,semiring_left_distr;reflexivity.
  Qed.

  Lemma Σ_distr_r e L : Σ L · e ⩵ Σ (map (fun f => f · e) L).
  Proof.
    induction L;simpl.
    - apply left_absorbing.
    - rewrite <- IHL,semiring_right_distr;reflexivity.
  Qed.

  Lemma Σ_app L M : Σ L ∪ Σ M ⩵ Σ (L++M).
  Proof.
    induction L;simpl;[|rewrite <- IHL].
    - apply left_unit.
    - symmetry;apply mon_assoc.
  Qed.

  Lemma Σ_incl L M : L ⊆ M -> Σ L ≦ Σ M.
  Proof.
    intro I;unfold leqA;rewrite Σ_app;revert M I;induction L;intros M I.
    - reflexivity.
    - simpl;rewrite <- IHL by (rewrite <- I;intro;simpl;tauto).
      assert (Ia : a ∈ M) by (apply I;now left).
      clear I L IHL.
      induction M as [|e L].
      + simpl in *;tauto.
      + simpl;destruct Ia as [->|Ia];simpl.
        * rewrite (mon_assoc _ _ _),(ka_idem _);reflexivity.
        * rewrite IHL at 1 by assumption.
          rewrite (mon_assoc _ _ _),(semiring_comm e a),(mon_assoc _ _ _);reflexivity.
  Qed.

  Global Instance Σ_equivalent : Proper (@equivalent _ ==> eqA) Σ.
  Proof.
    intros l1 l2 E.
    apply antisymmetry;apply Σ_incl;rewrite E;reflexivity.
  Qed.

  Lemma Σ_bigger e L : e ∈ L -> e ≦ Σ L.
  Proof.
     intro I;transitivity (Σ [e]).
     - simpl;apply inf_cup_left.
     - apply Σ_incl;intros ? [<-|F];simpl in *;tauto.
  Qed.

  Lemma Σ_bounded e L : (forall f, f ∈ L -> f ≦ e) <-> Σ L ≦ e.
  Proof.
    split.
    - induction L;simpl;intro I.
      + apply zero_minimal.
      + rewrite IHL by (intros ? ?;apply I;now right).
        rewrite (I a) by now left.
        rewrite (ka_idem e);reflexivity.
    - intros E f If.
      rewrite <- E;apply Σ_bigger,If.
  Qed.

  Lemma ka_star_mid_split e : e⋆·e·e⋆ ≦ e⋆.
  Proof.
    etransitivity;[apply proper_prod_inf;[apply proper_prod_inf;
                                          [reflexivity|apply star_incr]|reflexivity]|].
    cut ((e ⋆ · e ⋆) · e ⋆ ⩵ e ⋆);[intros ->;reflexivity|].
    repeat rewrite ka_star_dup;reflexivity.
  Qed.

  Lemma ka_zero_star :  𝟬 ⋆ ⩵ 𝟭.
  Proof.
    apply antisymmetry.
    - transitivity (𝟬 ⋆ · 𝟭).
      + rewrite right_unit;reflexivity.
      + apply ka_star_left_ind.
        rewrite left_absorbing;apply zero_minimal.
    - apply one_inf_star.
  Qed.

End ka_facts.


Require Import nat.
Require Import list.
Require Import dictionary.
Require Import state.
Require Import ISA.

Fixpoint s_execute (e:State) (stack:list nat)(prog:list sinstr) : list nat :=
  match prog with
  | []      => stack  (* returns stack as it currently is *)
  | (i::is) => match i with
               | SPush n  => s_execute e (n::stack) is
               | SLoad k  => s_execute e ((e k)::stack) is
               | SPlus    => match stack with
                             | []         => s_execute e stack is (* error *)
                             | [x]        => s_execute e stack is (* error *)
                             | x::y::st'  => s_execute e ((y+x)::st') is
                            end
               | SMinus   => match stack with
                             | []         => s_execute e stack is (* error *)
                             | [x]        => s_execute e stack is (* error *)
                             | x::y::st'  => s_execute e ((y-x)::st') is
                            end
               | SMult    => match stack with
                             | []         => s_execute e stack is (* error *)
                             | [x]        => s_execute e stack is (* error *)
                             | x::y::st'  => s_execute e ((y*x)::st') is
                            end
                end
  end.

Lemma s_execute_app : forall (e:State) (stack:list nat)(p1 p2:list sinstr),
  s_execute e stack (p1 ++ p2) = s_execute e (s_execute e stack p1) p2.
Proof.
  intros e stack p1. revert stack. induction p1 as [|i is IH].
  - reflexivity.
  - intros stack p2. destruct i.
    + simpl. rewrite IH. reflexivity.
    + simpl. rewrite IH. reflexivity.
    + destruct stack as [|n stack].
      { simpl. rewrite IH. reflexivity. }
      { destruct stack as [|n' stack].
        { simpl. rewrite IH. reflexivity. }
        { simpl. rewrite IH. reflexivity. } }
    + destruct stack as [|n stack].
      { simpl. rewrite IH. reflexivity. }
      { destruct stack as [|n' stack].
        { simpl. rewrite IH. reflexivity. }
        { simpl. rewrite IH. reflexivity. } }
    + destruct stack as [|n stack].
      { simpl. rewrite IH. reflexivity. }
      { destruct stack as [|n' stack].
        { simpl. rewrite IH. reflexivity. }
        { simpl. rewrite IH. reflexivity. } }
Qed.


Require Import Strings.String.
Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.BinInt.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.

Section bloomfilter.

Variable Index:Type.
Variable index_beq: Index -> Index -> bool.
(*Parameter Index_eq: forall (i j:Index), {i=j} + {i<>j}.*)

Variable index_refl: forall i, index_beq i i = true.

Variable Hash0: Z -> Index.
Variable Hash1: Z -> Index.
Variable Hash2: Z -> Index.

Definition Filter:= Index -> bool.

Definition upd (F:Filter) (i:Index) (b:bool): Filter :=
  fun j => if index_beq i j then b else F j.

Definition empty:Filter := fun _ => false.

Definition get (F:Filter) (i:Index): bool := F i.

Definition add0 (F:Filter) (z:Z) :=
   upd F (Hash0 z) true.

Definition add1 (F:Filter) (z:Z) :=
   upd F (Hash1 z) true.

Definition add2 (F:Filter) (z:Z) :=
   upd F (Hash2 z) true.

Definition add (F:Filter * Filter * Filter) (z:Z) :=
match F with (F0, F1, F2) =>
  (add0 F0 z, add1 F1 z, add2 F2 z)
end.

Definition addm (F:Filter * Filter * Filter) (zs:list Z):=
List.fold_left add zs F.

Definition query (F:Filter * Filter * Filter) (z:Z) : bool :=
match F with (F0, F1, F2) =>
  get F0 (Hash0 z) && get F1 (Hash1 z) && get F2 (Hash2 z)
end.

Lemma bf_add_query_true z F: query (add F z) z = true.
destruct F as [[F0 F1] F2]. simpl. unfold get, add0, add1, add2, upd.
rewrite ! index_refl. trivial. Qed.

Lemma eqindexP : forall n m, reflect (index_beq n m = true) (index_beq n m).
Proof.
  intros n m. apply iff_reflect. reflexivity.
Qed.

Lemma add0_comm x y F: add0 (add0 F x) y = add0 (add0 F y) x.
Proof.
  unfold add0, upd.
  apply functional_extensionality.
  intros.
  destruct (eqindexP (Hash0 x) x0) as [H1|H2];
  destruct (eqindexP (Hash0 y) x0) as [H3|H4];
  reflexivity.
Qed.

Lemma add1_comm x y F: add1 (add1 F x) y = add1 (add1 F y) x.
Proof.
  unfold add1, upd.
  apply functional_extensionality.
  intros.
  destruct (eqindexP (Hash1 x) x0) as [H1|H2];
  destruct (eqindexP (Hash1 y) x0) as [H3|H4];
  reflexivity.
Qed.

Lemma add2_comm x y F: add2 (add2 F x) y = add2 (add2 F y) x.
Proof.
  unfold add2, upd.
  apply functional_extensionality.
  intros.
  destruct (eqindexP (Hash2 x) x0) as [H1|H2];
  destruct (eqindexP (Hash2 y) x0) as [H3|H4];
  reflexivity.
Qed.

Lemma add_comm x y F: add (add F x) y = add (add F y) x.
Proof.
  destruct F as [[F0 F1] F2]. simpl.
  apply pair_equal_spec. split.
  apply pair_equal_spec. split.
  apply add0_comm. apply add1_comm. apply add2_comm.
Qed.

Lemma addm_add_comm : forall x ys F, addm (add F x) ys = add (addm F ys) x.
Proof.
  intros. generalize F.
  induction ys as [|hd tl IH]; unfold addm.
  - intros. reflexivity.
  - intros. unfold addm in IH. unfold fold_left in *. rewrite add_comm.
    rewrite IH. reflexivity.
Qed.

Theorem BFNoFalseNegative z zs F: query (addm (add F z) zs) z  = true.
Proof.
  rewrite addm_add_comm. apply bf_add_query_true.
Qed.

End bloomfilter.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. lfind. Admitted.


(******************************************************************************)
(* Chapter 1.4: Functors                                                      *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(0)
同じディレクトリにある Categories.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Require Import Notations.
Require Import Morphisms.
Require Import Categories.

Class Functor `(C1 : Category) `(C2 : Category) (fobj : C1 -> C2) :=
  {
    functor_fobj := fobj;
    fmor                : forall {a b : C1}, a ~> b -> (fobj a) ~> (fobj b);
    fmor_respects       : forall {a b : C1} {f f' : a ~> b},
                            f === f' -> fmor f === fmor f';
    fmor_preserves_id   : forall {a : C1}, @fmor a a id === id;
(* forall a, fmor (id a) === id (fobj a); *)
    fmor_preserves_comp : forall {a b c : C1} {f : a ~> b} {g : b ~> c},
                            (fmor g) \\o (fmor f) === fmor (g \\o f)
  }.
Coercion functor_fobj : Functor >-> Funclass.

Check functor_fobj : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ _, C2.
(* ,の前の最後の「_」は、普通の引数で、C1（の対象） *)
Check @fmor        : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ a b _, fobj a ~> fobj b.
(* ,の前の最後の「_」は、普通の引数で、a ~> b の型を持つ。 *)

(* fobj と fmor の意味：
カテゴリ1 C1 = (Obj, Hom)
カテゴリ2 C2 = (Obj0, Hom0)

fobj : C1 -> C2、カテゴリC1（の対象）からC2（の対象）への写像
ファンクタからのコアーションが効く。

fmor : (a ~> b) -> (fobj a ~> fobj b)
カテゴリC1（の射）からC2（の射）への写像、
ただし fobj が与えられないと、意味をなさないことに注意！
 *)

Check @fmor : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ a b _, fobj a ~> fobj b.
Check fmor : _ ~> _ -> _ ~> _.
About fmor.                       (* Set Implicit Arguments の所為で、
                                     fobj は implicit になっている。 *)
Arguments fmor {Obj Hom Obj0 Hom0 C1 C2} fobj {_ a b} _ : rename.
Check fmor.                          (* fobj を指定するようにする。 *)

Notation "F \ f" := (fmor F f) : category_scope.
Open Scope category_scope.

(* parametric_morphism_fmor *)
(* これの証明に、Classの公理に Proper (eqv ==> eqv) fmor が必要なわけではない。 *)
(* また、(@fmor _ _ .... a b) は fmor と略せない。  *)
Instance functor_fmor_Proper `(C1 : Category) `(C2 : Category)
         (Fobj : C1 -> C2) (F : Functor Fobj) (a b : C1) :
  Proper (@eqv (a ~> b) ==> @eqv (Fobj a ~> Fobj b)) (@fmor _ _ _ _ _ _ _ _ a b).
Proof.
  move=> x y.                               (* これが肝 *)
  Check (@fmor_respects _ _ C1 _ _ C2 Fobj F a b x y).
  by apply (@fmor_respects _ _ C1 _ _ C2 Fobj F a b x y).
Qed.

(* 恒等関手 *)
(* the identity functor *)
Program Instance functor_id `(C : Category) : Functor (fun (x : C) => x) :=
  {|
    fmor := fun (a b : C) (f : a ~> b) => f
  |}.
Obligation 2.                               (* id === id *)
Proof.
  Check (fun (x : C) => C).                 (* カテゴリC(の対象)から、カテゴリC(の対象)の写像 *)
  Check (fun (a b : C) (f : a ~> b) => f).  (* カテゴリC(の射)から、カテゴリC(の射)の写像 *)
  reflexivity.                              (* fmor_preserves_id *)
Defined.
Obligation 3.                               (* g \\o f === g \\o f *)
Proof.
  reflexivity.                              (* fmor_preserves_comp *)
Defined.

(* 定数関手 *)
(* the constant functor *)
Program Instance functor_const `(C : Category) `{D : Category} (d : D) :
  Functor (fun (x : C) => d) :=
  {|
    fmor := fun (a b : C) (f : a ~> b) => id
  |}.
Obligation 1.
Proof.
  Check (fun (x : C) => d). (* カテゴリC(の対象)から、カテゴリD(の対象)の写像 *)
  Check (fun (a b : C) (f : a ~> b) => id). (* カテゴリC(の射)から、カテゴリD(の射)の写像 *)
  reflexivity.
Defined.
Obligation 2.
Proof.
  reflexivity.
Defined.
Obligation 3.
Proof.
  by apply left_identity.
Defined.

Generalizable Variables Fobj Gobj.

Locate "_ ○ _".                            (* "f ○ g" := fun x => f (g x) *)
Locate "_ \o _".                            (* SSReflect では、こっちを使う。 *)
Locate "_ \\o _".                           (* "f \\o g" := comp f g *)

(* 関手の合成 *)
(* functors compose *)
Program Instance functor_comp `(C1 : Category) `(C2 : Category) `(C3 : Category)
        `(F : @Functor _ _ C1 _ _ C2 Fobj) `(G : @Functor _ _ C2 _ _ C3 Gobj) :
  Functor (Gobj \o Fobj) :=
  {|
    fmor := fun a b m => G \ (F \ m)
  |}.
Obligation 1.
Proof.
  Check F : C1 -> C2.              (* C1の対象からC2の対象への写像  *)
  Check Fobj : C1 -> C2.           (* C1の対象からC2の対象への写像  *)
  Check fmor F.                    (* C1の射からC2の射への写像 *)
  Check G : C2 -> C3.              (* C2の対象からC3の対象への写像  *)
  Check Gobj : C2 -> C3.           (* C2の対象からC3の対象への写像  *)
  Check fmor G.                    (* C2の射からC3の射への写像 *)
  rewrite H.
  reflexivity.
Defined.
Obligation 2.
Proof.
  repeat setoid_rewrite fmor_preserves_id.
  reflexivity.
Defined.
Obligation 3.
Proof.
  repeat setoid_rewrite fmor_preserves_comp.
  reflexivity.
Defined.

Notation "f >>>> g" := (@functor_comp _ _ _ _ _ _ _ _ _ _ f _ g)   : category_scope.
Open Scope category_scope.

Generalizable Variables Xobj Yobj Zobj a b.

(*
Lemma functor_comp_assoc `{C : Category} `{D : Category} `{E : Category} `{F : Category}
      `(F1 : @Functor _ _ C _ _ D Xobj)
      `(F2 : @Functor _ _ D _ _ E Yobj)
      `(F3 : @Functor _ _ E _ _ F Zobj) :
  forall (a b : C) (f : a ~> b),
    ((F1 >>>> F2) >>>> F3) \ f === (F1 >>>> (F2 >>>> F3)) \ f.

Lemma functor_comp_assoc `{C':Category}`{D:Category}`{E:Category}`{F:Category}
  {F1obj}(F1:Functor C' D F1obj)
  {F2obj}(F2:Functor D E F2obj)
  {F3obj}(F3:Functor E F F3obj)
  `(f:a~>b) :
  ((F1 >>>> F2) >>>> F3) \ f ~~ (F1 >>>> (F2 >>>> F3)) \ f.
  intros; simpl.
  reflexivity.
  Qed.
*)

(* this is like JMEq, but for the particular case of ~~; note it does not require any axioms! *)

Inductive heq_morphisms `{C : Category} {a b : C} (f : a ~> b) :
  forall {a' b' : C}, a' ~> b' -> Prop :=
| heq_morphisms_intro {f' : a ~> b} :
    eqv f f' -> @heq_morphisms _ _ C a b f a b f'.

Definition heq_morphisms_refl `{C : Category} a b f :
  @heq_morphisms _ _ C a b f a  b  f.
Proof.
  apply heq_morphisms_intro.
  reflexivity.
Qed.
Check heq_morphisms_refl.
Check @heq_morphisms_refl :
  forall {Obj Hom C} {a b : Obj} {f : a ~> b},
    heq_morphisms f f.

Definition heq_morphisms_symm `{C : Category} a b f a' b' f' :
  @heq_morphisms _ _ C a b f a' b' f' -> @heq_morphisms _ _ C a' b' f' a b f.
Proof.
  case=> f'' H.
  apply: heq_morphisms_intro.
  rewrite H.
  reflexivity.
Qed.
Check heq_morphisms_symm.
Check @heq_morphisms_symm :
  forall {Obj Hom C}
         {a b : Obj} {f : a ~> b}
         {a' b' : Obj} {f' : a' ~> b'},
    heq_morphisms f f' -> heq_morphisms f' f.

Definition heq_morphisms_tran `{C : Category} a b f a' b' f' a'' b'' f'' :
  @heq_morphisms _ _ C a b f a' b' f' ->
  @heq_morphisms _ _ C a' b' f' a'' b'' f'' ->
  @heq_morphisms _ _ C a b f a'' b'' f''.
Proof.
  case=> f''' H.
  case=> f'''' H'.
  apply: heq_morphisms_intro.
  rewrite -H'.
  by apply: H.
Qed.
Check heq_morphisms_tran.
Check @heq_morphisms_tran :
  forall {Obj Hom C}
         {a b : Obj} {f : a ~> b}
         {a' b' : Obj} {f' : a' ~> b'}
         {a'' b'' : Obj} {f'' : a'' ~> b''},
    heq_morphisms f f' -> heq_morphisms f' f'' -> heq_morphisms f f''.

(*
Add Parametric Relation  (Ob:Type)(Hom:Ob->Ob->Type)(C:Category Ob Hom)(a b:Ob) : (hom a b) (eqv a b)
  reflexivity proved by  heq_morphisms_refl
  symmetry proved by     heq_morphisms_symm
  transitivity proved by heq_morphisms_tran
  as parametric_relation_heq_morphisms.
  Add Parametric Morphism `(c:Category Ob Hom)(a b c:Ob) : (comp a b c)
  with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp.
  auto.
  Defined.
*)

Implicit Arguments heq_morphisms [ Obj Hom C a b a' b' ].
Hint Constructors heq_morphisms.

Definition EqualFunctors `{C1 : Category} `{C2 : Category}
           {F1obj} (F1 : Functor F1obj)
           {F2obj} (F2 : Functor F2obj) :=
  forall a b (f f' : hom a b),
    f === f' -> heq_morphisms (fmor F1 f) (fmor F2 f').
(* f f' : a~~{C1}~~>b *)

Notation "f ~~~~ g" := (EqualFunctors f g) (at level 45).

Class IsomorphicCategories `(C : Category) `(D : Category) :=
  {
    ic_f_obj    : C -> D;
    ic_g_obj    : D -> C;
    ic_f        : Functor ic_f_obj;
    ic_g        : Functor ic_g_obj;

    ic_forward  : ic_f >>>> ic_g ~~~~ functor_id C;
    ic_backward : ic_g >>>> ic_f ~~~~ functor_id D
  }.

(* this causes Coq to die: *)
(* Definition IsomorphicCategories := Isomorphic (CategoryOfCategories). *)


Require Export D.

(** **** Problem #14 : 3 stars, optional (apply_with_exercise)
    Hint: Use the [apply ... with ...] tactic. *)

Check trans_lt.

Example trans_eq_exercise : forall (n m o p : nat),
     (minustwo o) < m ->
     (n + p) < (minustwo o) ->
     (n + p) < m.
Proof.
  intros.  apply trans_lt with (m:=minustwo o). apply H0. apply H.
Qed.


(***************************************************************************)
(*   This is part of FA_3rdCalculus, it is distributed under the terms     *)
(*         of the GNU Lesser General Public License version 3              *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*            Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.             *)
(***************************************************************************)

Require Export UnD.

Fixpoint N_uni_derivative F f a b n :=
  match n with
  | 1 => uni_derivative F f a b
  | p` => ∃ f1, uni_derivative F f1 a b /\ N_uni_derivative f1 f a b p
  end.

Definition N_uni_derivability F a b n := ∃ f, N_uni_derivative F f a b n.

Fact NderNec : ∀ {F f a b n}, N_uni_derivative F f a b n` ->
  ∃ f1, N_uni_derivative F f1 a b n /\ uni_derivative f1 f a b.
Proof.
  intros. generalize dependent F; induction n; intros;
  destruct H as [f1 [H]]; [eauto|]. destruct (IHn _ H0) as [f2 [H1]].
  exists f2. split; auto. red; eauto.
Qed.

Fact NderSuf : ∀ {F f a b n},
  (∃ f1, N_uni_derivative F f1 a b n /\ uni_derivative f1 f a b) ->
  N_uni_derivative F f a b n`.
Proof.
  intros. destruct H as [f0 [H]]. generalize dependent F. induction n; intros.
  - exists f0; auto.
  - destruct H as [f1 [H]]. pose proof (IHn _ H1). exists f1. auto.
Qed.

Fact Nderf : ∀ {F f1 f2 a b n}, N_uni_derivative F f1 a b n ->
  (∀ x, x ∈ [a|b] -> f1 x = f2 x) -> N_uni_derivative F f2 a b n.
Proof.
  intros. generalize dependent F. induction n; intros.
  - eapply derf; eauto.
  - destruct H as [f3 [H]]. simpl. eauto.
Qed.

Fact NderF : ∀ {F1 F2 f a b n}, N_uni_derivative F1 f a b n ->
  (∀ x, x ∈ [a|b] -> F1 x = F2 x) -> N_uni_derivative F2 f a b n.
Proof.
  intros. generalize dependent f. induction n; intros.
  - simpl in *. eapply derF; eauto.
  - destruct H as [f3 [H]]. exists f3. split; auto.
    eapply derF; eauto.
Qed.

Fact NderFf : ∀ {F1 F2 f1 f2 a b n},
  N_uni_derivative F1 f1 a b n -> (∀ x, x ∈ [a|b] -> F1 x = F2 x) ->
  (∀ x, x ∈ [a|b] -> f1 x = f2 x) -> N_uni_derivative F2 f2 a b n.
Proof.
  intros. eapply NderF in H; eauto. eapply Nderf in H; eauto.
Qed.

Fact uniNder : ∀ {F f1 f2 a b k},
   N_uni_derivative F f1 a b k -> N_uni_derivative F f2 a b k ->
   ∀ x, x ∈ [a|b] -> f1 x = f2 x.
Proof.
  intros. generalize dependent F. induction k; intros.
  - eapply unider; eauto.
  - destruct H as [f3 [H]], H0 as [f4 [H0]].
    eapply IHk; eauto. pose proof (unider H0 H). eapply NderF; eauto.
Qed.

Fact NderOrdPl : ∀ {F f1 f2 a b n k}, N_uni_derivative F f1 a b n ->
  N_uni_derivative f1 f2 a b k -> N_uni_derivative F f2 a b (Plus_N n k).
Proof.
  intros. generalize dependent F; generalize dependent f1;
  generalize dependent f2; induction k; intros; apply NderSuf; [eauto|].
  destruct (NderNec H0) as [f3 [H1]]. pose proof (IHk _ _ H1 _ H). eauto.
Qed.

Fact NderOrdMi : ∀ {F f1 f2 a b n k}, N_uni_derivative F f1 a b n ->
  N_uni_derivative F f2 a b (Plus_N n k) -> N_uni_derivative f1 f2 a b k.
Proof.
  intros. generalize dependent F; generalize dependent f1;
  generalize dependent f2; induction k; intros.
  - destruct (NderNec H0) as [f3 [H1]]. apply (derF H2 (uniNder H1 H)).
  - Simpl_Nin H0. destruct (NderNec H0) as [f3 [H1]].
    pose proof (IHk _ _ _ H H1). apply NderSuf; eauto.
Qed.

Fact NderOP1 : ∀ {F f1 f2 a b n}, N_uni_derivative F f1 a b n ->
  uni_derivative f1 f2 a b -> N_uni_derivative F f2 a b n`.
Proof. intros. rewrite <- NPl_1. eapply NderOrdPl; eauto. Qed.

Fact NderOM1 : ∀ {F f1 f2 a b n}, N_uni_derivative F f1 a b n ->
  N_uni_derivative F f2 a b n` -> uni_derivative f1 f2 a b.
Proof. intros. rewrite <- NPl_1 in H0. apply (NderOrdMi H H0). Qed.

Fact Nder_lt : ∀ {F a b k}, N_uni_derivability F a b k -> a < b.
Proof.
  intros. destruct H as [f H]. generalize dependent F. induction k; intros.
  - eapply der_lt; eauto. - destruct H, H; eauto.
Qed.

Fact Nderin : ∀ {F f a b c n}, c ∈ [a|b] -> c < b ->
  N_uni_derivative F f a b n -> N_uni_derivative F f c b n.
Proof.
  intros. pose proof (ccir H).
  generalize dependent F; induction n; intros.
  - eapply dersub; eauto.
  - destruct H1 as [f1 [H1]]. exists f1; split; auto.
    eapply dersub; eauto.
Qed.

Fact Ndervety : ∀ {F f a b n},
  N_uni_derivative F f a b n -> N_uni_derivability F a b n.
Proof.
  intros. red; eauto.
Qed.

Fact Nderpred : ∀ {F a b n},
  N_uni_derivability F a b n` -> N_uni_derivability F a b n.
Proof.
  intros. generalize dependent F. induction n; intros.
  - destruct H as [f [f1 [H]]]. red; eauto.
  - destruct H as [f [f1 [H]]]. apply Ndervety in H0.
    destruct (IHn _ H0) as [f2 H1]. red; exists f2. red; eauto.
Qed.

Fact Nderltn : ∀ {F a b n k}, ILT_N k n ->
  N_uni_derivability F a b n -> N_uni_derivability F a b k.
Proof.
  intros. induction n; [N1F H|]. destruct (Theorem26 _ _ H).
  - apply Nderpred in H0; auto.
  - subst k. apply Nderpred; auto.
Qed.

Fact Nderlen : ∀ {F a b n m},  ILE_N m n ->
  N_uni_derivability F a b n -> N_uni_derivability F a b m.
Proof.
  intros. destruct H. - eapply Nderltn; eauto. - subst m; auto.
Qed.

Axiom cid : ∀ {A :Type} {P :A -> Prop}, (∃ x, P x) -> { x :A | P x }.

Definition Getele {A :Type} {P :A -> Prop} (Q :∃ x, P x) := proj1_sig (cid Q).

Definition n_th {F a b n} (H :N_uni_derivability F a b n)
  := Getele H.

Definition p_th {F a b n} (H :N_uni_derivability F a b n`)
  := Getele (Nderpred H).

Definition k_th {F a b n} k (H :ILT_N k n)
  (H0 :N_uni_derivability F a b n) := Getele (Nderltn H H0).

Definition m_th {F a b n} k (H :ILE_N k n)
  (H0 :N_uni_derivability F a b n) := Getele (Nderlen H H0).

Ltac mdg1 f := unfold m_th, Getele;
  destruct cid as [f ]; simpl proj1_sig.
Ltac mdh1 f H := unfold m_th, Getele in H;
  destruct cid as [f ]; simpl proj1_sig in H.
Ltac kdg1 f := unfold k_th, Getele;
  destruct cid as [f ]; simpl proj1_sig.
Ltac kdg2 f l f1 := unfold k_th, Getele;
  destruct (cid l) as [f ], cid as [f1]; simpl proj1_sig.
Ltac kdh1 f H := unfold k_th, Getele in H;
  destruct cid as [f ]; simpl proj1_sig in H.
Ltac ndg1 f := unfold n_th, Getele;
  destruct cid as [f ]; simpl proj1_sig.
Ltac ndh1 f H := unfold n_th, Getele in H;
  destruct cid as [f ]; simpl proj1_sig in H.
Ltac ndh2 f H H0 := unfold n_th, Getele in H, H0;
  destruct cid as [f ]; simpl proj1_sig in H, H0.
Ltac ndg2 f l f1 := unfold n_th, Getele;
  destruct (cid l) as [f ], cid as [f1]; simpl proj1_sig.
Ltac pdg1 f := unfold p_th, Getele;
  destruct cid as [f ]; simpl proj1_sig.
Ltac pdg2 f l f1 := unfold p_th, Getele;
  destruct (cid l) as [f ], cid as [f1]; simpl proj1_sig.

Fact NderCut : ∀ {F a b n} k l1 (l :N_uni_derivability F a b n),
  N_uni_derivability (k_th k l1 l) a b (Minus_N n k l1).
Proof.
  intros. generalize dependent F. induction n; intros; [N1F l1|].
  destruct (Theorem26 _ _ l1).
  - inversion l as [f]. destruct (NderNec H0) as [f0 [H1]].
    pose proof (IHn H _ (Ndervety H1)). kdg1 f1. kdh1 f2 H3.
    rewrite (NMi7 _ H). destruct H3 as [f3]. exists f. apply NderSuf.
    exists f3. pose proof (NderOrdPl n1 H3). Simpl_Nin H4.
    apply @NderF with (F2:=f1) in H3; [|eapply uniNder; eauto].
    apply @derF with (F2:=f3) in H2; [|eapply uniNder; eauto]. auto.
  - subst k. Simpl_N. kdg1 f. inversion l as [f1].
    pose proof (NderOM1 n0 H). red; eauto.
Qed.

Fact NderfMu : ∀ {F f a b c n},
  N_uni_derivative F f a b n ->
  N_uni_derivative (mult_fun c F) (mult_fun c f) a b n.
Proof.
  intros. generalize dependent F; induction n; intros.
  - simpl in *. apply derfMu; auto.
  - destruct H as [f1 [H]].
    exists(mult_fun c f1). split; auto. apply derfMu; auto.
Qed.

Fact NderFPl : ∀ {F f G g a b n},
  N_uni_derivative F f a b n -> N_uni_derivative G g a b n ->
  N_uni_derivative (Plus_Fun F G) (Plus_Fun f g) a b n.
Proof.
  intros. generalize dependent F; generalize dependent G.
  induction n; intros.
  - simpl in *. apply derFPl; auto.
  - destruct H as [f1 [H]], H0 as [g1 [H0]].
    exists(Plus_Fun f1 g1). split; auto. apply derFPl; auto.
Qed.

Fact NderFMi : ∀ {F f G g a b n},
  N_uni_derivative F f a b n -> N_uni_derivative G g a b n ->
  N_uni_derivative (Minus_Fun F G) (Minus_Fun f g) a b n.
Proof.
  intros. generalize dependent F; generalize dependent G.
  induction n; intros.
  - simpl in *. apply derFMi; auto.
  - destruct H as [f1 [H]], H0 as [g1 [H0]].
    exists(Minus_Fun f1 g1). split; auto. apply derFMi; auto.
Qed.

Fact Nderf_mi : ∀ {F f a b n}, N_uni_derivative F f a b n ->
  N_uni_derivative (λ x, F(-x)) (λ x, (-(1))^n · f(-x)) (-b) (-a) n.
Proof.
  intros. generalize dependent f. induction n; intros.
  - unfold N_uni_derivative in *. unfold Pow. apply derf_mi in H.
    apply @derf with (f1:=(λ x, -f(-x))); intros; Simpl_R.
  - pose proof (Nderpred (Ndervety H)).
    destruct H0 as [f1 H0]. pose proof (IHn _ H0).
    pose proof (NderOM1 H0 H). apply derf_mi in H2.
    apply derfMu with (c:=(-(1))^n)  in H2. unfold mult_fun in H2.
    eapply NderOP1; eauto. apply (derf H2); intros.
    rewrite PowS, Theorem199; Simpl_R.
Qed.

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

Fact dermxc : ∀ {a b} c m, a < b -> uni_derivative (λ x,m·(x-c)) (λ _,m) a b.
Proof.
  intros. pattern m at 2. rewrite <- Theorem195. apply derfMu.
  pose proof (derFMi (derCx 1 H) (derC c H)).
  apply (derF H0); intros; unfold Minus_Fun; Simpl_R.
Qed.

Fact derpow1 : ∀ {a b} c n, a < b ->
  uni_derivative (λ x, (x-c)^n`)(λ x, n`·(x-c)^n) a b.
Proof.
  intros. pose proof (dermxc c 1 H). induction n.
  - pose proof (derFMu H0 H0). cbv beta in H1.
    apply (derFf H1); unfold Mult_Fun; intros; Simpl_R. rewrite R_T2; auto.
  - pose proof (derFMu IHn H0). cbv beta in H1.
    apply (derFf H1); unfold Mult_Fun; intros; Simpl_R.
    rewrite <- (RN3 (n`)), Theorem201', Theorem199; Simpl_R.
Qed.

Fact derrdf1 : ∀ {a b} c n z, a < b ->
  uni_derivative (λ x, (z·Rdifa ((x-c)^n`) n`))
  (λ x, (z·Rdifa ((x-c)^n) n)) a b.
Proof.
  intros. apply derfMu. pose proof (derpow1 c n H).
  pose proof (derfMu (Rdifa 1 n`) H0). unfold mult_fun in H1.
  apply (derFf H1); intros; [|unfold Rdifa].
  - rewrite Theorem194, rdft; Simpl_R.
  - apply eqTi_R with (z:=factorial n); [apply facun0|Simpl_R].
    rewrite Theorem194, <- Theorem199, Di_Rt.
    rewrite <- Theorem199, (Theorem194 _ n`), Di_Rt; Simpl_R.
Qed.

Fact Nderrdf1 : ∀ {a b} c z n k l, a < b ->
  N_uni_derivative (λ x, (z·Rdifa ((x-c)^n) n))
  (λ x, (z·Rdifa ((x-c)^(Minus_N n k l)) (Minus_N n k l))) a b k.
Proof.
  intros. pose proof (@derrdf1 a b c).
  generalize dependent n. induction k; intros.
  - simpl. pose proof (H0 (Minus_N n 1 l) z H). Simpl_Nin H1.
  - set (l1:=(N1P' l)). assert (IGT_N (Minus_N n 1 l1) k).
    { apply Theorem20_1 with (z:=1); Simpl_N. }
    assert (Minus_N n k` l = Minus_N (Minus_N n 1 l1) k H1).
    { apply Theorem20_2 with (z:=k`); Simpl_N. } rewrite H2.
    generalize (IHk _ H1)(Theorem15 _ _ _ (Nlt_S_ k) l); intros.
    pose proof (derrdf1 c (Minus_N n 1 l1) z H). Simpl_Nin H5. red; eauto.
Qed.

Fact Nderrdf2 : ∀ {a b} c z n, a < b ->
  N_uni_derivative (λ x, (z·Rdifa ((x-c)^n) n)) (λ x, z) a b n.
Proof.
  intros. induction n.
  - simpl. pose proof (dermxc c z H).
    eapply derF; eauto. intros. rewrite rdf_1; auto.
  - pose proof (derrdf1 c n z H). red; eauto.
Qed.


Theorem ExF003_1 {X  :Type} (P : X -> Prop) (Q : X -> X) (a : X): (forall x, P x -> P (Q x)) /\ P a -> P (Q (Q a)).
Proof.
  intros.
  destruct H.
  assert (P a -> P (Q a)).
  + specialize (H a).
    exact H.
  + pose proof (H (Q a)) as bla.
    apply bla.
    apply H1.
    exact H0.
Qed.

Theorem ExF003_2 {X :Type} (P : X -> Prop) (Q : X -> X) (a : X): (forall x, P x -> P (Q x)) /\ P a -> P (Q (Q a)).
Proof.
  intros.
  destruct H.
  apply H.
  apply H.
  assumption.
Qed.


Require Export Tactics.

(** Take the minimum of two things which might be [nat]s. *)
Definition option_f {A} (f : A -> A -> A) : option A -> option A -> option A
  := fun a b => match a, b with
                  | None, _ => b
                  | _, None => a
                  | Some a, Some b => Some (f a b)
                end.

(** The distance between two points is the maximum of the two
    differences; in Coq, we have that [a - b = 0] if [b ≥ a]. *)
Definition abs_minus (x y : nat) :=
  if le_dec x y then y - x else x - y.

Notation "∥' x -- y '∥" := (abs_minus x y) : nat_scope.

Delimit Scope dec_scope with dec.
Infix "<=" := le_lt_dec : dec_scope.
Infix "≤" := le_lt_dec : dec_scope.
Infix "=" := eq_nat_dec : dec_scope.

(** Given a boolean relation, we can find the [f]-most element of a list. *)
Definition get_func_bool {T} (f : T -> T -> bool) (*H : forall x y z, f x y = true -> f y z = true -> f x z = true*)
           (ls : list T)
: ls <> [] -> T
  := match ls with
       | [] => fun H => match H eq_refl : False with end
       | x::xs => fun _ => fold_right (fun acc pt => if (f acc pt) then acc else pt)
                                      x
                                      xs
     end.

Program Definition get_func {T} {R} `{f : forall x y : T, Decidable (R x y)} (*`{Transitive _ R}*) (ls : list T)
: ls <> [] -> T
  := @get_func_bool _ (fun x y => if f x y then true else false) (*_*) ls.
(*Next Obligation.
  abstract (
      destruct (f x y), (f y z), (f x z); hnf in *; firstorder eauto
    ).
Defined.*)

Section spec_get_func.
  Local Hint Extern 1 => intros; etransitivity; eassumption.
  Local Hint Extern 1 => eapply Forall_impl; [ | eassumption ].
  Local Hint Extern 3 => progress case_eq_if.
  Local Hint Constructors Forall.

  Lemma spec_rel_get_func {T} {R}
        `{forall x y : T, Decidable (R x y)}
        `{PartialOrder _ eq R, Total _ R}
        (ls : list T)
        (Hls : ls <> [])
  : List.Forall (fun elem => R (get_func Hls) elem) ls.
  Proof.
    destruct ls; auto; simpl.
    induction ls; auto;
    try solve [ do 2 (reflexivity || constructor) ].
    specialize (IHls (fun H => nil_cons (eq_sym H))).
    constructor; simpl.
    { eauto. }
    { constructor; eauto. }
  Qed.

  Lemma spec_in_get_func {T} {R}
        `{forall x y : T, Decidable (R x y)}
        `{PartialOrder _ eq R, Total _ R}
        (ls : list T)
        (Hls : ls <> [])
  : get_func Hls ∈ ls.
  Proof.
    destruct ls; eauto.
    simpl; clear Hls.
    induction ls; try solve [ intuition ].
    destruct_head or; simpl in *;
    rewrite_rev_hyp;
    case_eq_if;
    try solve [ intuition ].
  Qed.
End spec_get_func.

Fixpoint take_while A (f : A -> bool) n (v : Vector.t A n) : { x : nat & Vector.t A x }
  := match v with
       | Vector.nil => existT _ _ (Vector.nil _)
       | Vector.cons x _ xs => if f x
                               then existT _ _ (Vector.cons _ x _ (projT2 (take_while f xs)))
                               else existT _ _ (Vector.nil _)
     end.

Infix "<" := lt_dec : dec_scope.
Infix "<=" := le_dec : dec_scope.
Infix ">" := gt_dec : dec_scope.
Infix ">=" := ge_dec : dec_scope.

Definition option_min : option nat -> option nat -> option nat
  := fun a b => match a, b with
                  | None, _ => b
                  | _, None => a
                  | Some a, Some b => Some (min a b)
                end.

Notation "[]" := List.nil : list_scope.

Notation "[]" := (Vector.nil _) : vector_scope.
Notation "h :: t" := (Vector.cons _ h _ t) (at level 60, right associativity) : vector_scope.
Bind Scope vector_scope with Vector.t.
Delimit Scope vector_scope with vector.

(** Given a decidable [≤] on [B] and a function [f : A → B], we can
    take the smaller [A] as decided by [f]. *)
Definition min_by {A B P} `{p : forall x y : B, Decidable (P x y)}
           (f : A -> B)
: A -> A -> A
  := fun a b => if p (f a) (f b) then a else b.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Theorem plus_O_n : forall n : nat, 0 + n = n.
1 subgoal

  ============================
  forall n : nat, 0 + n = n

plus_O_n < Proof.
1 subgoal

  ============================
  forall n : nat, 0 + n = n

plus_O_n < intros n.
1 subgoal

  n : nat
  ============================
  0 + n = n

plus_O_n < simpl.
1 subgoal

  n : nat
  ============================
  n = n

plus_O_n < reflexivity.
No more subgoals.

plus_O_n < Qed.
Proof.
intros n.
simpl.
reflexivity.

Qed.
plus_O_n is defined


Require Export FormalMath.Infra.

(** The definition of a category and related concepts and theorems
    follow Steve Awodey's "Category Theory". *)

(** * Chapter 1.3 Definition of a category *)

Class Arrows (O: Type): Type := Arrow: O -> O -> Type.
#[global] Typeclasses Transparent Arrows.
Infix "~>" := Arrow (at level 90, right associativity): math_scope.

Class CatId O `{Arrows O} := cat_id: forall x, x ~> x.
Class CatComp O `{Arrows O} := comp: forall x y z, (y ~> z) -> (x ~> y) -> (x ~> z).

Arguments cat_id {O arrows CatId x} : rename.
Arguments comp {O arrow CatComp} _ _ _ _ _ : rename.

Infix ">>>" := (comp _ _ _) (at level 40, left associativity) : math_scope.

#[universes (polymorphic, cumulative)]
 Class Category O `{!Arrows O} `{forall a b: O, Equiv (a ~> b)}
 `{!CatId O} `{!CatComp O}: Prop := {
    arrow_equiv :> forall a b, Setoid (a ~> b);
    comp_proper :> forall a b c, Proper ((=) ==> (=) ==> (=)) (comp a b c);
    comp_assoc : forall `(f: a ~> b) `(g: b ~> c) `(h: c ~> d),
      h >>> (g >>> f) = (h >>> g) >>> f;
    left_identity: forall `(f: a ~> b), cat_id >>> f = f;
    right_identity: forall `(f: a ~> b), f >>> cat_id = f;
  }.

Arguments comp_assoc {O arrows eq CatId CatComp Category a b} _ {c} _ {d} _ : rename.

(** * Chapter 1.4 Examples of categories *)

(** 6: Functor *)
Section FUNCTOR.

  Context `{Category C} `{Category D}.
  Context (M: C -> D).

  Class Fmap: Type := fmap: forall {v w: C}, (v ~> w) -> (M v ~> M w).

  Class Functor `(Fmap): Prop := {
      functor_from: Category C;
      functor_to: Category D;
      functor_morphism :> forall a b, Setoid_Morphism (@fmap _ a b);
      preserves_id: forall {a}, fmap (cat_id: a ~> a) = cat_id;
      preserves_comp: forall `(g: y ~> z) `(f: x ~> y),
        fmap (g >>> f) = fmap g >>> fmap f
    }.

  #[global] Instance fmapEquiv: Equiv Fmap :=
    fun F1 F2 => forall (v w: C) (ar: v ~> w), F1 v w ar = F2 v w ar.

  #[global] Instance fmapSetoid: Setoid Fmap.
  Proof.
    constructor; repeat intro; try easy.
    specialize (H3 v w ar). specialize (H4 v w ar). now transitivity (y v w ar).
  Qed.

End FUNCTOR.

#[global] Typeclasses Transparent Fmap.

Section IDENTITY_FUNCTOR.

  Context `{Category C}.

  #[global] Instance idFmap: Fmap id := fun _ _ => id.

  #[global] Instance idFunctor: Functor (id: C -> C) _.
  Proof.
    constructor; try apply _; try easy.
    intros. constructor; try apply _; try easy.
  Qed.

End IDENTITY_FUNCTOR.

Section COMPOSE_FUNCTOR.

  Context
    A B C
    `{!Arrows A} `{!Arrows B} `{!Arrows C}
    `{!CatId A} `{!CatId B} `{!CatId C}
    `{!CatComp A} `{!CatComp B} `{!CatComp C}
    `{forall a b: A, Equiv (a ~> b)}
    `{forall a b: B, Equiv (a ~> b)}
    `{forall a b: C, Equiv (a ~> b)}
    `{!Functor (f: B -> C) f'} `{!Functor (g: A -> B) g'}.

  #[global] Instance compFmap: Fmap (compose f g) :=
    fun _ _ => compose (fmap f) (fmap g).

  #[global] Instance compFunctor: Functor (compose f g) _.
  Proof.
    pose proof (functor_from g). pose proof (functor_to g). pose proof (functor_to f).
    constructor; intros; try apply _; unfold fmap, compFmap.
    - apply setoid_morphism_trans.
      + apply (functor_morphism g).
      + apply (functor_morphism f).
    - unfold compose. repeat rewrite preserves_id; auto.
    - unfold compose. repeat rewrite preserves_comp; auto.
  Qed.

End COMPOSE_FUNCTOR.

(** * Chapter 1.5 Isomorphisms *)

Section ISOMORPHISM.

  Context `{Category C}.

  (** Definition 1.3 *)
  Class Isomorphism `(f: A ~> B) (g: B ~> A): Prop := {
      iso_comp1: g >>> f = cat_id;
      iso_comp2: f >>> g = cat_id;
    }.

  Lemma iso_inverse_unique: forall `(f: A ~> B) (g1 g2: B ~> A),
      Isomorphism f g1 -> Isomorphism f g2 -> g1 = g2.
  Proof.
    intros. destruct H1, H2. rewrite <- left_identity.
    rewrite <- iso_comp5, <- comp_assoc. rewrite iso_comp4. apply right_identity.
  Qed.

  Lemma isomorphism_sym: forall `(f: A ~> B) (g: B ~> A),
      Isomorphism f g -> Isomorphism g f.
  Proof. intros. destruct H1. split; auto. Qed.

  Definition isomorphic (A B: C) := exists (f: A ~> B) (g: B ~> A), Isomorphism f g.

End ISOMORPHISM.

Infix "~=~" := isomorphic (at level 90, no associativity): math_scope.

(** * Chapter 2.1 Epis and monos *)

Section EPIS_MONOS.

  Context `{Category C}.

  (** Definition 2.1 *)
  Class Monomorphism `(f: A ~> B): Prop :=
    mono_comp: forall {D: C} (g h: D ~> A), f >>> g = f >>> h -> g = h.

  Class Epimorphism `(f: A ~> B): Prop :=
    epi_comp: forall {D: C} (i j: B ~> D), i >>> f = j >>> f -> i = j.

  Lemma id_monic_epic: forall `(f: A ~> B) (g: B ~> A),
      g >>> f = cat_id -> Monomorphism f /\ Epimorphism g.
  Proof.
    intros. split; repeat intro.
    - rewrite <- left_identity. rewrite <- (left_identity h).
      rewrite <- H1. rewrite <- comp_assoc. rewrite H2. apply comp_assoc.
    - rewrite <- right_identity. rewrite <- (right_identity j).
      rewrite <- H1. rewrite !comp_assoc. now rewrite H2.
  Qed.

  (** Proposition 2.6 *)
  Lemma iso_monic_epic: forall `(f: A ~> B) (g: B ~> A),
      Isomorphism f g -> Monomorphism f /\ Epimorphism f.
  Proof.
    intros. destruct (id_monic_epic f g iso_comp1).
    destruct (id_monic_epic g f iso_comp2). now split.
  Qed.

End EPIS_MONOS.

(** * Chapter 2.2 Initial and terminal objects *)
Section INITIAL_TERMINAL.

  Context `{Category C}.

  Class InitialArrow (o: C): Type := initial_arrow: forall c, o ~> c.

  (** Definition 2.9 *)
  Class Initial (o: C) `{InitialArrow o}: Prop :=
    initial_arrow_unique: forall c f', f' = initial_arrow c.

  Class TerminalArrow (o: C): Type := terminal_arrow: forall c, c ~> o.

  Class Terminal (o: C) `{TerminalArrow o}: Prop :=
    terminal_arrow_unique: forall c f', f' = terminal_arrow c.

  (** Proposition 2.10 *)
  Lemma initial_unique_iso: forall `(Initial o1) `(Initial o2), o1 ~=~ o2.
  Proof.
    intros. exists (initial_arrow o2). exists (initial_arrow o1).
    constructor; rewrite initial_arrow_unique; symmetry; apply initial_arrow_unique.
  Qed.

  Lemma terminal_unique_iso: forall `(Terminal o1) `(Terminal o2), o1 ~=~ o2.
  Proof.
    intros. exists (terminal_arrow o1). exists (terminal_arrow o2).
    constructor; rewrite terminal_arrow_unique; symmetry; apply terminal_arrow_unique.
  Qed.

End INITIAL_TERMINAL.

(** * Chapter 1.6 Constructions on categories *)

(** Chapter 1.6.1: product category *)
Section PRODUCT_CATEGORY.

  Context `{Category C} `{Category D}.
  Instance prodArrows: Arrows (C * D) :=
    fun p1 p2 => ((fst p1 ~> fst p2) * (snd p1 ~> snd p2))%type.
  Instance prodCatEq: forall A B: (C * D), Equiv (A ~> B) :=
    fun _ _ p1 p2 => fst p1 = fst p2 /\ snd p1 = snd p2.
  Instance prodCatId: CatId (C * D) := fun _ => (cat_id, cat_id).
  Instance prodCatComp: CatComp (C * D) :=
    fun _ _ _ a1 a2 => (fst a1 >>> fst a2, snd a1 >>> snd a2).
  Instance prodCatSetoid: forall A B: (C * D), Setoid (A ~> B).
  Proof.
    intros. constructor; red; unfold equiv, prodCatEq;
      intros; split; try easy; destruct H3, H4; firstorder.
  Qed.

  Instance prodCategory: Category (C * D).
  Proof.
    constructor; intros; try apply _.
    - repeat intro. destruct x, x0, y, y0, H3, H4. unfold comp, prodCatComp.
      simpl in *. split; simpl.
      + now rewrite H3, H4.
      + now rewrite H5, H6.
    - destruct h, g, f. split; simpl; apply comp_assoc.
    - unfold comp, prodCatComp. destruct f. split; simpl; apply left_identity.
    - unfold comp, prodCatComp. destruct f. split; simpl; apply right_identity.
  Qed.

  Instance fstFmap: Fmap fst := fun _ _ => fst.

  Instance fstFunctor: Functor fst _.
  Proof.
    constructor; try apply _; intros.
    - constructor; try apply _. repeat intro. destruct H3. apply H3.
    - destruct a. reflexivity.
    - destruct x, y, z, f, g. easy.
  Qed.

  Instance sndFmap: Fmap snd := fun _ _ => snd.

  Instance sndFunctor: Functor snd _.
  Proof.
    constructor; try apply _; intros.
    - constructor; try apply _. repeat intro. destruct H3. apply H4.
    - destruct a. reflexivity.
    - destruct x, y, z, f, g. easy.
  Qed.

End PRODUCT_CATEGORY.

(** Chapter 1.6.2: opposite category *)
Section OPPOSITE_CATEGORY.

  Context `{@Category C ArrowsC CatEquivC CatIdC CatCompC}.

  Inductive CatOp A := catop_inject: A -> CatOp A.
  Arguments catop_inject {_} _.

  #[export] Instance catop_rep {A}: Cast (CatOp A) A :=
    fun x => match x with catop_inject x => x end.

  #[export] Instance oppoArrows: Arrows (CatOp C) := fun a b => ' b ~> ' a.
  #[export] Instance oppoCatEq: forall A B: (CatOp C), Equiv (oppoArrows A B) :=
    fun A B => CatEquivC (' B) (' A).
  #[export] Instance oppoCatId: CatId (CatOp C) := fun x => CatIdC (' x).
  #[export] Instance oppoCatComp: CatComp (CatOp C) :=
    fun a b c => flip (CatCompC (' c) (' b) (' a)).
  #[export] Instance oppoCatSetoid: forall A B: (CatOp C), Setoid (oppoArrows A B).
  Proof. intros. change (Setoid (ArrowsC (' B) (' A))). apply arrow_equiv. Qed.

  #[export] Instance oppoCategory: Category (CatOp C).
  Proof.
    constructor; try apply _; intros; unfold comp, oppoCatComp, Arrow,
      oppoArrows, cat_id, oppoCatId, equiv, oppoCatEq, flip.
    - repeat intro. change (CatCompC (' c) (' b) (' a) x0 x =
                              CatCompC (' c) (' b) (' a) y0 y). now rewrite H1, H0.
    - symmetry. apply comp_assoc.
    - apply right_identity.
    - apply left_identity.
  Qed.

  Section INITIAL_TERMINAL_DUAL.

    Parameter (o: C).
    Context `{!InitialArrow o}.

    Instance oppoTermArrow: TerminalArrow (catop_inject o).
    Proof. repeat intro. repeat red. exact (initial_arrow (' c)). Defined.

    Lemma initial_op_terminal: Initial o -> Terminal (catop_inject o).
    Proof.
      intros. repeat red. repeat red in H0.
      unfold Arrow, oppoArrows, terminal_arrow, oppoTermArrow, cast.
      simpl. intros. apply H0.
    Qed.

    Context `{!TerminalArrow o}.

    Instance oppoInitArrow: InitialArrow (catop_inject o).
    Proof. repeat intro. repeat red. exact (terminal_arrow (' c)). Defined.

    Lemma terminal_op_initial: Terminal o -> Initial (catop_inject o).
    Proof.
      intros. repeat red. repeat red in H0.
      unfold Arrow, oppoArrows, terminal_arrow, oppoTermArrow, cast.
      simpl. intros. apply H0.
    Qed.

  End INITIAL_TERMINAL_DUAL.

End OPPOSITE_CATEGORY.

(** Chapter 1.6.3: arrow category *)
Section ARROW_CATEGORY.

  Context `{Category C}.

  Definition arrowObj := {domcod: C * C & fst domcod ~> snd domcod}.

  Instance arrowArrows: Arrows arrowObj.
  Proof.
    intros [[A B] f] [[A' B'] f']. simpl in *.
    exact {g: (A ~> A') * (B ~> B') | (snd g) >>> f = f' >>> (fst g)}.
  Defined.

  Instance arrowCatEq: forall (A B: arrowObj), Equiv (A ~> B).
  Proof.
    intros [[A B] f] [[A' B'] g]. unfold Arrow, arrowArrows.
    intros [[g1 g2] ?H] [[g3 g4] ?H].
    exact ((g1 = g3) /\ (g2 = g4)).
  Defined.

  Instance arrowCatId: CatId arrowObj.
  Proof.
    intros [[A B] f]. simpl in f. unfold Arrow, arrowArrows.
    exists (cat_id, cat_id). simpl. now rewrite left_identity, right_identity.
  Defined.

  Instance arrowCatComp: CatComp arrowObj.
  Proof.
    intros [[A1 A2] fA] [[B1 B2] fB] [[C1 C2] fC].
    intros [[h1 h2] ?H]. intros [[g1 g2] ?H]. unfold Arrow, arrowArrows.
    exists (h1 >>> g1, h2 >>> g2). simpl in *.
    now rewrite <- comp_assoc, H2, comp_assoc, H1, comp_assoc.
  Defined.

  Instance arrowCatSetoid: forall (A B: arrowObj), Setoid (A ~> B).
  Proof.
    intros [[A1 A2] fA] [[B1 B2] fB]. unfold Arrow, arrowArrows.
    constructor; repeat intro.
    - destruct x as [[g1 g2] ?H]. cbn. now split.
    - destruct x as [[x1 x2] ?H]. destruct y as [[y1 y2] ?H]. simpl in *. cbn in *.
      destruct H0. split; now symmetry.
    - destruct x as [[x1 x2] ?H]. destruct y as [[y1 y2] ?H].
      destruct z as [[z1 z2] ?H]. simpl in *. cbn in *. destruct H1, H2.
      split; etransitivity; eauto.
  Qed.

  Instance arrowCategory: Category arrowObj.
  Proof.
    constructor; try apply _; intros.
    - destruct a as [[a1 a2] fa]. destruct b as [[b1 b2] fb].
      destruct c as [[c1 c2] fc]. repeat intro. cbn in x, y, x0, y0.
      destruct x as [[gx1 gx2] ?H]. destruct y as [[gy1 gy2] ?H].
      destruct x0 as [[gz1 gz2] ?H]. destruct y0 as [[gw1 gw2] ?H]. cbn in *.
      destruct H1, H2. split.
      + now rewrite H1, H2.
      + now rewrite H7, H8.
    - destruct a as [[a1 a2] fa]. destruct b as [[b1 b2] fb].
      destruct c as [[c1 c2] fc]. destruct d as [[d1 d2] fd]. cbn in f, g, h.
      destruct f as [[f1 f2] ?H]. destruct g as [[g1 g2] ?H].
      destruct h as [[h1 h2] ?H]. cbn in *. split; apply comp_assoc.
    - destruct a as [[a1 a2] fa]. destruct b as [[b1 b2] fb]. cbn in f.
      destruct f as [[f1 f2] ?H]. cbn. split; apply left_identity.
    - destruct a as [[a1 a2] fa]. destruct b as [[b1 b2] fb]. cbn in f.
      destruct f as [[f1 f2] ?H]. cbn. split; apply right_identity.
  Qed.

  Instance domFmap: Fmap (C := arrowObj) (compose fst (@projT1 _ _)).
  Proof.
    repeat intro. destruct v as [[v1 v2] av]. destruct w as [[w1 w2] aw].
    exact (fst (proj1_sig X)).
  Defined.

  Instance domFunctor: Functor (compose fst (@projT1 _ _)) _.
  Proof.
    constructor; try apply _; repeat intro.
    - destruct a as [[a1 a2] aa]. destruct b as [[b1 b2] ab].
      constructor; try apply _. repeat intro. cbn in x, y. cbn.
      destruct x as [[x1 x2] ?H]. destruct y as [[y1 y2] ?H]. cbn in H1. simpl in *.
      destruct H1. easy.
    - destruct a as [[a1 a2] aa]. cbn. easy.
    - destruct x as [[x1 x2] ax]. destruct y as [[y1 y2] ay].
      destruct z as [[z1 z2] az]. cbn in f, g.
      destruct g as [[g1 g2] ?H]. destruct f as [[f1 f2] ?H]. cbn. easy.
  Qed.

  Instance codFmap: Fmap (C := arrowObj) (compose snd (@projT1 _ _)).
  Proof.
    repeat intro. destruct v as [[v1 v2] av]. destruct w as [[w1 w2] aw].
    exact (snd (proj1_sig X)).
  Defined.

  Instance codFunctor: Functor (compose snd (@projT1 _ _)) _.
  Proof.
    constructor; try apply _; repeat intro.
    - destruct a as [[a1 a2] aa]. destruct b as [[b1 b2] ab].
      constructor; try apply _. repeat intro. cbn in x, y. cbn.
      destruct x as [[x1 x2] ?H]. destruct y as [[y1 y2] ?H]. cbn in H1. simpl in *.
      destruct H1. easy.
    - destruct a as [[a1 a2] aa]. cbn. easy.
    - destruct x as [[x1 x2] ax]. destruct y as [[y1 y2] ay].
      destruct z as [[z1 z2] az]. cbn in f, g.
      destruct g as [[g1 g2] ?H]. destruct f as [[f1 f2] ?H]. cbn. easy.
  Qed.

End ARROW_CATEGORY.

(** Chapter 1.6.4: slice category *)
Section SLICE_CATEGORY.

  Context `{Category C}.

  Definition sliceObj (o: C) := {dom: C & dom ~> o}.

  Instance sliceArrows (o: C): Arrows (sliceObj o).
  Proof.
    intros [A fA] [B fB]. exact {fab: A ~> B | fB >>> fab = fA}.
  Defined.

  Instance sliceCatEq (o: C): forall A B: (sliceObj o), Equiv (A ~> B).
  Proof.
    intros [A fA] [B fB]. unfold Arrow, sliceArrows.
    intros [fab1 ?H] [fab2 ?H]. exact (fab1 = fab2).
  Defined.

  Instance sliceCatId (o: C): CatId (sliceObj o).
  Proof.
    intros [A f]. unfold Arrow, sliceArrows. exists cat_id. apply right_identity.
  Defined.

  Instance sliceCatComp (o: C): CatComp (sliceObj o).
  Proof.
    intros [X fX] [Y fY] [Z fZ]. cbn.
    intros [fyz ?H]. intros [fxy ?H]. exists (fyz >>> fxy).
    rewrite <- H2, <- H1. apply comp_assoc.
  Defined.

  Instance sliceCatSetoid (o: C): forall (A B: sliceObj o), Setoid (A ~> B).
  Proof.
    intros [A fA] [B fB]. cbn. constructor; repeat intro.
    - destruct x as [f ?H]. now cbn.
    - destruct x as [fx ?H]. destruct y as [fy ?H]. cbn in *. now symmetry.
    - destruct x as [fx ?H]. destruct y as [fy ?H]. destruct z as [fz ?H].
      cbn in *. etransitivity; eauto.
  Qed.

  Instance sliceCategory (o: C): Category (sliceObj o).
  Proof.
    constructor; try apply _; intros.
    - destruct a as [a fa]. destruct b as [b fb]. destruct c as [c fc].
      repeat intro. cbn in x, y, x0, y0. destruct x as [fx ?H].
      destruct y as [fy ?H]. destruct x0 as [fz ?H]. destruct y0 as [fw ?H].
      cbn in *. now rewrite H1, H2.
    - destruct a as [a fa]. destruct b as [b fb]. destruct c as [c fc].
      destruct d as [d fd]. cbn in f, g, h. destruct f as [f ?H].
      destruct g as [g ?H]. destruct h as [h ?H]. cbn. apply comp_assoc.
    - destruct a as [a fa]. destruct b as [b fb]. cbn in f. destruct f as [f ?].
      cbn. apply left_identity.
    - destruct a as [a fa]. destruct b as [b fb]. cbn in f. destruct f as [f ?].
      cbn. apply right_identity.
  Qed.

  (** * Chapter 1.9 Exercises 5 Question 1 *)
  Instance sliceForgetFmap (o: C): Fmap (C := sliceObj o) (@projT1 _ _).
  Proof.
    repeat intro. destruct v as [v av]. destruct w as [w aw]. cbn in X.
    cbn. exact (proj1_sig X).
  Defined.

  Instance sliceForgetFunctor (o: C): Functor (C := sliceObj o) (@projT1 _ _) _.
  Proof.
    constructor; try apply _; intros.
    - destruct a as [a fa]. destruct b as [b fb]. constructor; try apply _.
      repeat intro. cbn in x, y. destruct x as [fx ?H]. destruct y as [fy ?H].
      cbn in *. easy.
    - destruct a as [a fa]. cbn. easy.
    - destruct x as [x fx]. destruct y as [y fy]. destruct z as [z fz].
      cbn in f, g. destruct g as [fg ?H]. destruct f as [ff ?H]. cbn. easy.
  Qed.

  (** Example 2.11.6 *)
  Section SLICE_TERMINAL.
    Context {c: C}.

    Definition idSlice: (sliceObj c) := existT (fun dom : C => dom ~> c) c cat_id.

    Instance idTermArrow: TerminalArrow idSlice.
    Proof.
      repeat intro. destruct c0 as [A fA]. do 2 red. unfold idSlice.
      exists fA. apply left_identity.
    Defined.

    Instance idSliceTerminal: Terminal idSlice.
    Proof.
      repeat intro. destruct c0 as [A fA]. repeat red in f'. destruct f' as [fab ?H].
      do 2 red. unfold idSlice. unfold terminal_arrow, idTermArrow. rewrite <- H1.
      symmetry. apply left_identity.
    Qed.

  End SLICE_TERMINAL.

  Section SLICE_COMP_FUNCTOR.

    Context {c d: C} {g: c ~> d}.

    Definition gM (f: sliceObj c) : sliceObj d.
    Proof. destruct f as [X f]. exists X. exact (g >>> f). Defined.

    Instance sliceCompFmap: Fmap gM.
    Proof.
      repeat intro. destruct v as [dv fv]. destruct w as [dw fw].
      cbn. cbn in X. destruct X as [fab ?H]. exists fab.
      rewrite <- comp_assoc. rewrite H1. easy.
    Defined.

    Instance sliceCompFunctor: Functor gM _.
    Proof.
      constructor; try apply _; intros.
      - constructor; try apply _. repeat intro.
        destruct a as [da fa]. destruct b as [db fb]. cbn in x, y.
        destruct x as [fx ?H]. destruct y as [fy ?H]. cbn. cbn in H1. easy.
      - destruct a as [da fa]. cbn. easy.
      - destruct x as [x fx]. destruct y as [y fy]. destruct z as [z fz].
        cbn in g0, f. destruct g0 as [fg ?H]. destruct f as [ff ?H]. cbn. easy.
    Qed.

  End SLICE_COMP_FUNCTOR.

End SLICE_CATEGORY.

(** Chapter 1.6.4: coslice category *)
Section COSLICE_CATEGORY.

  Context `{Category C}.
  Context {o : C}.

  Definition cosliceObj := {cod: C & o ~> cod}.

  Instance cosliceArrows: Arrows cosliceObj.
  Proof.
    intros [A fA] [B fB]. exact {fab: A ~> B | fab >>> fA = fB}.
  Defined.

  Instance cosliceCatEq: forall A B: cosliceObj, Equiv (A ~> B).
  Proof.
    intros [A fA] [B fB]. unfold Arrow, cosliceArrows.
    intros [fab1 ?H] [fab2 ?H]. exact (fab1 = fab2).
  Defined.

  Instance cosliceCatId: CatId cosliceObj.
  Proof.
    intros [A f]. unfold Arrow, cosliceArrows. exists cat_id. apply left_identity.
  Defined.

  Instance cosliceCatComp: CatComp cosliceObj.
  Proof.
    intros [X fX] [Y fY] [Z fZ]. cbn.
    intros [fyz ?H]. intros [fxy ?H]. exists (fyz >>> fxy).
    rewrite <- H1, <- H2. symmetry. apply comp_assoc.
  Defined.

  Instance cosliceCatSetoid: forall (A B: cosliceObj), Setoid (A ~> B).
  Proof.
    intros [A fA] [B fB]. cbn. constructor; repeat intro.
    - destruct x as [f ?H]. now cbn.
    - destruct x as [fx ?H]. destruct y as [fy ?H]. cbn in *. now symmetry.
    - destruct x as [fx ?H]. destruct y as [fy ?H]. destruct z as [fz ?H].
      cbn in *. etransitivity; eauto.
  Qed.

  Instance cosliceCategory: Category cosliceObj.
  Proof.
    constructor; try apply _; intros.
    - destruct a as [a fa]. destruct b as [b fb]. destruct c as [c fc].
      repeat intro. cbn in x, y, x0, y0. destruct x as [fx ?H].
      destruct y as [fy ?H]. destruct x0 as [fz ?H]. destruct y0 as [fw ?H].
      cbn in *. now rewrite H1, H2.
    - destruct a as [a fa]. destruct b as [b fb]. destruct c as [c fc].
      destruct d as [d fd]. cbn in f, g, h. destruct f as [f ?H].
      destruct g as [g ?H]. destruct h as [h ?H]. cbn. apply comp_assoc.
    - destruct a as [a fa]. destruct b as [b fb]. cbn in f. destruct f as [f ?].
      cbn. apply left_identity.
    - destruct a as [a fa]. destruct b as [b fb]. cbn in f. destruct f as [f ?].
      cbn. apply right_identity.
  Qed.

  (** Example 2.11.6 *)
  Definition idCoslice: cosliceObj := existT (fun dom : C => o ~> dom) o cat_id.

  Instance idInitArrow: InitialArrow idCoslice.
  Proof.
    repeat intro. destruct c as [A fA]. do 2 red. unfold idCoslice.
    exists fA. apply right_identity.
  Defined.

  Instance idSliceInitial: Initial idCoslice.
  Proof.
    repeat intro. destruct c as [A fA]. repeat red in f'. destruct f' as [fab ?H].
    do 2 red. unfold idCoslice. do 2 red. rewrite <- H1.
    symmetry. apply right_identity.
  Qed.

End COSLICE_CATEGORY.

(** * Chapter 2.3 Generalized elements *)

Section GENERALIZED_ELEMENTS.

  Context `{Category C}.

  (** Example 2.12.3 *)
  Lemma arrow_eq_iff: forall {c d: C} (f g: c ~> d),
      f = g <-> forall {X: C} (x: X ~> c), f >>> x = g >>> x.
  Proof.
    intros. split; intros.
    - now rewrite H1.
    - specialize (H1 _ cat_id). now rewrite !right_identity in H1.
  Qed.

End GENERALIZED_ELEMENTS.