(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Axiom.Separation.
Require Import BBST.Axiom.Union.
Require Export BBST.Axiom.Infinity.
Require Export BBST.Definition.Include.
Require Export BBST.Definition.Emptyset.
Require Export BBST.Definition.OneTwo.
Require Export BBST.Definition.Successor.
Require Export BBST.Definition.TransitiveSet.

Definition 为自然数 := λ n, ∀ A, 归纳的 A → n ∈ A.

Definition ω := {a ∊ 𝐈 | 为自然数 a}.

Theorem ω是任意归纳集的共通部分 : ∀ A, 归纳的 A → ω ⊆ A.
Proof. intros A H x Hx. apply 分离之条件 in Hx. auto. Qed.

Theorem ω里有且仅有自然数 : ∀ n, n ∈ ω ↔ 为自然数 n.
Proof.
  split.
  - intros n属于ω. now apply 分离除去 in n属于ω.
  - intros n为自然数. apply 分离介入; auto.
    apply n为自然数. apply 无穷公理.
Qed.

(* 皮亚诺公理1 *)
Lemma 零是自然数 : ∅ ∈ ω.
Proof.
  apply 分离介入. apply 无穷公理. intros A [H _]. auto.
Qed.

Lemma ω不为零 : ω ≠ ∅.
Proof.
  intros H. pose proof 零是自然数.
  rewrite H in H0. 空集归谬.
Qed.

Global Hint Immediate 零是自然数 ω不为零 : core.

(* 皮亚诺公理2 *)
Theorem ω是归纳集 : 归纳的 ω.
Proof.
  split. auto.
  intros a Ha. apply 分离之条件 in Ha. apply 分离介入.
  - apply 无穷公理. apply Ha. apply 无穷公理.
  - intros A A归纳. apply A归纳. apply Ha. apply A归纳.
Qed.

Corollary ω归纳 : ∀n ∈ ω, n⁺ ∈ ω.
Proof. apply ω是归纳集. Qed.
Global Hint Resolve ω归纳 : core.

Fact 壹是自然数 : 壹 ∈ ω.
Proof. rewrite <- 零的后继为壹. auto. Qed.
Global Hint Immediate 壹是自然数 : core.

Fact 贰是自然数 : 贰 ∈ ω.
Proof. rewrite <- 壹的后继为贰. auto. Qed.
Global Hint Immediate 贰是自然数 : core.

(* 皮亚诺公理3 *)
Theorem 零不是任何自然数的后继 : ¬ ∃ n ∈ ω, n⁺ = ∅.
Proof. intros [n [Hn H]]. eapply 后继非空. apply H. Qed.

(* 皮亚诺公理5 *)
Theorem 归纳原理 : ∀ N, N ⊆ ω → 归纳的 N → N = ω.
Proof.
  intros N N子集 N归纳. 外延 n Hn.
  - apply N子集. apply Hn.
  - apply 分离之条件 in Hn. apply Hn. apply N归纳.
Qed.

Corollary 归纳法 : ∀ P : 性质, P ∅ → (∀n ∈ ω, P n → P n⁺) → ∀n ∈ ω, P n.
Proof with auto.
  intros P 起始 归纳 n Hn. set {n ∊ ω | P n} as N.
  assert (N = ω). {
    apply 归纳原理. apply 分离为子集. split. apply 分离介入...
    intros m Hm. apply 分离除去 in Hm as [Hm HPm]. apply 分离介入...
  }
  rewrite <- H in Hn. apply 分离之条件 in Hn...
Qed.

Ltac 归纳 n Hn :=
  match goal with
    | |- ∀n ∈ ω, _ => intros n Hn; pattern n
    | Hn: n ∈ ω |- _ => pattern n
  end;
  match goal with |- ?P n => let IH := fresh "归纳假设" in
    generalize dependent n; apply (归纳法 P); [|intros n Hn IH]
  end.

Tactic Notation "归纳" simple_intropattern(n) simple_intropattern(Hn) := 归纳 n Hn.
Tactic Notation "归纳" simple_intropattern(n) := 归纳 n ?Hn.
Tactic Notation "归纳" := let n := fresh "n" in let Hn := fresh "Hn" in 归纳 n Hn.

Theorem 非零自然数的前驱存在 : ∀n ∈ ω, n ≠ ∅ → ∃k ∈ ω, n = k⁺.
Proof.
  归纳.
  - (* n = ∅ *) intros 矛盾. easy.
  - (* n = m⁺ *) intros _. exists n. split; easy.
Qed.

Ltac 讨论 n := match goal with | Hn: n ∈ ω |- _ =>
  let H := fresh "H" in let p := fresh "p" in
  let Hp := fresh "Hp" in let Heq := fresh "Heq" in
  排中 (n = ∅) as [|H]; [|
    apply (非零自然数的前驱存在 n Hn) in H as [p [Hp Heq]]
  ]; subst n; [|rename p into n] end.

(* 练习5-1 *)
Fact 零小于后继数 : ∀n ∈ ω, ∅ ∈ n⁺.
Proof. 归纳; auto. Qed.
Global Hint Immediate 零小于后继数 : core.

Theorem ω为传递集 : 为传递集 ω.
Proof.
  apply 传递集即其元素都为其子集. 归纳.
  - (* n = ∅ *) auto.
  - (* n = m⁺ *) intros x Hx. apply 后继除去 in Hx as [].
    + now apply 归纳假设.
    + now subst.
Qed.
Global Hint Resolve ω为传递集 : core.

Theorem 自然数为传递集 : ∀n ∈ ω, 为传递集 n.
Proof.
  归纳; intros p q Hp Hq.
  - 空集归谬.
  - apply 后继除去 in Hq as [].
    + apply 左后继介入. eapply 归纳假设; eauto.
    + subst. auto.
Qed.
Global Hint Immediate 自然数为传递集 : core.

(* 皮亚诺公理4 *)
Lemma 后继是单射 : ∀ n m ∈ ω, n⁺ = m⁺ → n = m.
Proof.
  intros n Hn m Hm 相等.
  apply 自然数为传递集 in Hn, Hm.
  rewrite 传递集即其后继的并等于自身 in Hn, Hm.
  congruence.
Qed.


From Coq Require Import Program.Program.
From Coq Require Import Relations.Relations.
From Coq Require Import Setoids.Setoid.
From Coq Require Import Classes.Morphisms.
From Coq Require Import Classes.RelationClasses.

Declare Scope vsa.
#[global]
Open Scope vsa.

Class Ord A := ord: relation A.
Class Equiv A := equiv: relation A.
#[global]
Typeclasses Transparent Ord Equiv.

Infix "⊑" := ord (at level 60, no associativity) : vsa.
Notation "(⊑)" := ord (only parsing) : vsa.
Notation "( X ⊑)" := (ord X) (only parsing) : vsa.
Notation "(⊑ X )" := (fun Y => Y ⊑ X) (only parsing) : vsa.

Infix "=" := equiv : type_scope.
Notation "(=)" := equiv (only parsing) : vsa.
Notation "( x =)" := (equiv x) (only parsing) : vsa.
Notation "(= x )" := (fun y => equiv y x) (only parsing) : vsa.

Infix "≡" := eq (at level 70, no associativity) : vsa.
Notation "(≡)" := eq (only parsing) : vsa.
Notation "( x ≡)" := (eq x) (only parsing) : vsa.
Notation "(≡ x )" := (fun y => eq y x) (only parsing) : vsa.

Class Setoid (A: Type) `{E: Equiv A}: Prop :=
  setoid_equiv :> Equivalence (=).

Class Poset (A: Type) `{E: Equiv A} `{O: Ord A}: Prop := {
  poset_setoid :> Setoid A;
  poset_refl :> Reflexive (⊑);
  poset_antisym :> Antisymmetric A (=) (⊑);
  poset_trans :> Transitive (⊑);
  poset_proper :> Proper ((=) ==> (=) ==> iff) (⊑)
}.

Section Dual.

  #[local]
  Set Printing Implicit.

  Context (A: Type) {E: Equiv A} {O: Ord A}.

  Definition DualOrd: Ord A := flip (⊑).

  Hint Unfold DualOrd: core.

  Lemma DualOrd_Reflexive {P: Poset A}: Reflexive DualOrd.
  Proof. firstorder. Qed.

  Hint Unfold Antisymmetric: core.

  Lemma DualOrd_Antisymmetric {P: Poset A}: Antisymmetric A E DualOrd.
  Proof.
    autounfold. intros. now apply antisymmetry.
  Qed.

  Lemma DualOrd_Transitive {P: Poset A}: Transitive DualOrd.
  Proof. firstorder. Qed.

  Lemma DualPoset {P: Poset A}: @Poset A E DualOrd.
  Proof.
    pose proof (poset_setoid) as S.
    apply Build_Poset with S.
    - exact DualOrd_Reflexive.
    - exact DualOrd_Antisymmetric.
    - exact DualOrd_Transitive.
    - repeat intro. split; intro; cbv.
        rewrite <- H0. rewrite <- H. assumption.
        rewrite H0. rewrite H. assumption.
  Defined.

End Dual.

Section PropSetoid.

  #[global]
  Instance PropEquiv: Equiv Prop := iff.
  #[global]
  Instance PropOrd: Ord Prop := impl.

  #[program, global]
  Instance PropSetoid: Setoid Prop.

  #[program, global]
  Instance PropPoset: Poset Prop.
  Solve All Obligations with firstorder.

End PropSetoid.

Section Projection.

  Context {A B: Type}.

  Lemma projected_setoid `{Setoid B} `{Equiv A} (f: A -> B)
    (eq_correct : forall x y, x = y <-> f x = f y) : Setoid A.
  Proof.
    constructor; repeat intro; apply eq_correct.
      reflexivity.
     symmetry. now apply eq_correct.
    transitivity (f y); now apply eq_correct.
  Qed.

  Lemma projected_poset `{Poset B} `{Equiv A} `{Ord A} (f: A -> B)
    (eq_correct : forall x y, x = y <-> f x = f y)
    (ord_correct : forall x y, x ⊑ y <-> f x ⊑ f y): Poset A.
  Proof.
    constructor 1 with (projected_setoid f eq_correct);
      repeat intro.
    - apply ord_correct. reflexivity.
    - apply eq_correct. apply antisymmetry; now apply ord_correct.
    - apply ord_correct. transitivity (f y); now apply ord_correct.
    - split; intro; apply ord_correct.
       rewrite eq_correct in H2, H3. rewrite <- H2. rewrite <- H3. now apply ord_correct.
      rewrite eq_correct in H2, H3. rewrite H2. rewrite H3. now apply ord_correct.
  Qed.

End Projection.

Notation "x ↾ p" := (exist _ x p) (at level 20) : vsa.

Definition SigEquiv {A: Type} `{Equiv A} (P: A -> Prop) : Equiv (sig P) := fun x y => `x = `y.
Definition SigOrd {A: Type} `{Ord A} (P: A -> Prop) : Ord (sig P) := fun x y => `x ⊑ `y.
Ltac simpl_sig_setoid :=
  match goal with
  | |- (@equiv _ (@SigEquiv _ ?e _) (?x↾_) (?y↾_)) => change (@equiv _ e x y)
  | |- (@ord _ (@SigOrd _ ?e _) (?x↾_) (?y↾_)) => change (@ord _ e x y)
  end.

#[global]
Hint Extern 10 (Equiv (sig _)) => apply @SigEquiv: typeclass_instances.
#[global]
Hint Extern 10 (Ord (sig _)) => apply @SigOrd: typeclass_instances.
#[global]
Hint Extern 4 (@equiv _ (SigEquiv _ _ _) (_↾_) (_↾_)) => simpl_sig_setoid: core.
#[global]
Hint Extern 4 (@ord _ (SigOrd _ _ _) (_↾_) (_↾_)) => simpl_sig_setoid: core.

#[global]
Instance SigSetoid {A: Type} `{Setoid A} (P : A -> Prop) : Setoid (sig P).
Proof. now apply (projected_setoid (@proj1_sig _ P)). Qed.

#[global]
Instance SigPoset {A: Type} `{Poset A} (P : A -> Prop) : Poset (sig P).
Proof. now apply (projected_poset (@proj1_sig _ P)). Qed.

Structure Morphism (X A: Type) `{!Equiv X} `{!Equiv A} : Type := {
  morphism : X -> A;
  morphism_proper :> Proper ((=) ==> (=)) morphism
}.

Coercion morphism : Morphism >-> Funclass.
Notation "X → A" := (Morphism X A) (at level 80, right associativity).

Section Pointwise.

  Context (X A: Type) `{!Equiv X} `{!Equiv A} `{!Ord A}.

  #[global]
  Instance PointwiseEquiv: Equiv (X → A) :=
    fun f g => forall (x: X), f x = g x.

  #[global]
  Instance PointwiseOrd: Ord (X → A) :=
    fun f g => forall (x: X), f x ⊑ g x.

  #[program, global]
  Instance PointwiseEquiv_Equivalence `{!Setoid A}: Equivalence PointwiseEquiv.
  Solve All Obligations with firstorder.

  #[global]
  Instance PointwiseOrd_Reflexive `{!Poset A}: Reflexive PointwiseOrd.
  Proof. firstorder. Qed.

  #[global]
  Instance PointwiseOrd_Antisymmetric `{!Poset A}: Antisymmetric (X → A) PointwiseEquiv PointwiseOrd.
  Proof.
    intros f g H1 H2 x. now apply antisymmetry.
  Qed.

  #[global]
  Instance PointwiseOrd_Transitive `{!Poset A}: Transitive PointwiseOrd.
  Proof. firstorder. Qed.

  #[program, global]
  Instance PointwisePoset `{!Poset A}: Poset (X → A).
  Next Obligation.
    intros f f' H__f g g' H__g.
    unfold equiv in H__f, H__g. unfold PointwiseEquiv in H__f, H__g. unfold ord. unfold PointwiseOrd.
    (* TODO: (=) valid under equiv, impl, forall & exist *)
    split; intros H x.
    - rewrite <- H__f. rewrite <- H__g. apply H.
    - rewrite H__f. rewrite H__g. apply H.
  Qed.

End Pointwise.

Class Sett (A: Type) `{!Equiv A} : Type := {
  sett : A -> Prop;
  set_proper :> Proper ((=) ==> iff) sett
}.

Coercion sett : Sett >-> Funclass.
Notation "℘ A" := (Sett A) (at level 79).

Definition SetContains {A: Type} `{!Equiv A} (x: A) (P: ℘ A): Prop :=
  sett x.

#[program]
Definition SetSingleton {A: Type} `{Setoid A} (x: A): ℘ A :=
  Build_Sett _ _ (fun t => t = x) _.
Next Obligation. solve_proper. Qed.
#[program]
Definition SetList {A: Type} `{Setoid A} (l: list A): ℘ A :=
  Build_Sett _ _ (fun t => (fix f l' :=
          match l' with
          | nil => False
          | cons x q => t = x \/ (f q)
          end) l) _.
Next Obligation.
  split; induction l; auto; intros [|]; [left | right | left | right]; firstorder.
Qed.
#[program]
Definition SetProp {A: Type} `{Setoid A} (P: A -> Prop) `{!Proper ((=) ==> iff) P}: ℘ A :=
  Build_Sett _ _ P _.
#[program]
Definition SetEmpty {A: Type}: ℘ A := Build_Sett _ _ (fun _ => False) _.
#[program]
Definition SetFull {A: Type}: ℘ A := Build_Sett _ _ (fun _ => True) _.

Notation "x ∈ P" := (SetContains x P) (at level 19).
Notation "{{ x }}" := (SetSingleton x).
Notation "{{ x ; y ; .. ; z }}" := (SetList (cons x (cons y (.. (cons z nil) ..)))).
Notation "{{ x | P }}" := (SetProp (fun x => P)).
Notation "{{ x : A | P }}" := (SetProp (fun x : A => P)).
Notation "∅" := SetEmpty.

Lemma set_contains_singleton {A: Type} `{Setoid A} (x: A):
  forall u, u ∈ {{ x }} <-> u = x.
Proof. reflexivity. Qed.

Lemma set_contains_pair {A: Type} `{Setoid A} (x y: A):
  forall u, u ∈ {{ x; y }} <-> u = x \/ u = y.
Proof. unfold SetContains. simpl. firstorder. Qed.

Lemma set_contains_empty {A: Type} `{Setoid A}:
  forall (u: A), u ∈ ∅ -> False.
Proof. contradiction. Qed.

Lemma set_contains_full {A: Type} `{Setoid A}:
  forall (u: A), u ∈ SetFull.
Proof. unfold SetContains. simpl. auto. Qed.

Section Powerset.

  Context {X: Type} `{Setoid X}.

  #[global]
  Instance PowersetEquiv: Equiv (℘ X) :=
    fun P Q => forall f, f ∈ P <-> f ∈ Q.

  #[global]
  Instance PowersetOrd: Ord (℘ X) :=
    fun P Q => forall x, x ∈ P -> x ∈ Q.

  #[program, global]
  Instance PowersetSetoid: Setoid (℘ X).
  Solve All Obligations with firstorder.

  #[program, global]
  Instance PowersetPoset: Poset (℘ X).
  Solve All Obligations with firstorder.

End Powerset.

#[global]
Add Parametric Morphism {A: Type} `{Equiv A}: (@SetContains A _)
  with signature (=) ==> (=) ==> iff as SetContains_Morphism.
Proof.
  intros x y H__eq [f H__f] [g H__g] H__fg.
  unfold SetContains. unfold SigEquiv in *. unfold equiv in *. unfold PowersetEquiv in *. simpl in *.
  rewrite H__fg. rewrite H__eq. reflexivity.
Qed.

Class SgOp A `{Equiv A} := sg_op: A → A → A.
Class SgSetOp A `{Equiv A} := sg_set_op: ℘ A → A.
Class MonUnit A := mon_unit: A.

#[global]
Typeclasses Transparent SgOp SgSetOp MonUnit.

Infix "&" := sg_op (at level 50, left associativity) : vsa.
Notation "(&)" := sg_op (only parsing) : vsa.
Notation "( x &)" := (sg_op x) (only parsing) : vsa.
Notation "(& x )" := (fun y => y & x) (only parsing) : vsa.

Definition UpperBound {A: Type} `{Poset A} (S: ℘ A) (u: A) := forall x, x ∈ S -> x ⊑ u.
Definition LowerBound {A: Type} `{Poset A} (S: ℘ A) (u: A) := forall x, x ∈ S -> u ⊑ x.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.
Require Import WildCat.Core.
Require Import WildCat.Equiv.
Require Import WildCat.Induced.
Require Import WildCat.NatTrans.

(** * Wild functor categories *)

(** ** Categories of 0-coherent 1-functors *)

Record Fun01 (A B : Type) `{IsGraph A} `{IsGraph B} := {
  fun01_F : A -> B;
  fun01_is0functor : Is0Functor fun01_F;
}.

Coercion fun01_F : Fun01 >-> Funclass.
Existing Instance fun01_is0functor.

Definition NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} (F G : A -> B)
           {ff : Is0Functor F} {fg : Is0Functor G}
  := { alpha : F $=> G & Is1Natural F G alpha }.

(** Note that even if [A] and [B] are fully coherent oo-categories, the objects of our "functor category" are not fully coherent.  Thus we cannot in general expect this "functor category" to itself be fully coherent.  However, it is at least a 0-coherent 1-category, as long as [B] is a 1-coherent 1-category. *)

Global Instance is0cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is01Cat (Fun01 A B).
Proof.
  srapply Build_Is01Cat.
  - intros [F ?] [G ?].
    exact (NatTrans F G).
  - intros [F ?]; cbn.
    exists (id_transformation F); exact _.
  - intros [F ?] [G ?] [K ?] [gamma ?] [alpha ?]; cbn in *.
    exists (comp_transformation gamma alpha); exact _.
Defined.

(** In fact, in this case it is automatically also a 0-coherent 2-category and a 1-coherent 1-category, with a totally incoherent notion of 2-cell between 1-coherent natural transformations. *)

Global Instance is0coh2cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is1Cat (Fun01 A B).
Proof.
  srapply Build_Is1Cat.
  - intros [F ?] [G ?]; serapply Build_Is01Cat.
    + intros [alpha ?] [gamma ?].
      exact (forall a, alpha a $== gamma a).
    + intros [alpha ?] a; cbn.
      reflexivity.
    + intros [alpha ?] [gamma ?] [phi ?] nu mu a.
      exact (mu a $@ nu a).
  - intros [F ?] [G ?]; serapply Build_Is0Gpd.
    intros [alpha ?] [gamma ?] mu a.
    exact ((mu a)^$).
  - intros [F ?] [G ?] [K ?] [alpha ?].
    serapply Build_Is0Functor.
    intros [phi ?] [mu ?] f a.
    exact (alpha a $@L f a).
  - intros [F ?] [G ?] [K ?] [alpha ?].
    serapply Build_Is0Functor.
    intros [phi ?] [mu ?] f a.
    exact (f a $@R alpha a).
  - intros [F ?] [G ?] [K ?] [L ?] [alpha ?] [gamma ?] [phi ?] a; cbn.
    serapply cat_assoc.
  - intros [F ?] [G ?] [alpha ?] a; cbn.
    serapply cat_idl.
  - intros [F ?] [G ?] [alpha ?] a; cbn.
    serapply cat_idr.
Defined.

(** It also inherits a notion of equivalence, namely a natural transformation that is a pointwise equivalence.  Note that this is not a "fully coherent" notion of equivalence, since the functors and transformations are not themselves fully coherent. *)

Definition NatEquiv {A B : Type} `{IsGraph A} `{HasEquivs B}
           (F G : A -> B) `{!Is0Functor F, !Is0Functor G}
  := { alpha : forall a, F a $<~> G a & Is1Natural F G (fun a => alpha a) }.

Global Instance hasequivs_fun01 (A B : Type) `{Is01Cat A} `{HasEquivs B}
  : HasEquivs (Fun01 A B).
Proof.
  srapply Build_HasEquivs.
  1:{ intros [F ?] [G ?]. exact (NatEquiv F G). }
  1:{ intros [F ?] [G ?] [alpha ?]; cbn in *.
      exact (forall a, CatIsEquiv (alpha a)). }
  all:intros [F ?] [G ?] [alpha alnat]; cbn in *.
  - exists (fun a => alpha a); assumption.
  - intros a; exact _.
  - intros ?; srefine (_;_).
    + intros a; exact (Build_CatEquiv (alpha a)).
    + cbn. refine (is1natural_homotopic alpha _).
      intros a; apply cate_buildequiv_fun.
  - cbn; intros; apply cate_buildequiv_fun.
  - intros ?; exists (fun a => (alpha a)^-1$).
    apply Build_Is1Natural; intros a b f.
    refine ((cat_idr _)^$ $@ _).
    refine ((_ $@L (cate_isretr (alpha a))^$) $@ _).
    refine (cat_assoc _ _ _ $@ _).
    refine ((_ $@L (cat_assoc_opp _ _ _)) $@ _).
    refine ((_ $@L ((isnat (fun a => alpha a) f)^$ $@R _)) $@ _).
    refine ((_ $@L (cat_assoc _ _ _)) $@ _).
    refine (cat_assoc_opp _ _ _ $@ _).
    refine ((cate_issect (alpha b) $@R _) $@ _).
    exact (cat_idl _).
  - intros; apply cate_issect.
  - intros; apply cate_isretr.
  - intros [gamma ?] r s a; cbn in *.
    refine (catie_adjointify (alpha a) (gamma a) (r a) (s a)).
Defined.

(** ** Categories of 1-coherent 1-functors *)

Record Fun11 (A B : Type) `{Is1Cat A} `{Is1Cat B} :=
{
  fun11_fun : A -> B ;
  is0functor_fun11 : Is0Functor fun11_fun ;
  is1functor_fun11 : Is1Functor fun11_fun
}.

Coercion fun11_fun : Fun11 >-> Funclass.
Global Existing Instance is0functor_fun11.
Global Existing Instance is1functor_fun11.

Arguments Build_Fun11 {A B _ _ _ _} F _ _ : rename.

Definition fun01_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B}
           (F : Fun11 A B)
  : Fun01 A B.
Proof.
  exists F; exact _.
Defined.

Global Instance is01cat_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B} : Is01Cat (Fun11 A B).
Proof.
  exact (induced_01cat (fun01_fun11)).
Defined.

Global Instance is1cat_fun11 {A B :Type} `{Is1Cat A} `{Is1Cat B} : Is1Cat (Fun11 A B).
Proof.
  exact (induced_1cat (fun01_fun11)).
Defined.

Global Instance hasequivs_fun11 {A B : Type} `{Is1Cat A} `{HasEquivs B} : HasEquivs (Fun11 A B).
Proof.
  exact (induced_hasequivs fun01_fun11).
Defined.


(* Adapted from http://poleiro.info/posts/2013-04-03-parse-errors-as-type-errors.html,
   https://github.com/arthuraa/poleiro/blob/master/theories/ForceOption.v
   to produce N instead of nat *)

Require Export Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.NArith.

Local Open Scope char_scope.

Local Open Scope N_scope.

Definition binDigitToN (c : ascii) : option N :=
  match c with
    | "0" => Some 0
    | "1" => Some 1
    | _   => None
  end.

Open Scope string_scope.

Fixpoint readBinNAux (s : string) (acc : N) : option N :=
  match s with
    | "" => Some acc
    | String c s' =>
      match binDigitToN c with
        | Some n => readBinNAux s' (2 * acc + n)
        | None => None
      end
  end.

Definition readBinN (s : string) : option N := readBinNAux s 0.

Goal readBinN "11111111" = Some 255.
Proof. reflexivity. Qed.

Definition forceOption A Err (o : option A) (err : Err) : match o with
                                                            | Some _ => A
                                                            | None => Err
                                                          end :=
  match o with
    | Some a => a
    | None => err
  end.

Inductive parseError := ParseError.

Definition bin (s : string) := forceOption N parseError (readBinN s) ParseError.

Goal bin"11111111" = 255.
Proof. reflexivity. Qed.

Goal bin"1011" = 11.
Proof. reflexivity. Qed.

Goal bin"1O" = ParseError.
Proof. reflexivity. Qed.


(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export lists.

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Check list.

Check (nil nat).

Check (cons nat 3 (nil nat)).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Module MumbleGrumble.

Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.

Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(*
 d (b a 5) Yes
 d mumble (b a 5) Yes
 d bool (b a 5) Yes
 e bool true Yes
 e mumble (b c 0) Yes
 ebool (b c 0) No
 c Yes
*)

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.
Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.
Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.
Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Fail Definition mynil := nil.

Definition mynil : list nat := nil.

Check @nil.

Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall(X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  induction l.
  - reflexivity.
  - simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  induction l.
  - simpl. reflexivity.
  - simpl.
    intros.
    rewrite IHl.
    reflexivity.
Qed.

Lemma app_length : forall(X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  induction l1.
  - simpl.
    reflexivity.
  - intros.
    simpl.
    rewrite IHl1.
    reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  induction l1.
  - simpl.
    intros.
    rewrite -> app_nil_r.
    reflexivity.
  - simpl.
    intros.
    rewrite -> IHl1.
    rewrite <- app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    rewrite -> IHl.
    simpl.
    reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Check @combine.
Compute (combine [1;2] [false;false;true;true]).

Fixpoint split
  {X Y : Type}
  (l : list (X*Y)):
  (list X) * (list Y) :=
 match l with
 | [] => ([], [])
 | h :: t => ([fst h] ++ (fst (split t)), [snd h] ++ (snd (split t)))
 end.

Example test_split:
  split [(1,false);(2,false);(3, false)] = ([1;2;3],[false;false;false]).
Proof. simpl. reflexivity. Qed.

Module OptionPlayground.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n =? O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | h :: t => Some h
  end.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Check @doit3times.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h :: t => if test h
      then h :: (filter test t)
      else filter test t
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.

Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

 Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun x => andb (evenb x) (leb 7 x)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type}
(test : X -> bool) (l : list X): list X * list X :=
  ((filter test l), filter (fun x => negb( test x)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

Lemma map_assoc: forall (X Y: Type) (f: X -> Y) (x: X) (l: list X),
  map f (l ++ [x]) = map f l ++ [f x].
Proof.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite <- IHl.
    rewrite -> map_assoc.
    reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y) :=
  match l with
  | [] => []
  | h :: t => f h ++ flat_map f t
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Check (fold andb).

Example fold_example1:
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition manual_grade_for_fold_types_different : option (nat*string) := None.

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.

Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.

Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Module Exercises.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite <- IHl.
    reflexivity.
Qed.

Definition manual_grade_for_fold_map : option (nat*string) := None.

Definition prod_curry {X Y Z : Type}
(f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
(f : X -> Y -> Z) (p : X * Y) : Z :=
  match p with
  | (x, y) => f x y
  end.

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry:
  forall(X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros.
  reflexivity.
Qed.

Module Church.

Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

Check @doit3times.
Compute zero.

Definition succ (n : cnat) : cnat :=
  fun _ f x => f (n _ f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. simpl. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. simpl. reflexivity. Qed.

Definition plus (n m : cnat) : cnat :=
  fun _ f x => n _ f (m _ f x).

(*
  n = two
  m = three
  x = x
  two f (three f x) =>
  two f (f (f (f x))) =>
  f ( f (f (f (f x))))
*)

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2 : plus two one = three.
Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition mult (n m : cnat) : cnat :=
  fun _ f x => (n _ (m _ f) x).

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

Definition exp (n m : cnat) : cnat :=
  fun _ f x => (n _ (m _) f)  x.

End Church.
End Exercises.


(**
Utility definitions for well-founded recursion
*)

Require Import Coq.Program.Wf.
Require Import Coq.Wellfounded.Wellfounded.
Require Import Coq.Init.Specif.

Definition wfFix1 {a n r}
  (R : n -> n -> Prop)
  (m : a -> n)
  (Hwf : well_founded R)
  (F : forall x : a, ({x' : a | R (m x') (m x)} -> r) -> r)
  : a -> r :=
       @Wf.Fix_sub a _ (wf_inverse_image _ _ R m Hwf) (fun _ => r)  F.

Definition wfFix2 {a b n r}
  (R : n -> n -> Prop)
  (m : a -> b -> n)
  (Hwf : well_founded R)
  (F : forall (x : a) (y : b), (forall (x' : a), {y' : b | R (m x' y') (m x y)} -> r) -> r)
  (x : a)
  (y : b)
  : r :=
      let m' (p : a * b) : n := m (fst p) (snd p) in
      let F' (p : a * b) (rec : {p' : a * b | R (m' p') (m' p)} -> r) : r
             := let x := fst p in let y := snd p in
                let rec' (x' : a) (yH' : {y' : b | R (m x' y') (m x y)})
                  := let y' := proj1_sig yH' in
                     let H  := proj2_sig yH' in
                     rec (exist _ (x',y') H)
                in F x y rec'
      in wfFix1 R m' Hwf F' (x, y).

Definition wfFix3 {a b c n r}
  (R : n -> n -> Prop)
  (m : a -> b -> c -> n)
  (Hwf : well_founded R)
  (F : forall (x : a) (y : b) (z : c), (forall (x' : a) (y' : b), {z' : c | R (m x' y' z') (m x y z)} -> r) -> r)
  (x : a)
  (y : b)
  (z : c)
  : r :=
      let m' (p : a * b * c) : n := m (fst (fst p)) (snd (fst p)) (snd p) in
      let F' (p : a * b * c) (rec : {p' : a * b * c | R (m' p') (m' p)} -> r) : r
             := let x := fst (fst p) in let y := snd (fst p) in let z := snd p in
                let rec' (x' : a) (y' : b) (zH' : {z' : c | R (m x' y' z') (m x y z)})
                  := let z' := proj1_sig zH' in
                     let H  := proj2_sig zH' in
                     rec (exist _ (x',y',z') H)
                in F x y z rec'
      in wfFix1 R m' Hwf F' (x, y, z).

Lemma wfFix1_eq:
  forall (a n r : Type) (R : n -> n -> Prop) (m : a -> n) (Hwf : well_founded R),
  forall F x,
  @wfFix1 a n r R m Hwf F x = F x (fun xH => wfFix1 R m Hwf F (proj1_sig xH)).
Proof.
  intros.
  apply Coq.Program.Wf.WfExtensionality.fix_sub_eq_ext with (P := fun _ : a => r).
Qed.

Lemma wfFix2_eq:
  forall (a b n r : Type) (R : n -> n -> Prop) (m : a -> b -> n) (Hwf : well_founded R),
  forall F x y,
  @wfFix2 a b n r R m Hwf F x y = F x y (fun x yH => wfFix2 R m Hwf F x (proj1_sig yH)).
Proof.
  intros.
  apply wfFix1_eq.
Qed.

Lemma wfFix3_eq:
  forall (a b c n r : Type) (R : n -> n -> Prop) (m : a -> b -> c -> n) (Hwf : well_founded R),
  forall F x y z,
  @wfFix3 a b c n r R m Hwf F x y z = F x y z (fun x y zH => wfFix3 R m Hwf F x y (proj1_sig zH)).
Proof.
  intros.
  apply wfFix1_eq.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Zsqrt.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Import ZArithRing.
Require Import Omega.
Require Export ZArith_base.
Open Local Scope Z_scope.

(**********************************************************************)
(** Definition and properties of square root on Z *)

(** The following tactic replaces all instances of (POS (xI ...)) by
    `2*(POS ...)+1`, but only when ... is not made only with xO, XI, or xH. *)
Ltac compute_POS :=
  match goal with
    |  |- context [(Zpos (xI ?X1))] =>
      match constr:X1 with
	| context [1%positive] => fail 1
	| _ => rewrite (BinInt.Zpos_xI X1)
      end
    |  |- context [(Zpos (xO ?X1))] =>
      match constr:X1 with
	| context [1%positive] => fail 1
	| _ => rewrite (BinInt.Zpos_xO X1)
      end
  end.

Inductive sqrt_data (n:Z) : Set :=
  c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n.

Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
  refine
    (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) :=
      match p return sqrt_data (Zpos p) with
	| xH => c_sqrt 1 1 0 _ _
	| xO xH => c_sqrt 2 1 1 _ _
	| xI xH => c_sqrt 3 1 2 _ _
	| xO (xO p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r') with
		| left Hle =>
                  c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1)
                  (4 * r' - (4 * s' + 1)) _ _
		| right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _
              end
          end
	| xO (xI p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with
		| left Hle =>
                  c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1)
                  (4 * r' + 2 - (4 * s' + 1)) _ _
		| right Hgt =>
                  c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _
              end
          end
	| xI (xO p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with
		| left Hle =>
                  c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1)
                  (4 * r' + 1 - (4 * s' + 1)) _ _
		| right Hgt =>
                  c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _
              end
          end
	| xI (xI p') =>
          match sqrtrempos p' with
            | c_sqrt s' r' Heq Hint =>
              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with
		| left Hle =>
                  c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1)
                  (4 * r' + 3 - (4 * s' + 1)) _ _
            | right Hgt =>
                c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _
            end
        end
    end); clear sqrtrempos; repeat compute_POS;
 try (try rewrite Heq; ring); try omega.
Defined.

(** Define with integer input, but with a strong (readable) specification. *)
Definition Zsqrt :
  forall x:Z,
    0 <= x ->
    {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}.
  refine
    (fun x =>
      match
	x
	return
        0 <= x ->
        {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}
	with
	| Zpos p =>
          fun h =>
            match sqrtrempos p with
              | c_sqrt s r Heq Hint =>
		existS
                (fun s:Z =>
                  {r : Z |
                    Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)})
                s
                (exist
                  (fun r:Z =>
                    Zpos p = s * s + r /\
                    s * s <= Zpos p < (s + 1) * (s + 1)) r _)
            end
	| Zneg p =>
          fun h =>
            False_rec
            {s : Z &
              {r : Z |
		Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
            (h (refl_equal Datatypes.Gt))
	| Z0 =>
          fun h =>
            existS
            (fun s:Z =>
              {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0
            (exist
               (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0
               _)
    end); try omega.
 split; [ omega | rewrite Heq; ring_simplify (s*s) ((s + 1) * (s + 1)); omega ].
Defined.

(** Define a function of type Z->Z that computes the integer square root,
    but only for positive numbers, and 0 for others. *)
Definition Zsqrt_plain (x:Z) : Z :=
  match x with
    | Zpos p =>
      match Zsqrt (Zpos p) (Zorder.Zle_0_pos p) with
	| existS s _ => s
      end
    | Zneg p => 0
    | Z0 => 0
  end.

(** A basic theorem about Zsqrt_plain *)

Theorem Zsqrt_interval :
  forall n:Z,
    0 <= n ->
    Zsqrt_plain n * Zsqrt_plain n <= n <
    (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1).
Proof.
  intros x; case x.
  unfold Zsqrt_plain in |- *; omega.
  intros p; unfold Zsqrt_plain in |- *;
    case (Zsqrt (Zpos p) (Zorder.Zle_0_pos p)).
  intros s [r [Heq Hint]] Hle; assumption.
  intros p Hle; elim Hle; auto.
Qed.

(** Positivity *)

Theorem Zsqrt_plain_is_pos: forall n, 0 <= n ->  0 <= Zsqrt_plain n.
Proof.
  intros n m; case (Zsqrt_interval n); auto with zarith.
  intros H1 H2; case (Zle_or_lt 0 (Zsqrt_plain n)); auto.
  intros H3; contradict H2; auto; apply Zle_not_lt.
  apply Zle_trans with ( 2 := H1 ).
  replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1))
     with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1));
  auto with zarith.
  ring.
Qed.

(** Direct correctness on squares. *)

Theorem Zsqrt_square_id: forall a, 0 <= a ->  Zsqrt_plain (a * a) = a.
Proof.
  intros a H.
  generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa.
  case (Zsqrt_interval (a * a)); auto with zarith.
  intros H1 H2.
  case (Zle_or_lt a (Zsqrt_plain (a * a))); intros H3; auto.
  case Zle_lt_or_eq with (1:=H3); auto; clear H3; intros H3.
  contradict H1; auto; apply Zlt_not_le; auto with zarith.
  apply Zle_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith.
  apply Zmult_lt_compat_r; auto with zarith.
  contradict H2; auto; apply Zle_not_lt; auto with zarith.
  apply Zmult_le_compat; auto with zarith.
Qed.

(** [Zsqrt_plain] is increasing *)

Theorem Zsqrt_le:
 forall p q, 0 <= p <= q  ->  Zsqrt_plain p <= Zsqrt_plain q.
Proof.
  intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2;
  [ | subst q; auto with zarith].
  case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3.
  assert (Hp: (0 <= Zsqrt_plain q)).
   apply Zsqrt_plain_is_pos; auto with zarith.
  absurd (q <= p); auto with zarith.
  apply Zle_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)).
  case (Zsqrt_interval q); auto with zarith.
  apply Zle_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith.
  apply Zmult_le_compat; auto with zarith.
  case (Zsqrt_interval p); auto with zarith.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

Require Export ZArith.
Require Export Rbase.

Require Import ClassicalEpsilon.

Class WhyType T := {
  why_inhabitant : T ;
  why_decidable_eq : forall x y : T, { x = y } + { x <> y }
}.

Notation int := Z.
Notation IZR := IZR (only parsing).

Global Instance int_WhyType : WhyType int.
Proof.
split.
exact Z0.
exact Z_eq_dec.
Qed.

Notation real := R.

Global Instance real_WhyType : WhyType real.
Proof.
split.
exact R0.
intros x y.
destruct (total_order_T x y) as [[H|H]|H] ;
  try (left ; exact H) ; right.
now apply Rlt_not_eq.
now apply Rgt_not_eq.
Qed.

Global Instance tuple_WhyType : forall T {T' : WhyType T} U {U' : WhyType U}, WhyType (T * U).
Proof.
intros T WT U WU.
split.
split ; apply why_inhabitant.
intros (x1,x2) (y1,y2).
destruct (why_decidable_eq x1 y1) as [H1|H1].
destruct (why_decidable_eq x2 y2) as [H2|H2].
left.
now apply f_equal2.
right.
now injection.
right.
now injection.
Qed.

Global Instance unit_WhyType : WhyType unit.
Proof.
split.
exact tt.
intros [] [].
now left.
Qed.

Global Instance bool_WhyType : WhyType bool.
Proof.
split.
exact false.
exact Bool.bool_dec.
Qed.

Global Instance func_WhyType : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, WhyType (a -> b).
Proof.
intros.
repeat split.
exact (fun _ => why_inhabitant).
intros x y.
apply excluded_middle_informative.
Qed.


(** 対角線論法の証明 *)

From mathcomp Require Import all_ssreflect.

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

Axiom Excluded_Middle : forall (P : Prop), P \/ ~P. (* 排中律 *)
Axiom Absurd : forall (P : Prop), ~ P /\ P -> False.

Section DIAG.
  Variable φ : nat -> nat -> bool.         (* 自己参照1 *)

  Definition diag (n : nat) : bool := ~~ φ n n. (* 対角線関数 *)

  Goal exists (g : nat -> bool),
      forall (n : nat), φ n <> g. (* 自己参照2 *)
  Proof.
    exists diag.
    move=> n Hc.
    case: (Excluded_Middle (φ n n = diag n)).
    (* φ n n = diag n -> False *)
    (* diag をその定義で展開する。 *)
    - rewrite /diag => H1.
      by case H2 : (φ n n); rewrite H2 in H1.
    (* φ n n <> diag n -> False *)
    (* diag をHcで展開する。 *)
    - by rewrite Hc.
  Qed.

  Goal exists (g : nat -> bool),
      forall (n : nat), φ n <> g. (* 自己参照2 *)
  Proof.
    exists diag.
    move=> n Hc.
    apply: (@Absurd (φ n n = diag n)).
    split.
    - rewrite /diag => H1.
      by case H2 : (φ n n); rewrite H2 in H1.
    - by rewrite Hc.
  Qed.

  (* refine ((_ : φ n n <> diag n) (_ : φ n n = diag n)). *)
  (* absurd (F n n = diag F n). *)
End DIAG.

(* END *)


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import div fintype finset finfun bigop prime zmodp.
From mathcomp Require Import order ssralg ssrnum ssrint rat matrix mxalgebra.

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

Import GRing.Theory.
Local Open Scope nat_scope.

Section extrassr.

Local Open Scope ring_scope.

Lemma mulrIb (V : zmodType) (x : V) : x != 0 ->
   injective (fun b : bool => x *+ b).
Proof. by move=> /negPf x0F [] [] //= /eqP; rewrite ?x0F // eq_sym x0F. Qed.

Lemma inj_row_free (F : fieldType) m n (A : 'M[F]_(m, n)) :
  (forall v : 'rV_m, v *m A = 0 -> v = 0) -> row_free A.
Proof.
move=> Ainj; rewrite -kermx_eq0; apply/eqP/row_matrixP => i.
by rewrite row0; apply/Ainj; rewrite -row_mul mulmx_ker row0.
Qed.

Definition row_free_injr F m n p A : _ -> injective (@mulmxr A) :=
  @row_free_inj F m n p A.

Lemma det_mx11 (R : comRingType) (M : 'M[R]_1) : \det M = M 0 0.
Proof. by rewrite {1}[M]mx11_scalar det_scalar. Qed.

End extrassr.

Section Ext.

Variables (n : nat) (X : finType).
Implicit Types (S : {set X ^ n.+1}) (R : {set X ^ n}).
Implicit Types (s : X ^ n.+1) (r : X ^ n) (x y : X) (m : nat).

(* Extension of s with one element x at the begining *)
Definition ext x r : X ^ n.+1 := [ffun i => oapp r x (unlift 0%R i)].

(* Restriction of b, without the last element, the inverse of ext *)
Definition rem s : X ^ n := [ffun i => s (lift 0%R i)].

(* extension of a set with one element x at the begining. *)
Definition extset x R : {set X ^ n.+1} := [set ext x s | s in R].

(* the set of possible completions of r by x in S *)
Definition compl S r : {set X} := [set x | ext x r \in S].

(* the set of elements with at least m + 1 extensions in S *)
Definition Xi m S : {set X ^ n} := [set r : X ^ n | m < #|compl S r|].

Lemma remK s : ext (s 0%R) (rem s) = s.
Proof.
by apply/ffunP=> i; rewrite ffunE; case: unliftP => [j|] ->; rewrite //= ffunE.
Qed.

Lemma extK x : cancel (ext x) rem.
Proof. by move=> b; apply/ffunP=> i; rewrite !ffunE liftK. Qed.

Lemma ext0 x r : ext x r 0%R = x.
Proof. by rewrite /ext ffunE unlift_none. Qed.

Let extE' := (inE, ext0, extK, remK, eqxx).

Lemma eq_ext x x' (r r' : X ^ n) :
  (ext x r == ext x' r') = (x == x') && (r == r').
Proof.
have [->|] /= := altP (x =P x'); first by rewrite (can_eq (@extK _)).
by apply: contraNF => /eqP/ffunP/(_ 0%R); rewrite !ext0 => ->.
Qed.

Lemma compl0 r : compl set0 r = set0.
Proof. by apply/setP=> i; rewrite !inE. Qed.

Lemma compl_rem_neq0 S s : s \in S -> compl S (rem s) != set0.
Proof.
move=> sS; have : s 0%R \in compl S (rem s) by rewrite !extE'.
by apply: contraTneq => ->; rewrite inE.
Qed.

Lemma ext_in S r x : (ext x r \in S) = (x \in compl S r).
Proof. by rewrite inE. Qed.

Lemma card_extset R x : #|extset x R| = #|R|.
Proof.
by rewrite card_imset // => u v /eqP; rewrite eq_ext => /andP [_ /eqP].
Qed.

Lemma mem_extset x s R : s \in extset x R = (s 0%R == x) && (rem s \in R).
Proof.
apply/imsetP/idP => [[r rS ->]|/andP [/eqP<-] rsS]; first by rewrite !extE'.
by exists (rem s) => //; rewrite !extE'.
Qed.

Lemma mem_extset_r x r R : ext x r \in extset x R = (r \in R).
Proof. by rewrite mem_extset ?extE'. Qed.

Lemma rem_inW S s : s \in S -> rem s \in Xi 0 S.
Proof.
by move=> sS; rewrite inE; apply/card_gt0P; exists (s 0%R); rewrite !extE'.
Qed.

Lemma extset0 x : extset x set0 = set0.
Proof. by rewrite /extset imset0. Qed.

Lemma extsetK x : cancel (extset x) (Xi 0).
Proof.
move=> S; apply/setP => /= s; apply/idP/idP => [|sS]; last first.
  by rewrite -[s](extK x) rem_inW // mem_extset_r.
by rewrite inE => /card_gt0P [y]; rewrite inE mem_extset ?extE' => /andP [].
Qed.

Definition extE := (extE', mem_extset, extsetK, extset0).

Fact ord0_in_compl S s : s \in S -> s 0%R \in compl S (rem s).
Proof. by rewrite !extE'. Qed.

Lemma subset_extset x : {mono extset x : R R' / R \subset R'}.
Proof.
move=> R R'; apply/subsetP/subsetP => RR' /= r.
  by move/(mem_imset (ext x))/RR'; rewrite mem_extset_r.
by case/imsetP=> r' rR ->; rewrite mem_extset_r RR'.
Qed.

Lemma subset_compl r : {homo compl^~ r : S S' / S \subset S'}.
Proof. by move=> ???; apply/subsetP=> x; rewrite !inE; apply/subsetP. Qed.

Lemma subset_Xi m : {homo Xi m : S S' / S \subset S'}.
Proof.
move=> S S' subSS'; apply/subsetP=> s; rewrite !in_set => /leq_trans-> //.
exact/subset_leq_card/subset_compl.
Qed.

Lemma leq_Xi S : {homo Xi^~ S : m p / p <= m >-> m \subset p}.
Proof. by move=> m p ?; apply/subsetP => s; rewrite !inE; apply/leq_trans. Qed.

Lemma Xi0 i : Xi i set0 = set0.
Proof. by apply/setP => e; rewrite !inE compl0 cards0. Qed.

Lemma Xi1_eq0 S : (Xi 0 S == set0) = (S == set0).
Proof.
apply/idP/idP=> [|/eqP->]; last by rewrite Xi0.
apply: contraTT => /set0Pn [x xS].
by apply/set0Pn; exists (rem x); apply: rem_inW.
Qed.

End Ext.

Local Open Scope ring_scope.

Section AbstractSigndet.

Variables (F : fieldType) (k' : nat).
Let k := k'.+1.
Let X := 'I_k.
Variable M : 'M[F]_k.

Definition mat1 (S : {set X}) : 'M[F]_#|S| :=
  \matrix_(i, j) M (enum_val i) (inord j).

Hypothesis row_free_mat1 : forall (S : {set X}), row_free (mat1 S).

Definition mat_coef n (i : X ^ n) (j : X ^ n) := \prod_k M (i k) (j k).

Definition mat n (S : {set X ^ n}) (A : {set X ^ n}) : 'M_(#|S|, #|A|) :=
  \matrix_(i < #|S|, j < #|A|) mat_coef (enum_val i) (enum_val j).

Definition adapted n (S : {set X ^ n}) (A : {set X ^ n}) :=
  (#|A| == #|S|) && row_free (mat S A).

Fixpoint adapt n : {set X ^ n} -> {set X ^ n} :=
  if n isn't _.+1 then id
  else fun S => \bigcup_(i < k) extset i (adapt (Xi i S)).

Arguments adapt n S : simpl never.

Lemma adapt0 (S : {set X^0}) : adapt S = S. Proof. by []. Qed.

Lemma adaptS n (S : {set X ^ n.+1}) :
  adapt S = \bigcup_(i < k) extset i (adapt (Xi i S)).
Proof. by []. Qed.

Lemma adaptn0 n : @adapt n set0 = set0.
Proof.
elim: n => [|n IHn] //=; rewrite (adapt0, adaptS) big1 // => i _.
by rewrite Xi0 // IHn extset0.
Qed.

Lemma adapt_eq0 n S : (@adapt n S == set0) = (S == set0).
Proof.
elim: n => [|n IHn] // in S *.
apply/idP/idP => [/=|/eqP ->]; last by rewrite adaptn0.
apply: contraTT; rewrite -Xi1_eq0 -IHn => /set0Pn [x x_adaX].
apply/set0Pn; exists (ext ord0 x).
by apply/bigcupP; exists 0 => //; rewrite ?extE.
Qed.

Lemma subset_adapt n : {homo @adapt n : S S' / S \subset S'}.
Proof.
elim: n => [//|n IHn] S S' subSS' /=; apply/bigcupsP => i _.
by rewrite (bigcup_max i) // subset_extset IHn // subset_Xi.
Qed.

Lemma in_adapt n (S : {set X ^ n.+1}) (a : X ^ n.+1) :
  (a \in adapt S) = (rem a \in adapt (Xi (a 0) S)).
Proof.
move=> /=; apply/bigcupP/idP => [[i _ /imsetP [s sAXi ->]]|].
  by rewrite ?extE.
by move=> ra; exists (a 0); rewrite ?extE.
Qed.

Lemma adapt_down_closed  n (S : {set X ^ n}) (a b : X ^ n) :
  (forall i, b i <= a i)%N -> a \in adapt S -> b \in adapt S.
Proof.
elim: n => [|/= n IHn] in S a b *.
  by move=> _; rewrite (fintype_le1P _ b)// card_ffun !card_ord.
move=> leq_ba; rewrite !in_adapt => raAXi.
have: rem b \in adapt (Xi (a 0) S).
  by apply: IHn raAXi => i; rewrite !ffunE leq_ba.
by apply: subsetP; rewrite subset_adapt ?leq_Xi ?ltnS ?leq_ba.
Qed.

Lemma mat_coefS n (s : X ^ n.+1) (a : X ^ n.+1) :
  mat_coef s a = M (s 0) (a 0) * mat_coef (rem s) (rem a).
Proof.
rewrite [LHS]big_ord_recl; congr (_ * _).
by apply: eq_bigr => i _; rewrite !ffunE.
Qed.

Theorem mat_adapt_free n (S : {set X ^ n}) : row_free (mat S (adapt S)).
Proof.
elim: n => [|n IHn] in S *.
  apply/row_freeP; exists 1%:M; apply/matrixP=> i j.
  rewrite ?mulmx1 !mxE /mat_coef big_ord0.
  have := subset_leq_card (subsetT S); rewrite ?cardsT card_ffun !card_ord.
  by case: #|S| i j; do ![case=> //|move=>?].
have [->|SN0] := eqVneq S set0.
  move: (mat _ _); rewrite adaptn0 cards0 => A.
  by rewrite row_free_unit unitmxE det_mx00 unitr1.
have /set0Pn [/= s s_in] := SN0.
have /set0Pn [/= a a_in] : adapt S != set0 by rewrite adapt_eq0.
apply/inj_row_free => L LN0.
apply/rowP => j; rewrite mxE -(enum_valK_in s_in j).
move: (enum_val j) (enum_valP j) => /= t t_in {j}.
pose l t := L 0 (enum_rank_in s_in t); rewrite /= in l; rewrite -/(l _).
have [r] := ubnPleq #|compl S (rem t)|; elim: r => [|r IHr] in t t_in *.
  by rewrite leqn0 cards_eq0 (negPf (compl_rem_neq0 _)).
rewrite leq_eqVlt => /predU1P [extrt|]; last exact: IHr.
suff: \row_(j < #|compl S (rem t)|) l (ext (enum_val j) (rem t)) == 0.
  move=> /eqP /rowP /(_ (enum_rank_in (ord0_in_compl t_in) (t 0))).
  by rewrite !mxE ?enum_rankK_in ?ord0_in_compl ?extE.
have /(@row_free_injr _ 1)/raddf_eq0<- := row_free_mat1 (compl S (rem t)).
apply/eqP/rowP => /= j; rewrite !mxE; under eq_bigr do rewrite !mxE.
rewrite (big_enum_rank (ord0_in_compl t_in)) /=.
under eq_bigr => x do [rewrite extE => x_in; rewrite ?(extE, enum_rankK_in)//].
pose G i u := (\sum_(x in compl S u) l (ext x u) * M x i); rewrite -/(G _ _).
have rt : rem t \in Xi r S by rewrite inE extrt.
suff /eqP/rowP : \row_(p < #|Xi r S|) G (inord j) (enum_val p) == 0.
  by move=> /(_ (enum_rank_in rt (rem t))); rewrite !mxE ?enum_rankK_in.
have /(@row_free_injr _ 1)/raddf_eq0 /= <- := IHn (Xi r S).
apply/eqP/rowP => m; rewrite !mxE (big_enum_rank rt) /=.
under eq_bigr => x x_in do rewrite !mxE ?enum_rankK_in //= mulr_suml.
set f := BIG_F; transitivity (\sum_(i in Xi 0 S) f i).
  symmetry; rewrite (big_setID (Xi r S)) /= (setIidPr _) ?leq_Xi //.
  rewrite [X in (_ + X)]big1 ?addr0 // => u.
  rewrite !inE -leqNgt => /andP [u_small _].
  by rewrite /f big1 // => x; rewrite inE => ?; rewrite IHr ?mul0r //= extK.
rewrite pair_big_dep/= (reindex (fun a => (rem a, a 0))) /=; last first.
  by exists (fun p => ext p.2 p.1) => [x|[//? ?]]; rewrite !inE !extE.
have /matrixP/(_ 0 (enum_rank_in a_in (ext (inord j) (enum_val m)))) := LN0.
rewrite !mxE (big_enum_rank s_in) /= => LN0_eq0.
rewrite -[RHS]LN0_eq0; symmetry; apply: eq_big => [u|u uS].
  rewrite [_ \in compl _ _]inE remK andbC.
  by have [/rem_inW|//] := boolP (u \in S).
rewrite !mxE ?extE ?enum_rankK_in /l ?mat_coefS ?extE ?mulrA // ext_in.
move: (enum_val m) (enum_valP m) => /= b b_in; rewrite inE in_adapt ?extE.
apply: subsetP b_in; rewrite subset_adapt // leq_Xi // -ltnS inordK -?extrt //.
by rewrite (leq_trans (leq_trans (ltn_ord _) (max_card _))) ?card_ord.
Qed.

Lemma card_adapt n (S : {set X ^ n}) : #|adapt S| = #|S|.
Proof.
apply/eqP; rewrite eqn_leq andbC; have := mat_adapt_free S.
rewrite -row_leq_rank => /leq_trans->/=; last by rewrite rank_leq_col.
elim: n => // n IHn in S *; rewrite adaptS /=.
rewrite (@leq_trans (\sum_(i < k) #|Xi i S|))//=.
  elim/big_rec2: _; rewrite ?cards0// => i m A _ A_le.
  by rewrite cardsU (leq_trans (leq_subr _ _))// card_extset leq_add.
under eq_bigr do rewrite -sum1dep_card big_mkcond/=; rewrite exchange_big /=.
rewrite (eq_bigr (fun r => \sum_x (ext x r \in S))%N) => [|r]; last first.
  rewrite -big_mkcond/= big_ord_narrow 1?(leq_trans (max_card _)) ?card_ord//.
  by rewrite sum1_card card_ord -sum1dep_card big_mkcond.
rewrite exchange_big pair_big -big_mkcond/=.
rewrite -(@reindex _ _ _ _ _ (fun p => ext p.1 p.2) _ (fun=> _)) ?sum1_card//.
by exists (fun s : X ^ _ => (s 0, rem s)) => [[? ?]|x]; rewrite ?extE.
Qed.

Lemma adapt_adapted n (S : {set X ^ n}) : adapted S (adapt S).
Proof. by rewrite /adapted mat_adapt_free card_adapt eqxx. Qed.

Proposition prop_10_84 n (S : {set X ^ n}) (a : X ^ n) : a \in adapt S ->
  (#|[set i | a i != 0%R]| <= trunc_log 2 #|S|)%N.
Proof.
pose I (a : X ^ n) : {set 'I_n} := [set i | a i != 0]; rewrite -/(I _).
move=> a_adapt; apply: trunc_log_max => //.
pose nullify (B : {set 'I_n}) : X ^ n := [ffun i => a i *+ (i \in B)].
suff -> : (2 ^ #|I a| = #|nullify @: powerset (I a)|)%N.
  rewrite -[#|S|]card_adapt subset_leq_card //; apply/subsetP => b.
  move=> /imsetP [/= J]; rewrite inE => /subsetP JsubI -> {b}.
  by apply: adapt_down_closed a_adapt => /= i; rewrite ffunE; case: (_ \in _).
rewrite card_in_imset ?card_powerset // => J1 J2.
rewrite !inE => /subsetP J1a /subsetP J2a eqJ; apply/setP => i.
have [iI|/norP [/negPf-> /negPf->] //] := boolP ((i \in J1) || (i \in J2)).
have /mulrIb : a i != 0 by move: iI => /orP [/J1a|/J2a]; rewrite inE.
by apply; have /ffunP/(_ i) := eqJ; rewrite !ffunE.
Qed.

End AbstractSigndet.

Section Signdet3.

Implicit Type (k : 'I_3).

Definition sign k : rat := if (k >= 2)%N then -1 else k%:Q.
Definition ctmat3   := \matrix_(i < 3, j < 3) sign i ^ j.
Definition ctmat2 k := \matrix_(i < 2, j < 2) sign (lift k i) ^ j.

Lemma det_ctmat2 k : \det (ctmat2 k) =
  if (k <= 0)%N then - 2%:Q else if (k > 1)%N then 1 else -1.
Proof.
by case: k => [[|[|[|?]]] ?] //=;
   rewrite (expand_det_col _ 0) !big_ord_recl big_ord0;
   rewrite /cofactor ?det_mx11 !mxE /sign //=;
   rewrite ?(mul0r, expr0, expr1, mul1r, addr0, add0r).
Qed.

Lemma det_ctmat3 : \det ctmat3 = 2%:Q.
Proof.
rewrite (expand_det_col _ ord_max).
transitivity (\sum_i ctmat3 i ord_max * ((-1) ^+ i * \det (ctmat2 i)));
  last by rewrite !big_ord_recl big_ord0 !mxE !det_ctmat2.
apply: eq_bigr => i _; congr (_ * (_ *  _)); last congr (\det _).
  by rewrite -signr_odd odd_add addbF signr_odd.
by apply/matrixP => /= k l; rewrite !mxE //=; case: l => [[|[|?]] ?].
Qed.

Lemma row_free_ctmat (S : {set 'I_3}) : row_free (mat1 ctmat3 S).
Proof.
pose M S := \matrix_(i < #|S|, j < #|S|) sign (enum_val i) ^+ j.
have := subset_leq_card (subsetT S); rewrite cardsT card_ord => cardS.
have -> : mat1 ctmat3 S = M _.
  apply/matrixP => i j; rewrite !mxE inordK -?enum_val_nth //.
  by rewrite (leq_trans (ltn_ord _)).
move: cardS; have enumI3E : enum 'I_3 = [seq inord i | i <- iota 0 3].
  apply: (@eq_from_nth _ 0).
    by rewrite -cardE card_ord size_map size_iota.
  move=> i; rewrite -cardE card_ord => i_small.
  rewrite -{1}[i](@inordK 2) // nth_ord_enum (nth_map 0%N) //=.
  by case: i i_small => [|[|[|?]]].
do 3?[rewrite leq_eqVlt orbC => /orP []; rewrite ?ltnS ?leqn0].
- rewrite cards_eq0 => /eqP ->; rewrite row_free_unit unitmxE.
  by move: (M _); rewrite cards0 => M'; rewrite det_mx00.
- move=> /cards1P [/= x ->].
  suff -> : M [set x] = 1%:M by apply/inj_row_free => v; rewrite mulmx1.
  apply/matrixP => i j; rewrite !mxE.
  have := enum_valP i; rewrite inE => /eqP ->.
  by move: i j => /=; rewrite cards1 => i j; rewrite !ord1 expr0 eqxx.
- move=> /eqP S2; have /cards1P [x /(congr1 (@setC _))] : #|~: S| == 1%N.
    by rewrite cardsCs card_ord setCK S2.
  rewrite setCK => S_def; rewrite S_def in S2 *.
  rewrite row_free_unit unitmxE unitfE.
  suff: M [set~ x] = castmx (esym S2, esym S2) (ctmat2 x).
    case: _ / (esym S2) (M _) => A ->; rewrite castmx_id.
    by rewrite det_ctmat2 {S_def S2}; case: x => [[|[|?]] ?].
  apply/matrixP=> i j; rewrite !(mxE, castmxE) ?esymK /=; congr (sign _ ^+ _).
  apply/val_inj; rewrite /enum_val /=; move: i (enum_default _); rewrite S2.
  rewrite /enum_val -filter_index_enum /index_enum -enumT enumI3E /=.
  rewrite /= !topredE !inE -!val_eqE /= !inordK //=.
  by case: x {j S2 S_def} => [[|[|[|?]]] ?] [[|[|?]] ?] /=; rewrite ?inordK.
- move=> /eqP S3; have /= S_def : S = setT.
    by apply/eqP; rewrite eqEcard ?subsetT ?cardsT ?card_ord S3.
  rewrite row_free_unit unitmxE unitfE; rewrite S_def in S3 *.
  suff: M setT = castmx (esym S3, esym S3) ctmat3.
    by case: _ / (esym S3) (M _) => A ->; rewrite castmx_id det_ctmat3.
  apply/matrixP => i j; rewrite !(mxE, castmxE) ?esymK /=.
  congr (sign _ ^+ _); apply/val_inj => /=.
  rewrite /enum_val enum_setT -enumT /= enumI3E /=.
  have : (i < 3)%N by rewrite (leq_trans (ltn_ord i)) ?cardsT ?card_ord.
  by case: (val i) => [|[|[|?]]]; rewrite ?inordK //=.
Qed.

Theorem ctmat_adapted n (S : {set 'I_3 ^ n}) : adapted ctmat3 S (adapt S).
Proof. exact/adapt_adapted/row_free_ctmat. Qed.

End Signdet3.


Require Import FunctionalExtensionality Eqdep_dec ProofIrrelevance JMeq.
Require Export DiscreteCategoryFunctors DecidableDiscreteCategory DecidableSetCategory DecidableComputableCategory DecidableSmallCat.
Require Import Common Adjoint.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section eq_dec_prop.
  Lemma eq_dec_prop T (eq_dec : forall x y : T, {x = y} + {x <> y}) : forall x y : T, x = y \/ x <> y.
    intros x y; case (eq_dec x y); intuition.
  Qed.
End eq_dec_prop.

Section Obj.
  Local Ltac build_ob_functor Index2Object :=
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (fun C' => existT _ (Index2Object (projT1 C')) (projT2 C'))
          (fun _ _ F => ObjectOf F)
          _
          _
        )
    end;
    intros; simpl in *; reflexivity.

  Section type.
    Variable I : Type.
    Variable Index2Object : I -> Type.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition ObjectFunctorDec : SpecializedFunctor (@ComputableCategoryDec _ _ Index2Cat) TypeCatDec.
      build_ob_functor Index2Object.
    Defined.
  End type.

  Section set.
    Variable I : Type.
    Variable Index2Object : I -> Set.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition ObjectFunctorToSetDec : SpecializedFunctor (@ComputableCategoryDec _ _ Index2Cat) SetCatDec.
      build_ob_functor Index2Object.
    Defined.
  End set.

  Section prop.
    Variable I : Type.
    Variable Index2Object : I -> Prop.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition ObjectFunctorToPropDec : SpecializedFunctor (@ComputableCategoryDec _ _ Index2Cat) PropCatDec.
      build_ob_functor Index2Object.
    Defined.
  End prop.
End Obj.

Arguments ObjectFunctorDec {I Index2Object Index2Cat}.
Arguments ObjectFunctorToSetDec {I Index2Object Index2Cat}.
Arguments ObjectFunctorToPropDec {I Index2Object Index2Cat}.

Section InducedFunctor.
  Variable O : Type.
  Context `(O' : @SpecializedCategory obj).
  Variable f : O -> O'.
  Variable eq_dec : forall x y : O, {x = y} + {x <> y}.

  Hint Unfold Object.

  Local Ltac t' := intros; simpl in *; autounfold with core in *; repeat subst; trivial.
  Local Ltac t := t';
    repeat match goal with
             | _ => reflexivity
             | _ => apply Identity; assumption
             | [ H : appcontext[eq_dec ?a ?b] |- _ ] => destruct (eq_dec a b); t'
             | [ |- appcontext[eq_dec ?a ?b] ] => destruct (eq_dec a b); t'
             | [ H : _ |- _ ] => specialize (H (eq_refl _)); t'
             | [ H : False |- _ ] => destruct H
             | [ H : Empty_set |- _ ] => destruct H
             | [ H : unit |- _ ] => destruct H
             | [ |- _ = _ ] => progress (repeat rewrite RightIdentity; repeat rewrite LeftIdentity; repeat rewrite Associativity)
             | [ H : ?a = ?a |- _ ] => pose proof (UIP_refl _ _ H); subst H
             | [ H : _ |- _ ] => unique_pose (H eq_refl)
             | [ H : Morphism _ _ _ |- _ ] => hnf in H
             | [ H : _ = _ |- _ ] => case H; try clear H
           end.

  Definition InducedDiscreteFunctorDec_MorphismOf s d (m : Morphism (DiscreteCategoryDec eq_dec) s d) :
    Morphism O' (f s) (f d).
    t.
  Defined.

  Hint Unfold InducedDiscreteFunctorDec_MorphismOf.
  Hint Unfold DiscreteCategoryDec_Compose.
  Hint Unfold eq_rect_r eq_rect eq_sym.

  Local Arguments Compose {obj} [C s d d'] / _ _ : rename, simpl nomatch.

  Definition InducedDiscreteFunctorDec : SpecializedFunctor (DiscreteCategoryDec eq_dec) O'.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          f
          InducedDiscreteFunctorDec_MorphismOf
          _
          _
        )
    end;
    t.
  Defined.
End InducedFunctor.

Local Ltac destruct_eq_dec eq_dec a b :=
  match type of eq_dec with
    | forall x y : _, {x = y} + {x <> y} => destruct (eq_dec a b)
    | forall x y : _, {x = y} + {x = y -> False} => destruct (eq_dec a b)
  end;
  repeat subst; trivial; intros.

Local Ltac t_dec := repeat (intros; simpl in *; autounfold with core in *; simpl in *; trivial;
  match goal with
    | [ |- _ = _ ] => apply functional_extensionality_dep; intro
    | _ => progress functor_eq
    | [ H0 : appcontext[?H ?a ?b] |- _ ] => revert H0; destruct_eq_dec H a b
    | [ |- appcontext[?H ?a ?b] ] => destruct_eq_dec H a b
    | _ => progress (unfold Morphism, Object, InducedDiscreteFunctorDec_MorphismOf in *)
    | _ => progress destruct_sig
    | [ H : unit |- _ ] => destruct H
    | [ H : ?a = ?a, eq_dec : _ |- _ ] => pose proof (eq_proofs_unicity (eq_dec_prop eq_dec) H eq_refl); subst H
    | [ H : _ |- _ ] => unique_pose (H eq_refl)
    | _ => progress destruct_to_empty_set
    | [ H0 : appcontext[?H ?a ?b] |- appcontext[?H ?a ?b] ] => revert H0; destruct_eq_dec H a b
    | [ H : ?a = ?b |- _ ] => pose proof H; first [ subst a | subst b ]
  end
).

Section disc.
  Hint Unfold DiscreteCategoryDec_Identity.
  Hint Unfold eq_rect_r eq_rect eq_sym.

  Definition DiscreteFunctorDec : SpecializedFunctor TypeCatDec LocallySmallCatDec.
    refine (Build_SpecializedFunctor TypeCatDec LocallySmallCatDec
      (fun O => existT
        (fun C : LocallySmallCategory => forall x y : C, {x = y} + {x <> y})
        (DiscreteCategoryDec (projT2 O) : LocallySmallSpecializedCategory _)
        (fun x y => projT2 O x y))
      (fun s d f => InducedDiscreteFunctorDec _ f (projT2 s))
      _
      _
    );
    t_dec.
    match goal with
      | [ H : if ?eq_dec ?a ?b then unit else Empty_set |- _ ] => cut (JMeq H tt); [ intro | destruct_eq_dec eq_dec a b ]
    end.
    apply JMeq_eq.
    symmetry.
    (*
    Require Import Setoid.
    etransitivity; [ apply H | clear H ].
    compute.
    assert (JMeq match
                s x0 x0 as s0 return (if s0 then unit else Empty_set)
              with
              | left _ => tt
              | right n => match n eq_refl return Empty_set with
                           end
              end tt).
    destruct (s x0 x0); trivial.
    change ((match
        s x x0 as s0
        return
          ((if s0 then unit else Empty_set) ->
           if s x x0 then unit else Empty_set)
      with
      | left e =>
          fun _ : unit =>
          match
            match e in (_ = y) return (y = x) with
            | eq_refl => eq_refl
            end in (_ = y) return (if s y x0 then unit else Empty_set)
          with
          | eq_refl =>
              match
                s x0 x0 as s0 return (if s0 then unit else Empty_set)
              with
              | left _ => tt
              | right n => match n eq_refl return Empty_set with
                           end
              end
          end
      | right _ =>
          fun m : Empty_set =>
          match m return (if s x x0 then unit else Empty_set) with
          end
      end x1)) with ((match
        s x x0 as s0
        return
          ((if s0 then unit else Empty_set) ->
           if s x x0 then unit else Empty_set)
      with
      | left e =>
          fun _ : unit =>
          match
            match e in (_ = y) return (y = x) with
            | eq_refl => eq_refl
            end in (_ = y) return (if s y x0 then unit else Empty_set)
          with
          | eq_refl =>
              match
                s x0 x0 as s0 return (if s0 then unit else Empty_set)
              with
              | left _ => tt
              | right n => match n eq_refl return Empty_set with
                           end
              end
          end
      | right _ =>
          fun m : Empty_set =>
          match m return (if s x x0 then unit else Empty_set) with
          end
       end x1)). *)
    admit.
  Defined.

  Definition DiscreteSetFunctorDec : SpecializedFunctor SetCatDec SmallCatDec.
    refine (Build_SpecializedFunctor SetCatDec SmallCatDec
      (fun O => existT
        (fun C : SmallCategory => forall x y : C, {x = y} + {x <> y})
        (DiscreteCategoryDec (projT2 O) : SmallSpecializedCategory _)
        (fun x y => projT2 O x y))
      (fun s d f => InducedDiscreteFunctorDec _ f (projT2 s))
      _
      _
    );
    admit.
  Defined.
End disc.

Section Adjoints.
  Local Ltac t :=
    repeat match goal with
             | _ => progress trivial
             | _ => progress repeat (apply functional_extensionality_dep; intro)
             | _ => hnf in *;
               match goal with
                 | [ H : _ = _ |- _ ] => destruct H; simpl in *
               end
             | _ => rewrite FIdentityOf
             | _ => progress functor_eq
           end.

  Lemma DiscreteObjectIdentityDec : ComposeFunctors ObjectFunctorDec DiscreteFunctorDec = IdentityFunctor _.
    functor_eq; simpl_eq; reflexivity.
  Qed.

  Definition DiscreteObjectAdjunction : HomAdjunction DiscreteFunctorDec ObjectFunctorDec.
    match goal with
      | [ |- HomAdjunction ?F ?G ] =>
        refine (Build_HomAdjunction F G
          (fun _ _ F => (fun x => F x))
          _
          _
        )
    end;
    try abstract trivial;
      simpl; intros.
    exists (fun f => (InducedDiscreteFunctorDec _ f (projT2 A)));
      t.
    admit.
  Defined.
End Adjoints.


Require Import
  CMorphisms
  Types.Setoid
  Algebra.Category.

Set Universe Polymorphism.

Local Open Scope obj.
Local Open Scope morph.
Local Open Scope setoid.

Class Cartesian {U : Category} : Type :=
  { unit : U
  ; BProd : U -> U -> U
  ; unit_Is_Terminal : Is_Terminal_Object unit
  ; BProd_Is_Binary_Product :
     forall A B, Is_Binary_Product A B (BProd A B)
  }.

Arguments Cartesian : clear implicits.

Infix "*" := BProd : obj_scope.

Section CartesianOps.
Context {U} {CU : Cartesian U}.

Definition tt {Γ} : Γ ~~> unit.
Proof.
pose proof (Product_least (unit_Is_Terminal)).
specialize (X Γ (Empty_set_rect _)).
apply X.
Defined.

Definition fst {A B} : A * B ~~> A
  := (Product_proj (BProd_Is_Binary_Product A B) true).

Definition snd {A B} : A * B ~~> B
  := (Product_proj (BProd_Is_Binary_Product A B) false).

Definition pair {Γ A B : U} (f : Γ ~~> A) (g : Γ ~~> B)
  : Γ ~~> A * B.
Proof.
pose proof (Product_least
  (BProd_Is_Binary_Product A B) Γ).
simpl in X.
specialize (X (fun b : bool => match b as b' return
   Γ ~~> (if b' then A else B) with
  | true => f
  | false => g
  end)).
simpl in X.
apply X.
Defined.

Global Instance pair_Proper {Γ A B : U}
 : Proper (seq _ ==> seq _ ==> seq _)%signature
     (@pair Γ A B).
Proof.
Admitted.

End CartesianOps.

Notation "⟨ f , g ⟩" := (pair f g) : morph_scope.

Section MoreCartesianOps.
Context {U} {CU : Cartesian U}.

Lemma pair_fst : forall {A B C} (f : A ~~> B) (g : A ~~> C), fst ∘ ⟨f, g⟩ == f.
Proof.
Admitted.

Lemma pair_snd : forall {A B C} (f : A ~~> B) (g : A ~~> C), snd ∘ ⟨f, g⟩ == g.
Proof.
Admitted.

Lemma unit_uniq : forall {A} (h k : A ~~> unit), h == k.
Proof.
Admitted.

Definition parallel {A B C D : U}
  (f : A ~~> B) (g : C ~~> D) : A * C ~~> B * D :=
  ⟨ f ∘ fst , g ∘ snd ⟩.

Local Infix "⊗" := parallel (at level 25) : morph_scope.

Definition add_unit_left {A : U} : A ~~> unit * A
  := ⟨tt, id⟩.

Definition add_unit_right {A : U} : A ~~> A * unit
  := ⟨id, tt⟩.

Definition prod_assoc_left {A B C : U}
  : A * (B * C) ~~> (A * B) * C :=
  ⟨id ⊗ fst, snd ∘ snd⟩.

Definition prod_assoc_right {A B C : U}
  : (A * B) * C ~~> A * (B * C) :=
  ⟨fst ∘ fst, snd ⊗ id⟩.

Lemma pair_uniq : forall {A B C} (h : A ~~> B * C), h == ⟨fst ∘ h, snd ∘ h⟩.
Proof.
Admitted.

Theorem proj_eq : forall {A B C : U} {f f' : A ~~> B * C},
      (fst ∘ f) == (fst ∘ f') -> (snd ∘ f == snd ∘ f') -> f == f'.
Proof.
intros A B C f f' Hfst Hsnd.
rewrite (pair_uniq f). rewrite (pair_uniq f').
rewrite Hfst, Hsnd. reflexivity.
Defined.

Lemma pair_f : forall {A B C D : U} (f : A ~~> B) (h : B ~~> C) (k : B ~~> D),
  ⟨h, k⟩ ∘ f == ⟨h ∘ f, k ∘ f⟩.
Proof.
intros A B C D f h k. apply proj_eq.
- rewrite pair_fst, compose_assoc, pair_fst. reflexivity.
- rewrite pair_snd, compose_assoc, pair_snd. reflexivity.
Defined.

Lemma parallel_compose {A B C A' B' C'}
      (f' : A ~~> B) (f : B ~~> C) (g' : A' ~~> B') (g : B' ~~> C') :
  f ⊗ g ∘ f' ⊗ g' == (f ∘ f') ⊗ (g ∘ g').
Proof.
unfold parallel. rewrite pair_f.
apply pair_Proper; rewrite <- !compose_assoc;
  (apply compose_Proper; [ reflexivity |]).
rewrite pair_fst. reflexivity.
rewrite pair_snd. reflexivity.
Qed.

Theorem unit_isom_left : forall {A : U}, (unit * A) ≅ A.
Proof.
intros A. unshelve eapply
                   (Build_Iso (unit * A) A snd ⟨tt, id⟩ _ _).
- rewrite pair_snd. reflexivity.
- apply proj_eq.
  + apply unit_uniq.
  + rewrite compose_id_right. rewrite compose_assoc.
    rewrite pair_snd. rewrite compose_id_left.
    reflexivity.
Defined.

Theorem unit_isom_right : forall {A : U}, (A * unit) ≅ A.
Proof.
intros A. unshelve eapply
                   (Build_Iso (A * unit) A fst ⟨id, tt⟩ _ _).
- rewrite pair_fst. reflexivity.
- apply proj_eq.
  + rewrite compose_id_right. rewrite compose_assoc.
    rewrite pair_fst. rewrite compose_id_left.
    reflexivity.
  + apply unit_uniq.
Defined.

Lemma pair_id {A B : U} :
  ⟨ fst, snd ⟩ == id (A := A * B).
Proof.
rewrite (pair_uniq id).
rewrite !compose_id_right. reflexivity.
Qed.

Lemma parallel_pair : forall {A B C D E : U} (f : A ~~> B) (g : A ~~> C) (h : B ~~> D) (k : C ~~> E), (h ⊗ k) ∘ ⟨f, g⟩ == ⟨h ∘ f, k ∘ g⟩.
Proof.
intros A B C D E f g h k.
unfold parallel. apply proj_eq.
- rewrite compose_assoc. rewrite pair_fst, pair_fst.
  rewrite <- compose_assoc. rewrite pair_fst. reflexivity.
- rewrite compose_assoc. rewrite pair_snd, pair_snd.
  rewrite <- compose_assoc. rewrite pair_snd. reflexivity.
Defined.

Lemma parallel_fst : forall {A B C D : U} (f : A ~~> B) (g : C ~~> D),
  fst ∘ (f ⊗ g) == f ∘ fst. (* Have I already proven this somewhere else maybe? *)
Proof.
intros A B C D f g.
unfold parallel.
rewrite pair_fst.
reflexivity.
Qed.

Lemma parallel_snd : forall {A B C D : U} (f : A ~~> B) (g : C ~~> D),
  snd ∘ (f ⊗ g) == g ∘ snd.
Proof.
intros A B C D f g.
unfold parallel.
rewrite pair_snd.
reflexivity.
Qed.

Lemma parallel_id A B
  : id (A := A) ⊗ id (A := B) == id.
Proof.
unfold parallel.  rewrite !compose_id_left.
apply pair_id.
Qed.

Theorem parallel_proper : forall {A B C D} (f f' : A ~~> B) (g g' : C ~~> D),
  f == f' -> g == g' -> parallel f g == parallel f' g'.
Proof.
intros A B C D f f' g g' ff' gg'.
unfold parallel. rewrite ff', gg'. reflexivity.
Qed.

Definition diagonal {A : U} : A ~~> A * A := ⟨ id , id ⟩.
Definition swap {A B : U} : A * B ~~> B * A := ⟨snd, fst⟩.

Global Instance parallel_Proper : forall A B C D : U,
  Proper (seq (A ~~> B) ==> seq (C ~~> D) ==> seq _) parallel.
Proof.
intros. unfold Proper, respectful.
intros. apply parallel_proper; assumption.
Qed.

Lemma Iso_Prod {A B A' B'} (a : A ≅ A') (b : B ≅ B')
  : A * B ≅ A' * B'.
Proof.
refine (
    {| to := to a ⊗ to b
       ; from := from a ⊗ from b
    |}
  ); rewrite parallel_compose.
rewrite !to_from. apply parallel_id.
rewrite !from_to. apply parallel_id.
Defined.

End MoreCartesianOps.

Infix "⊗" := parallel (at level 25) : morph_scope.


(* scratch.v  *)
Require Import ssreflect ssrbool.
From mathcomp Require Import ssrnat eqtype seq.

(* tids Implemented from scratch *)

Inductive tid : Type :=
  | enil : tid
  | eC : tid -> tid
  | eP : tid -> tid.

Inductive evol : tid -> tid -> Prop :=
 | er : forall j k, j = k ->  evol j k
 | ep : forall j k, evol j k -> evol j (eP k).

(* We need to reason about suffixes in order to prove the transitivity
of congruence, and to proof left inversion lemmas *)

Fixpoint allP (e : tid) : Prop :=
  match e with
    | enil => True
    | eC x => False
    | eP x => allP x
  end.

Lemma allp_ep: forall e, allP e -> allP (eP e).
Proof. by []. Qed.

Lemma evol_enil: forall e, evol e enil <-> e = enil.
Proof.
split=>//[H|->]; last by constructor.
by inversion H; rewrite H0.
Qed.

Lemma evol_nile: forall e, allP e <-> evol enil e.
Proof.
split; first by elim: e=>//[_| e IH /IH /ep]//; constructor.
elim: e=>//= e IH H; first by inversion H; discriminate H0.
inversion H; first by discriminate H0.
by apply: IH.
Qed.

Lemma evol_ec: forall e e1, evol e (eC e1) <-> e = eC e1.
Proof.
split=>//[H|->]; last by constructor.
by inversion H; rewrite H0.
Qed.

Lemma evol_ep: forall e e1, evol e (eP e1) <-> e = eP e1 \/ evol e e1.
Proof.
split;last by case=>[->|/ep//]; constructor.
move=> H; inversion H; first (by left); by right.
Qed.

Lemma evol_epW i j: evol (eP i) j -> evol i j.
Proof.
move=> H2; elim: j H2=>[|e IH| e IH]H2; inversion H2; try (by discriminate H).
+ by rewrite -H; apply: ep; constructor.
by apply: ep; apply: IH.
Qed.

Lemma evol_epS i j: evol (eP i) j -> evol i (eP j).
Proof. by move/evol_epW/ep. Qed.

Lemma e_refl: forall e, evol e e.
Proof. by move=> H //; constructor. Qed.

Lemma e_trans: forall i j k, evol i j -> evol j k -> evol i k.
Proof.
move=>i j; elim:j i=>//=[i k|j IH i k|j IH i k]//;first by move/evol_enil=>->.
+ by move/evol_ec=>->.
by move/evol_ep=>[->//|H H3]; apply:(@IH _ _ H); apply: evol_epW.
Qed.

Lemma e_anti: forall i j, evol i j -> evol j i -> i = j.
Proof.
elim=>//=[j H|i IH j H|i IH j]//; first by move/evol_enil=>->.
+ by move/evol_ec=>->.
move=> H; inversion H; first by rewrite H0.
move=> H3; inversion H3; first by rewrite H4.
by rewrite (IH _  (evol_epW _ _ H0) (evol_epW _ _ H6)).
Qed.

Fixpoint tidcat (t1 t2: tid) : tid :=
  match t2 with
      | enil => t1
      | eC t => eC (tidcat t1 t)
      | eP t => eP (tidcat t1 t)
  end.

Lemma tidcate0 t: tidcat t enil = t.
Proof. by done. Qed.

Lemma tidcat0e t: tidcat enil t = t.
Proof. by elim: t=>//= t ->. Qed.

Lemma tidcatec t0 t1: tidcat t0 (eC t1) = eC (tidcat t0 t1).
Proof. by done. Qed.

Lemma tidcatep t0 t1: tidcat t0 (eP t1) = eP (tidcat t0 t1).
Proof. by done. Qed.

Lemma tidcatce t0 t1: tidcat (eC t0) t1 = tidcat t0 (tidcat (eC enil) t1).
Proof.
elim: t1 t0=>//t1 IH t0.
+ by rewrite [in y in _=y]tidcatec [in y in _=y]IH tidcat0e !tidcatec IH.
+ by rewrite [in y in _=y]tidcatep [in y in _=y]IH tidcat0e !tidcatep IH.
Qed.

Lemma tidcatpe t0 t1: tidcat (eP t0) t1 = tidcat t0 (tidcat (eP enil) t1).
Proof.
elim: t1 t0=>//t1 IH t0.
+ by rewrite [in y in _=y]tidcatec [in y in _=y]IH tidcat0e !tidcatec IH.
+ by rewrite [in y in _=y]tidcatep [in y in _=y]IH tidcat0e !tidcatep IH.
Qed.

Lemma tidcatA t0 t1 t2 : tidcat t0 (tidcat t1 t2) = tidcat (tidcat t0 t1) t2.
Proof.
elim: t1 t0 t2=>//[|e IH|e IH]t0 t2; first by rewrite tidcate0 tidcat0e.
+ by rewrite tidcatec tidcatce [in y in _=y]tidcatce IH.
+ by rewrite tidcatep tidcatpe [in y in _=y]tidcatpe IH.
Qed.

Lemma evol_tidcatS i k: allP k -> evol i (tidcat i k).
Proof.
elim: k=>//=[_|e IH E]; first by constructor.
by apply: ep; apply:IH.
Qed.

Lemma evol_allP i j: evol i j <-> exists k, allP k /\ j = tidcat i k.
Proof.
split=>[|[k][H]->]; last by apply evol_tidcatS.
elim: j=>/=[|e _|e IH].
- by move/evol_enil=>->; exists enil; rewrite tidcate0 //.
+ by move/evol_ec=>->; exists enil; rewrite tidcate0 //.
move/evol_ep=>[->|/IH[k][H]->]; first by exists enil; rewrite tidcate0 //.
by exists (eP k); rewrite /=.
Qed.

Lemma evol_tidcatR i j k: evol i j -> allP k -> evol (tidcat i k) (tidcat j k).
Proof.
elim: j i k=>//= [|t IH|t IH] i k; first by move/evol_enil=>->; constructor.
+ by move/evol_ec=>->; constructor.
move/evol_ep=>[->|H H1]; first by constructor.
move:(@IH _ _ H H1)=>/ep; rewrite -tidcatep tidcatpe.
suff: (eP k) = tidcat (eP enil) k by  move=><-.
by elim: k {IH H} H1=>//= k IH /IH ->.
Qed.

(* from this side, reasoning in terms of suffixes is better *)
Lemma evol_tidcatL i j k: evol j k -> evol (tidcat i j) (tidcat i k).
Proof.
by move/evol_allP=>[x][H]->; rewrite evol_allP; exists x; rewrite tidcatA //.
Qed.

(* We do a symmetric closure of evol, to generate a new equality of
 tids modulo evolution *)
(* Equivalence *)

Definition eqq (i j : tid) : Prop := evol i j \/ evol j i.

Lemma allp_eqq j k: allP j -> allP k -> eqq k j.
Proof.
elim: j k=>//=[k _|j IH k H0]H.
+by right; rewrite evol_allP; exists k; rewrite tidcat0e //.
case:(IH _ H0 H)=>[/ep |/evol_allP[x][H2]->]{IH H}; first by left.
elim: x j H2 H0=>//[j _ | x IH /= j H0 H1].
+ by left; rewrite tidcate0; apply:ep; constructor.
(* some reasoning about suffixes missing here *)
Admitted.

Lemma eqq_refl: forall j,  eqq j j.
Proof. by move=>j; left; constructor. Qed.

Lemma eqq_sym: forall i j,  eqq i j -> eqq j i.
Proof. by move=> i j; case; [ right | left]. Qed.

Lemma eqq_trans: forall i j k,  eqq i j -> eqq j k -> eqq i k.
Proof.
move=>i j k [H1|H1].
+ case=>[|H2]; first by move/(@e_trans i j k H1); left.
 elim: j H1 H2=>[|j _|j IH] ; first
            by move/evol_enil=>-> /evol_enil ->; left; constructor.
 - by move/evol_ec=>-> /evol_ec ->; left; constructor.
 move/evol_ep=>[<-|H]; first by right.
 by move/evol_ep=>[->|/(IH H)]//; left; apply: ep.
case=>[/evol_allP [x][H2]->|]; last by move/e_trans/(_ H1); right.
move: H1;case/evol_allP=>[y][H3]->.
by case: (allp_eqq x y H2 H3); [left |right]; apply:evol_tidcatL.
Qed.
(* Clearly, reasoning about suffixes of
  lists is a better idea than baked in tids
*)

(* boolean equivalence for reflection purposes *)