(**
Coq/SSReflect/MathComp による定理証明

第4章 MathComp ライブラリの基本ファイル

4.5 fintype.v --- 有限型のライブラリ

======

2018_12_10 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import perm.

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

(**
# はじめに

本節はテキストを参照しながら、MathComp のソースコードに沿って説明していきます。
ソースコードが手元にあるならば、それも参照してください。
opamでインストールしている場合は、ソースは、たとえば以下にあります。

~/.opam/4.07.1/lib/coq/user-contrib/mathcomp/ssreflect/fintype.v
*)

(**
# finType とは

要素の列挙(enum)のリストと、enumの要素に重複がないことを公理とする型クラスである。
インスタンスを生成するときに、この列挙リストに具体的な値を設定し、
公理は証明済みの命題に置き換える。

参考：eqType は、値が等しいことを決定する関数（ブール述語）が存在することと、
それがCoq本来の「=」と同値であることを公理とする型クラスである。
*)

(**
## 目次

- finType型のインスタンス型の作り方

- すでにあるfinType型のインスタンス

- 順序数型 (Ordinal型)

- 濃度

- forall と exists (boolean quantifiers)

- \subset と \proper (⊆ と ⊂)

finTypeとfinSetの関係についての補足：

``fT : finType`` としたとき、bool述語 ``P : fT -> bool`` がtrueを返す fT の要素を考えると、
濃度やforall, exists, subset, proper を定義できる。
ただし、ここでは P を集合とは見なさない。

このような集合は、のちに finset.v で定義する。set_finTypeはfinTypeのインスタンス型なので、
eqTypeのインスタンス型でもあるから、集合どうしの ``==`` が定義できる。
*)

(**
# finType型のインスタンス型の作り方

finType の定義は以下のとおりである。
*)
Print Finite.class_of.
(*
Record class_of (T : Type) : Type := Class
  { base : Choice.class_of T;
    mixin : Finite.mixin_of (EqType T base) }
*)
Print Finite.mixin_of.
(*
Record mixin_of (T : eqType) : Type := Mixin
  { mixin_base : Countable.mixin_of T;
    mixin_enum : seq T;
    _ : Finite.axiom (T:=T) mixin_enum } *)

(**
最初に述べた公理の内容は、以下である。ballがこれを満たすことは、あとで調べる。
*)
Print Finite.axiom.
(* = fun (T : eqType) (e : seq T) => forall x : T, (count_mem x) e = 1. *)

(**
conunt_mem を展開すると、つぎのようになる。
*)
Check fun (T : eqType) (e : seq T) =>
        forall x : T, count [pred y | x == y] e = 1.
(**
とりあえあず ``[pred y | x == y]`` は ``fun y => x == y`` と思ってよいので、

要素に重複のない（どの要素の数も1個の）T型のリストがある、という意味
 *)

(**
## ball_finType
 *)

(**
### ball_eqType, ball_choiceType, ball_countType を定義する。

ball と bool が1対1対応であることを証明して、それを使って、
型クラスeqType のインスタンスの ball_eqType型を定義する。
型クラスchoiceType のインスタンスの ball_choiceType型を定義する。
型クラスcountType のインスタンスの ball_countType型を定義する。

eqType の公理を直接証明するのは、以下を参照のこと。
https://github.com/suharahiromichi/coq/blob/master/csm/csm_4_2_eqtype.v

Countable の公理 (unpick と pick) はともかく、Choice の公理を証明するのは大変。
*)

(**
predArgType を明示したほうがよい。
 *)
Inductive ball : predArgType :=
| red                          (* 紅玉 *)
| white.                       (* 白玉 *)

Definition ball2bool (b : ball) : bool :=
  match b with
  | red => true
  | white => false
  end.

Definition bool2ball (b : bool) : ball :=
  match b with
  | true => red
  | false => white
  end.

Lemma inj_b2b : injective ball2bool.
Proof. by case; case. Qed.

Lemma can_b2b : cancel ball2bool bool2ball.
Proof. by case. Qed.

Definition ball_eqMixin := InjEqMixin inj_b2b.
Canonical ball_eqType := EqType ball ball_eqMixin.
Definition ball_choiceMixin := CanChoiceMixin can_b2b.
Canonical ball_choiceType := ChoiceType ball ball_choiceMixin.
Definition ball_countMixin := CanCountMixin can_b2b.
Canonical ball_countType := CountType ball ball_countMixin.

(**
### ball の本来の定義を使ってfinTypeを定義する。
 *)
Definition ball_enum := [:: red; white].

(**
ball_eqType で導入した「==」が、Finite.axiom を満たすことを確かめます。
*)
Compute count [pred y | red == y] ball_enum.   (* 1 *)
Compute count [pred y | white == y] ball_enum. (* 1 *)

(**
定理として証明します。
*)
Lemma ball_uniq : forall x, count_mem x ball_enum = 1.
Proof. by case. Qed.

Definition ball_finMixin' := @FinMixin ball_countType ball_enum ball_uniq.
Canonical ball_finType' := FinType ball ball_finMixin'.

(**
### ball2bool の単射性をつかってfinTypeを定義する。
 *)
Definition ball_finMixin := CanFinMixin can_b2b.
Canonical ball_finType := FinType ball ball_finMixin.

(**
出来上がったもの：
*)
Check red : ball : predArgType.
(**
注意：
ball の定義のときに predArgType を明示しない場合でも、
ball : predArgType は成り立つ。predArgType = Type であるため。
しかし、finType の定義のなかで、濃度の定義がされなくなってしまう。
card は mem_pred T -> nat であるため。
*)
Check red : ball_finType : finType.
Check red : Finite.sort ball_finType : predArgType.
Compute Finite.sort ball_finType.           (* ball *)

(**
ここでは、ball型 と bool型 との要素の対応で定義したが、
Ordinal型との要素の対応で定義もできる。MCBの7.5節参照。

[MCB] Mathematical Components (MathComp Book)
https://math-comp.github.io

https://github.com/suharahiromichi/coq/blob/master/math-comp-book/suhara.ch7-windrose.v
*)

(**
### MathComp の三点セット（？）

以上で、==, \in, #|_| の「三点セット」が成り立つようになる。
*)
Check red == red.
Check red != white.
Check red \in ball.          (* 最初に predArgType を明示すること。 *)
Check #| ball | == 2.        (* predArgType に対する finType なら濃度が定義される。 *)

(**
# すでにある finType のインスタンス型
*)

Check bool_finType       : finType.         (* bool型 *)
Check ordinal_finType 5  : finType.         (* 濃度5の順序数 *)

Check tuple_finType 3 (ordinal_finType 5)
  : finType.                (* 濃度5の順序数を要素とする寸法3のリスト *)

Check finfun_finType (ordinal_finType 5) (ordinal_finType 6)
  : finType. (* 濃度5の順序数を引数、濃度6の順序数を値とする関数である。 *)
(* finfun は、値は任意の型でよいので、すべての finfun が finType とは限らない。 *)

Check set_finType (ordinal_finType 5) : finType. (* 濃度5の順序数を要素とする集合 *)
(* finset は、finType型を引数、bool型を値とする関数 finfun である。 *)
Variable P Q : set_finType (ordinal_finType 5).
Check P == Q.

Check perm_finType (ordinal_finType 5) : finType. (* 濃度5の順序数の順列 *)

(**
finalg.v で定義される finRingType （や finFieldType） は、finTypeと同じ mixin を使用する。
base 型には、ringType （と fieldType） を使う。これらの型は以下の性質をもつ。

```
Variable F : finRingType.
Check F : ringType.
Check F : finType.
```
*)

(**
# 順序数 (ordinal n)

``0``〜``n-1`` の範囲の自然数である。
*)

Goal [forall x in 'I_5, x < 5].
Proof.
  apply/forallP.
  (* forall x, (x \in 'I_5) ==> (x < 5) *)
  by case=> m i.
Qed.

(**
## ordinal 型の値を作る関数

"n is inferred from the context" とは、この場合、``: 'I_5`` のところ。
 *)
Definition s0 : 'I_5 := ord0.
Definition s1 : 'I_5 := inord 1.
Definition s2 : 'I_5 := inord 2.
Definition s3 : 'I_5 := inord 3.
Definition s4 : 'I_5 := ord_max.

Definition p0 (x : 'I_5) := (x == s0).      (* 'I_5 -> bool *)
Definition p4 (x : 'I_5) := x <= s4.        (* 'I_5 -> bool *)

Compute p0 s0.                              (* true *)
Compute s0 \in p0.                          (* true *)

(**
出来上がったもの：
*)
Check s1 : 'I_5 : predArgType.            (* ordinal は predArgType *)
(**
``'I_5`` (``ordinal 5``) は、Finite.sort 関数についての
``ordinal_finType 5`` のカノニカル解なので、
Coq は ``Finite.sort (ordinal_finType 5)`` が ``'I_5`` であることを推論できる
（テキスト 3.15.2 参照）。
*)
Check s1 : ordinal_finType 5 : finType.
Check s1 : Finite.sort (ordinal_finType 5) : predArgType.
Compute Finite.sort (ordinal_finType 5).    (* 'I_5 *)

Compute val s1.                             (* ***** *)

(**
## 順序数の定義に基づいた定義

s1 == s1' であることの証明をすること。。。
*)
Definition s1' : 'I_5.
Proof. by apply: (@Ordinal 5 1). Defined.   (* Defined で終わる。 *)
Compute val s1'.                            (* 1 *)

Lemma le15 : 1 <= 5. Proof. done. Qed.
Definition s1'' := @Ordinal 5 1 le15.
Compute val s1''.                           (* 1 *)

(**
## 型を変換する関数

'I_5 を 'I_10 に変換する。
*)
Lemma le_5_10 : 5 <= 10. Proof. done. Qed.
Check @widen_ord 5 10 le_5_10 s1 : 'I_10.

Definition s1''' : 'I_10.
Proof.
  apply: (@widen_ord 5 10).
  - done.
  - apply: s1.
Defined.

(**
順序数の型（範囲）をひとつだけ増やす関数。

'I_n を 'I_n.+1 に変換する。
 *)
Definition widen_ord_1 {n : nat} (s : 'I_n) : 'I_n.+1.
Proof.
  apply: widen_ord.
  - by apply: leqnSn.
  - by apply: s.
Defined.

(**
'I_5 を 'I_6 を経て 'I_7 に変換する。
 *)
Check widen_ord_1 (widen_ord_1 s1) : 'I_7.

(**
## val または  nat_of_ord で自然数の値を取り出す。後者はコアーション。
*)
Check val : 'I_5 -> nat.
Check @nat_of_ord 5  : 'I_5 -> nat.

Compute val s0.                             (* = 0 *)
Compute nat_of_ord s0.                      (* = 0 *)

Compute val s4.                             (* = 4 *)
Compute nat_of_ord s4.                      (* = 4 *)

Compute s0 < 4.                     (* 不等式はコアーションが効く。 *)

(**
## 補題 val と nat_of_ord が単射である。
*)

Check @val_inj : forall (T : Type) (P : pred T) (sT : subType P), injective val.
Check ord_inj : forall n : nat, injective (nat_of_ord (n:=n)).

(**
## Ordinal についての補題：
*)

(* 'I_n 型の要素は、n より小さい。 *)
Check ltn_ord : forall (n : nat) (i : 'I_n), i < n.
(* 'I_n.+1 型の要素は、n 以下である。 *)
Check leq_ord : forall (n' : nat) (i : 'I_n'.+1), i <= n'.

(* 'I_n 型の要素は n 個である。 *)
Check card_ord : forall n : nat, #|'I_n| = n.

Check widen_ord_proof : forall (n m : nat) (i : 'I_n), n <= m -> i < m.
Check cast_ord_proof : forall (n m : nat) (i : 'I_n), n = m -> i < m.

(**
# 濃度 Cardinal
*)

Goal #| 'I_5  | = 5.
Proof.
  rewrite cardE.
  rewrite size_enum_ord.
  done.
Qed.

(*
predPredType の補足説明。
A is a collective predicate over T.
*)
Check bool_finType : finType.
Check (fun x => x == true)       : predPredType bool_finType.
Check (fun x => x \in [:: true]) : predPredType bool_finType.
Check (fun x => x \in [::])      : predPredType bool_finType.
(*    ^^^^^^^^^^^^^^^^^^^^^^^^^^ collective predicate over bool_finType *)

Check cardE : forall (T : finType) (A : predPredType T),
    #|A| = size (enum A).

Check eq_card : forall (T : finType) (A B : predPredType T),
    A =i B -> #|A| = #|B|.
Check eq_card_trans : forall (T : finType) (A B : predPredType T) (n : nat),
    #|A| = n -> B =i A -> #|B| = n.
Check card0 : forall T : finType,
    #|pred0| = 0.
Check card1 : forall (T : finType) (x : T),
    #|pred1 x| = 1.
Check eq_card0 : forall (T : finType) (A : predPredType T),
    A =i pred0 -> #|A| = 0.
Check eq_card1 : forall (T : finType) (x : T) (A : predPredType T),
    A =i pred1 x -> #|A| = 1.
Check cardUI : forall (T : finType) (A B : predPredType T),
    #|[predU A & B]| + #|[predI A & B]| = #|A| + #|B|. (* |A∩B|+|A∪B| = |A|+|B| *)
Check cardID : forall (T : finType) (B A : predPredType T),
    #|[predI A & B]| + #|[predD A & B]| = #|A|.        (* |A∩B|+|A-B| = |A| *)
Check cardC : forall (T : finType) (A : predPredType T),
    #|A| + #|[predC A]| = #|T|.             (* |A|+|A^c| = |T| *)
Check cardU1 : forall (T : finType) (x : T) (A : predPredType T),
    #|[predU1 x & A]| = (x \notin A) + #|A|.

(**
濃度が存在することの証明：

``∃ i, | p | = i``

https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_ex_card.v
 *)

(**
# forall と exists (boolean quantifiers)

## 定義

bool型を返す量化子（∀と∃）であり、``T : finType`` のとき、
bool型を返す述語 ``P : T -> bool`` において、
T型の要素を量化の範囲として、その「すべて」、「ある」要素に対して
``P x`` が true を返すとき、
[forall x in T, P x]、[exists x in T, P x] は true を返す。
``in T`` は省略できる。
*)

(**
## 用意されている同値の補題
*)
Check @forallP
  : forall (T : finType) (P : pred T), reflect (forall x : T, P x) [forall x, P x].
Check @existsP
  : forall (T : finType) (P : pred T), reflect (exists x : T, P x) [exists x, P x].

Goal [forall x, p4 x].              (* すべての 'I_5 の要素は、4以下である。 *)
Proof.
  apply/forallP.
  rewrite /p4 /s4.
  (* forall x : ordinal_finType 5, x <= p4 *)
  case=> m /=.              (* x を Ordinal の定義にしたがって分解する。 *)
  (* m < 5 -> m <= 4 *)
  done.
Qed.

Goal [exists x, p0 x].             (* ある 'I_5 の要素は、0である。 *)
Proof.
  apply/existsP.
  rewrite /p0.
  (* exists x : ordinal_finType 5, x == p0  *)
  exists s0.
  (* s0 == s0 *)
  done.
Qed.

(**
# 包含関係（部分集合）

``T : finType`` のとき、
bool型を返す述語 ``P : T -> bool`` において、
それがtrueを返す、Tの要素についての包含関係（部分集合と真部分集合）を考えることができる。
 *)

(**
## 濃度による定義 (\subset と \proper)
*)

Check p0 \subset p4.
(**
``p0 \subset p4`` は、「p0 でなく p4 である要素」の濃度が0であることで定義されている。
すなわち、
*)
Check (fun x : 'I_5 => ~~ (p0 x) && (p4 x)) : pred 'I_5.
(**
p0 x が false かつ p4 x が true という論理式を考え、
 *)
Check card (mem (predD p0 p4)) == 0.
(**
それを満たす x の個数が 0個である、と定義されている。

次の補題は、\subset の定義を展開しただけのものである。
*)
Check subsetE
  : forall (T : finType) (A B : predPredType T),
    (A \subset B) = pred0b [predD A & B].

(**
\proper は \subset から定義されている。
*)
Check p0 \proper p4.
Check (p0 \subset p4) && ~~(p4 \subset p0).

(**
## Prop型の命題 ``{subset p0 <= p4} ≡ (x \in p0 -> x \in p4)``
*)
Lemma p0_p4' : {subset p0 <= p4} : Prop.
Proof.
  rewrite /p0 /p4 => x.
  rewrite /in_mem /=.
  by move/eqP => ->.
Qed.

(**
補題が用意されている。
*)
Check @subsetP
  : forall (T : finType) (A B : predPredType T),
    reflect {subset A <= B} (A \subset B).
Check @properP
  : forall (T : finType) (A B : predPredType T),
    reflect (A \subset B /\ (exists2 x : T, x \in B & x \notin A)) (A \proper B).

Lemma p0_p4 : p0 \subset p4.
Proof.
  by apply/subsetP/p0_p4'.
Qed.

Lemma p0_p4'' : p0 \proper p4.
Proof.
  apply/properP.
  split.
  - by apply: p0_p4.
  - by exists s4.
Qed.

(**
## bool型の命題 ``[forall x, (x \in p0) ==> (x \in p4)]``
*)
Section Test.
  Variable T : finType.

  Lemma p0_p4''' : [forall x, (x \in p0) ==> (x \in p4)] : bool.
  Proof.
    apply/forallP => x.
    apply/implyP => /eqP ->.
    done.
  Qed.

(**
## 相互の同値関係

(forall x, x \in q1 -> x \in q2) <-> [forall x, (x \in q1) ==> (x \in q2)]
*)
  Lemma mySubsetP' (q1 q2 : pred T) :
    {subset q1 <= q2} <-> [forall x, (x \in q1) ==> (x \in q2)].
  Proof.
    split=> H.
    - apply/forallP => x.
      by apply/implyP/H.
      - move=> x.
      apply/implyP.
      move: x.
      by apply/forallP.
  Qed.

  Lemma mySubsetP (q1 q2 : pred T) :
    q1 \subset q2 <-> (forall x, x \in q1 -> x \in q2).
  Proof.
    split.
    - move/subsetP.
      move/mySubsetP' => H.
      by apply/mySubsetP'.
    - move/mySubsetP' => H.
      apply/subsetP.
      by apply/mySubsetP'.
  Qed.

  Lemma mySubsetE (q1 q2 : pred T) :
    q1 \subset q2 = [forall x, (x \in q1) ==> (x \in q2)].
  Proof.
    apply/idP/idP.
    - move=> H.
      apply/forallP => x.
      apply/implyP.
      by apply/mySubsetP : x.
    - move=> H.
      apply/mySubsetP => x.
      move/forallP in H.
      by move: (H x) => {H} /implyP H /=.
  Qed.
End Test.

Goal [forall x, (x \in p0) ==> (x \in p4)].
Proof.
  rewrite -mySubsetE.
  by apply: p0_p4.
Qed.

(* END *)


From defaultt Require Import set.
From Coq Require Import Program.Equality Bool.

Definition Atom : Type := nat.

Inductive Form : Type :=
  | For  : Form -> Form -> Form
  | Fand : Form -> Form -> Form
  | Fneg : Form -> Form
  | Fatm : Atom -> Form
  | Ffalse : Form.

Definition Fimp (fa fb : Form) : Form :=
  For (Fneg fa) fb.

Definition Ftrue : Form :=
  (Fneg Ffalse).

Fixpoint eval (env : nat -> bool) (f : Form) : bool :=
  match f with
  | For fa fb => eval env fa || eval env fb
  | Fand fa fb => eval env fa && eval env fb
  | Fneg fa => negb (eval env fa)
  | Fatm a => env a
  | Ffalse => false
  end.

Definition eval_set (env : nat -> bool) (E : set Form) : Prop :=
  forall f, E f -> eval env f = true.

Definition conseq (E : set Form) (f : Form) : Prop :=
  forall m, eval_set m E -> eval m f = true.

Infix "⊨" := conseq (at level 80).

Inductive deduct : set Form -> Form -> Prop :=
  | and_intro (E : set Form) fa fb :
    deduct E fa -> deduct E fb -> deduct E (Fand fa fb)
  | and_elim_l (E : set Form) fa fb :
    deduct E (Fand fa fb) -> deduct E fa
  | and_elim_r (E : set Form) fa fb :
    deduct E (Fand fa fb) -> deduct E fb
  | neg_elim E fa :
    deduct E fa -> deduct E (Fneg fa) -> deduct E Ffalse
  | bot_elim E fa :
    deduct E Ffalse -> deduct E fa
  | or_intro_l (E : set Form) fa fb :
    deduct E fa -> deduct E (For fa fb)
  | or_intro_r (E : set Form) fa fb :
    deduct E fb -> deduct E (For fa fb)
  | or_elim E fa fb fc :
    deduct E (For fa fb) ->
    deduct E (Fimp fa fc) ->
    deduct E (Fimp fb fc) ->
    deduct E fc
  | excluded_middle E fa :
    deduct E (Fneg (Fand fa (Fneg fa)))
  | axiom (E : set Form) fa : E fa -> deduct E fa.

Infix "⊢" := deduct (at level 80).

Theorem deduct_sound:
  forall E f, E ⊢ f -> E ⊨ f.
Proof.
  intros E f H. induction H; intros m Hm.
  - simpl. now rewrite (IHdeduct1 m Hm), (IHdeduct2 m Hm).
  - specialize (IHdeduct m Hm).
    now apply Bool.andb_true_iff in IHdeduct.
  - specialize (IHdeduct m Hm).
    now apply Bool.andb_true_iff in IHdeduct.
  - specialize (IHdeduct1 m Hm).
    specialize (IHdeduct2 m Hm).
    simpl in *.
    apply Bool.negb_true_iff in IHdeduct2.
    now rewrite IHdeduct1 in IHdeduct2.
  - now specialize (IHdeduct m Hm).
  - specialize (IHdeduct m Hm).
    simpl. rewrite IHdeduct. intuition.
  - specialize (IHdeduct m Hm).
    simpl. rewrite IHdeduct. intuition.
  - specialize (IHdeduct1 m Hm).
    specialize (IHdeduct2 m Hm).
    specialize (IHdeduct3 m Hm).
    simpl in *.
    apply Bool.orb_true_iff in IHdeduct1 as [IHdeduct1 | IHdeduct1].
    + now rewrite IHdeduct1 in IHdeduct2.
    + now rewrite IHdeduct1 in IHdeduct3.
  - simpl. now destruct (eval m fa).
  - now specialize (Hm fa H).
Qed.

(** Deductive closure *)
Definition theory (T : set Form) : set Form :=
  deduct T.

Definition inconsistent (T : set Form) : Prop :=
  deduct T Ffalse.

Definition consistent (T : set Form) : Prop :=
  ~inconsistent T.

Lemma disprove_consistent :
  forall T p, ~deduct T p -> consistent T.
Proof.
  intros T p Hp H.
  now assert (Hcontr : T ⊢ p) by apply bot_elim, H.
Qed.


Require Import List Arith.
Import ListNotations.
Require Import core.

Notation eqdec := eq_nat_dec.

Require Import Lia.

Module renSubst.

Notation upT vs := (0 :: vs).

(** Definition of finite type based on lists.
    It's very similar to the normal fin type of wellscoped syntax.
    Maybe even too much. I'm havin doubts that this is an appropriate
    formalization of traced syntax. *)
Inductive wrapNat (n:nat) : Type := wrapC : wrapNat n.

Fixpoint fin (l: list nat) : Type :=
  match l with
  | [] => False
  | n :: l => (wrapNat n) + (fin l)
  end.

(* compute the natural number that a value of type fin l denotes. *)
Fixpoint denote {l: list nat} (x: fin l) {struct l} : nat.
Proof.
  destruct l as [|n l'].
  - destruct x.
  - refine (match x with
            | inl (wrapC _) => n
            | inr x' => S (denote l' x')
            end).
Defined.

(* compute a "flattened" list, i.e. with the simplification which only tracks differences between the elements. *)
Fixpoint flatten (l: list nat) (acc: nat) : list nat :=
  match l with
  | [] => []
  | x :: l =>
    let x' := x - acc in
    x' :: flatten l (S x)
  end.

(* some values of the finite type *)
Definition fl (l: list nat) : list nat := flatten l 0.
Definition f0 : fin [0] := inl (wrapC 0).
Definition f1 : fin (fl [0;2;3]) := inl (wrapC 0). (* denotes 0 *)
Definition f2 : fin (fl [0;2;3]) := inr (inl (wrapC 1)). (* denotes 2 *)
Definition f3 : fin (fl [0;2;3]) := inr (inr (inl (wrapC 0))). (* denotes 3 *)

Compute (denote f0).
Compute (denote f1).
Compute (denote f2).
Compute (denote f3).

(* language definition *)
Inductive tm (vs : list nat) : Type :=
  | var_tm : fin vs -> tm vs
  | app : tm vs -> tm vs -> tm vs
  | lam : tm (upT vs) -> tm vs.

(* congruence lemmas are unchanged except list scope variable *)
Lemma congr_app {vs : list nat} {s0 : tm vs} {s1 : tm vs} {t0 : tm vs}
  {t1 : tm vs} (H0 : s0 = t0) (H1 : s1 = t1) :
  app _ s0 s1 = app _ t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app _ x s1) H0))
         (ap (fun x => app _ t0 x) H1)).
Qed.

Lemma congr_lam {vs : list nat} {s0 : tm (upT vs)} {t0 : tm (upT vs)}
  (H0 : s0 = t0) : lam _ s0 = lam _ t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => lam _ x) H0)).
Qed.

Open Scope type.

(* scons is the biggest problem when we map S over the list.
 * because we have to take the m, which is mapped, and pass it to f, which does not want the map.
 * With my simplification it works fine. *)
Definition scons {X : Type} {vs : list nat} (x : X) (f : fin vs -> X) (m : fin (upT vs)) : X.
Proof.
  destruct m as [n|m'].
  - exact x.
  - exact (f m').
Defined.

Compute (@scons nat (fl [1;2]) 1 (fun _ => 6) f1).
Compute (@scons nat (fl [1;2]) 1 (fun _ => 6) f2).
Compute (@scons nat (fl [1;2]) 1 (fun _ => 6) f3).

(* we can define "lossy" primitives.  *)
Definition var_zero {vs: list nat} : fin (upT vs) := inl (wrapC 0).
Definition shift {vs: list nat} : fin vs -> fin (upT vs) := inr.

(* with traced syntax we can know that var_zero is in fin [0] and shift does not contain a 0
 * but these non-lossy versions are not easy to use. *)
Definition var_zero' : fin [0] := inl (wrapC 0).
Definition shift' {vs: list nat} : fin vs -> fin (List.map S vs).
Proof.
  intros m. induction vs as [|v vs].
  - destruct m.
  - destruct m as [n|m'].
    + left. constructor.
    + right. exact (IHvs m').
Defined.

Definition up_ren {m n} (xi : fin m -> fin n) : fin (upT m) -> fin (upT n) :=
  scons var_zero (funcomp shift xi).

Definition upRen_tm_tm {vs0 vs1 : list nat} (xi: fin vs0 -> fin vs1) : fin (upT vs0) -> fin (upT vs1) := up_ren xi.

Fixpoint ren_tm {vs0 vs1: list nat} (xi_tm : fin vs0 -> fin vs1) (s: tm vs0) {struct s} : tm vs1.
Proof.
  refine (match s with
          | var_tm _ x => _
          | app _ s0 s1 => _
          | lam _ s0 => _
          end).
  - exact (var_tm _ (xi_tm x)).
  - exact (app _ (ren_tm _ _ xi_tm s0) (ren_tm _ _ xi_tm s1)).
  - exact (lam _ (ren_tm _ _ (upRen_tm_tm xi_tm) s0)).
Defined.

Print Assumptions ren_tm.

Lemma up_tm_tm {vs0 : list nat} {vs1 : list nat} (sigma : fin vs0 -> tm vs1) :
  fin (upT vs0) -> tm (upT vs1).
Proof.
  exact (scons (@var_tm (upT vs1) var_zero) (funcomp (ren_tm shift) sigma)).
Defined.

Fixpoint subst_tm {vs0 : list nat} {vs1 : list nat} (sigma_tm : fin vs0 -> tm vs1) (s : tm vs0) {struct s}
  : tm vs1.
Proof.
  refine (match s with
          | var_tm _ x => _
          | app _ s0 s1 => _
          | lam _ s0 => _
          end).
  - exact (sigma_tm x).
  - exact (app _ (subst_tm _ _ sigma_tm s0) (subst_tm _ _ sigma_tm s1)).
  - exact (lam _ (subst_tm _ _ (up_tm_tm sigma_tm) s0)).
Defined.

Print Assumptions subst_tm.

(* lambda x y . x w (lambda z . w z y) *)
(* lambda . lambda . 1 2 (lambda . 3 0 1) *)
Definition testtm : tm [1].
Proof.
  refine (lam _ (lam _ (app _ (app _ (* x w *) _ _)
                        (lam _ (app _ (app _ (* w z *) _ _) (* y *) _))))).
  - (* x *)
    cbv.
    (* apparently here Coq's unification is too weak *)
    refine (@var_tm (fl [0;1;3]) var_zero).
  - (* outer w *)
    refine (@var_tm (fl [0;1;3]) (shift var_zero)).
  - (* inner w *)
    refine (@var_tm (fl [0;1;2;4]) (shift (shift var_zero))).
  - (* z *)
    exact (@var_tm (fl [0;1;2;4]) var_zero).
  - (* y *)
    refine (@var_tm (fl [0;1;2;4]) (shift (shift var_zero))).
Defined.

Print Assumptions testtm.
Print testtm.

(* and here we see that the formalization is bad. we should have enough information that a shift increases the only free variable.
   so the type should be tm [2], but we are essentially throwing that info away. *)
Fail Check (ren_tm shift testtm : tm [2]).
Check (ren_tm shift testtm : tm [0;1]).
(* we can compute with these definitions *)
Compute (ren_tm shift testtm).
Compute (subst_tm (var_tm _) testtm).

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition cast {X} {x y: X} {p: X -> Type}
  : x = y -> p x -> p y
  := fun e a => match e with eq_refl => a end.

Lemma upId_tm_tm {vs : list nat} (sigma : fin vs -> tm vs)
  (Eq : forall x, sigma x = var_tm _ x) :
  forall x, up_tm_tm sigma x = @var_tm (upT vs) x.
Proof.
  refine (fun x =>
          match x with
          | inr x' => ap (ren_tm shift) (Eq x')
          | inl (wrapC _) => eq_refl
          end).
Qed.

Fixpoint idSubst_tm {vs : list nat} (sigma_tm : fin vs -> tm vs)
(Eq_tm : forall x, sigma_tm x = var_tm _ x) (s : tm vs) {struct s} :
subst_tm sigma_tm s = s :=
  match s as s0 return subst_tm sigma_tm s0 = s0
  with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 => congr_app (idSubst_tm sigma_tm Eq_tm s0) (idSubst_tm sigma_tm Eq_tm s1)
  | lam _ s0 => congr_lam (idSubst_tm (up_tm_tm sigma_tm) (upId_tm_tm sigma_tm Eq_tm) s0)
  end.

Lemma upExtRen_tm_tm {m : list nat} {n : list nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_tm_tm xi x = upRen_tm_tm zeta x.
Proof.
exact (fun n =>
       match n with
       | inr x' => ap shift (Eq x')
       | inl n => match n with wrapC _ => eq_refl end
       end).
Qed.

Fixpoint extRen_tm {m_tm : list nat} {n_tm : list nat} (xi_tm : fin m_tm -> fin n_tm)
(zeta_tm : fin m_tm -> fin n_tm) (Eq_tm : forall x, xi_tm x = zeta_tm x)
(s : tm m_tm) {struct s} : ren_tm xi_tm s = ren_tm zeta_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm n_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (extRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upExtRen_tm_tm _ _ Eq_tm) s0)
  end.

Lemma upExt_tm_tm {m : list nat} {n_tm : list nat} (sigma : fin m -> tm n_tm)
  (tau : fin m -> tm n_tm) (Eq : forall x, sigma x = tau x) :
  forall x, up_tm_tm sigma x = up_tm_tm tau x.
Proof.
exact (fun n =>
       match n with
       | inr fin_n => ap (ren_tm shift) (Eq fin_n)
       | inl n => match n with wrapC _ => eq_refl end
       end).
Qed.

Fixpoint ext_tm {m_tm : list nat} {n_tm : list nat} (sigma_tm : fin m_tm -> tm n_tm)
(tau_tm : fin m_tm -> tm n_tm) (Eq_tm : forall x, sigma_tm x = tau_tm x)
(s : tm m_tm) {struct s} : subst_tm sigma_tm s = subst_tm tau_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (ext_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm) (upExt_tm_tm _ _ Eq_tm)
           s0)
  end.

Lemma up_ren_ren (k l m : list nat) (xi: fin k -> fin l) (zeta : fin l -> fin m) (rho: fin k -> fin m) (E: forall x, (funcomp zeta xi) x = rho x) :
  forall x, up_ren zeta (up_ren xi x) = up_ren rho x.
Proof.
  intros [n|x'].
  - reflexivity.
  - cbn. unfold funcomp. now rewrite <- E.
Qed.

Arguments up_ren_ren {k l m} xi zeta rho E.

Lemma up_ren_ren_tm_tm {k : list nat} {l : list nat} {m : list nat} (xi : fin k -> fin l)
  (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x = upRen_tm_tm rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Fixpoint compRenRen_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
(xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(rho_tm : fin m_tm -> fin l_tm)
(Eq_tm : forall x, funcomp zeta_tm xi_tm x = rho_tm x) (s : tm m_tm) {struct
 s} : ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm rho_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm l_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upRen_tm_tm rho_tm) (up_ren_ren _ _ _ Eq_tm) s0)
  end.

Lemma up_ren_subst_tm_tm {k : list nat} {l : list nat} {m_tm : list nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_tm_tm tau) (upRen_tm_tm xi) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | inr fin_n => ap (ren_tm shift) (Eq fin_n)
       | inl n => match n with wrapC _ => eq_refl end
       end).
Qed.

Fixpoint compRenSubst_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
(xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp tau_tm xi_tm x = theta_tm x) (s : tm m_tm) {struct
 s} : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenSubst_tm (upRen_tm_tm xi_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_ren_subst_tm_tm _ _ _ Eq_tm) s0)
  end.

Lemma up_subst_ren_tm_tm {k : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_tm_tm zeta_tm)) (up_tm_tm sigma) x =
  up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | inr fin_n =>
           eq_trans
             (compRenRen_tm shift (upRen_tm_tm zeta_tm)
                (funcomp shift zeta_tm) (fun x => eq_refl) (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compRenRen_tm zeta_tm shift (funcomp shift zeta_tm)
                      (fun x => eq_refl) (sigma fin_n)))
                (ap (ren_tm shift) (Eq fin_n)))
       | inl n => eq_refl
       end).
Qed.

Fixpoint compSubstRen_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
(sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (ren_tm zeta_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
ren_tm zeta_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstRen_tm (up_tm_tm sigma_tm) (upRen_tm_tm zeta_tm)
           (up_tm_tm theta_tm) (up_subst_ren_tm_tm _ _ _ Eq_tm) s0)
  end.

Lemma up_subst_subst_tm_tm {k : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_tm_tm tau_tm)) (up_tm_tm sigma) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | inr fin_n =>
           eq_trans
             (compRenSubst_tm shift (up_tm_tm tau_tm)
                (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl)
                (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compSubstRen_tm tau_tm shift
                      (funcomp (ren_tm shift) tau_tm) (fun x => eq_refl)
                      (sigma fin_n))) (ap (ren_tm shift) (Eq fin_n)))
       | inl n => eq_refl
       end).
Qed.

Fixpoint compSubstSubst_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
(sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (subst_tm tau_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
subst_tm tau_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstSubst_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_subst_subst_tm_tm _ _ _ Eq_tm) s0)
  end.

Lemma rinstInst_up_tm_tm {m : list nat} {n_tm : list nat} (xi : fin m -> fin n_tm)
  (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x, funcomp (var_tm (upT n_tm)) (upRen_tm_tm xi) x = up_tm_tm sigma x.
Proof.
exact (fun n =>
       match n with
       | inr fin_n => ap (ren_tm shift) (Eq fin_n)
       | inl n => eq_refl
       end).
Qed.

Fixpoint rinst_inst_tm {m_tm : list nat} {n_tm : list nat}
(xi_tm : fin m_tm -> fin n_tm) (sigma_tm : fin m_tm -> tm n_tm)
(Eq_tm : forall x, funcomp (var_tm n_tm) xi_tm x = sigma_tm x) (s : tm m_tm)
{struct s} : ren_tm xi_tm s = subst_tm sigma_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (rinst_inst_tm (upRen_tm_tm xi_tm) (up_tm_tm sigma_tm)
           (rinstInst_up_tm_tm _ _ Eq_tm) s0)
  end.

Lemma renRen_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm (funcomp zeta_tm xi_tm) s.
Proof.
exact (compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Require Import Setoid Morphisms.

Lemma renRen'_tm_pointwise {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  pointwise_relation _ eq (funcomp (ren_tm zeta_tm) (ren_tm xi_tm))
    (ren_tm (funcomp zeta_tm xi_tm)).
Proof.
exact (fun s => compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm) s.
Proof.
exact (compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm_pointwise {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  pointwise_relation _ eq (funcomp (ren_tm zeta_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm)).
Proof.
exact (fun s => compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) (s : tm m_tm)
  : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm (funcomp tau_tm xi_tm) s.
Proof.
exact (compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm_pointwise {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  pointwise_relation _ eq (funcomp (subst_tm tau_tm) (ren_tm xi_tm))
    (subst_tm (funcomp tau_tm xi_tm)).
Proof.
exact (fun s => compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
  (s : tm m_tm) :
  subst_tm tau_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm) s.
Proof.
exact (compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm_pointwise {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  pointwise_relation _ eq (funcomp (subst_tm tau_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (subst_tm tau_tm) sigma_tm)).
Proof.
exact (fun s => compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm {m_tm : list nat} {n_tm : list nat} (xi_tm : fin m_tm -> fin n_tm)
  (s : tm m_tm) : ren_tm xi_tm s = subst_tm (funcomp (var_tm n_tm) xi_tm) s.
Proof.
exact (rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm_pointwise {m_tm : list nat} {n_tm : list nat}
  (xi_tm : fin m_tm -> fin n_tm) :
  pointwise_relation _ eq (ren_tm xi_tm)
    (subst_tm (funcomp (var_tm n_tm) xi_tm)).
Proof.
exact (fun s => rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma instId'_tm {m_tm : list nat} (s : tm m_tm) : subst_tm (var_tm m_tm) s = s.
Proof.
exact (idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma instId'_tm_pointwise {m_tm : list nat} :
  pointwise_relation _ eq (subst_tm (var_tm m_tm)) id.
Proof.
exact (fun s => idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm {m_tm : list nat} (s : tm m_tm) : ren_tm id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id s)).
Qed.

Lemma rinstId'_tm_pointwise {m_tm : list nat} :
  pointwise_relation _ eq (@ren_tm m_tm m_tm id) id.
Proof.
exact (fun s => eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id s)).
Qed.

Lemma varL'_tm {m_tm : list nat} {n_tm : list nat} (sigma_tm : fin m_tm -> tm n_tm)
  (x : fin m_tm) : subst_tm sigma_tm (var_tm m_tm x) = sigma_tm x.
Proof.
exact (eq_refl).
Qed.

Lemma varL'_tm_pointwise {m_tm : list nat} {n_tm : list nat}
  (sigma_tm : fin m_tm -> tm n_tm) :
  pointwise_relation _ eq (funcomp (subst_tm sigma_tm) (var_tm m_tm))
    sigma_tm.
Proof.
exact (fun x => eq_refl).
Qed.

Lemma varLRen'_tm {m_tm : list nat} {n_tm : list nat} (xi_tm : fin m_tm -> fin n_tm)
  (x : fin m_tm) : ren_tm xi_tm (var_tm m_tm x) = var_tm n_tm (xi_tm x).
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_tm_pointwise {m_tm : list nat} {n_tm : list nat}
  (xi_tm : fin m_tm -> fin n_tm) :
  pointwise_relation _ eq (funcomp (ren_tm xi_tm) (var_tm m_tm))
    (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (fun x => eq_refl).
Qed.

(* Class Up_tm X Y := *)
(*     up_tm : X -> Y. *)

(* Instance Subst_tm  {m_tm n_tm : nat}: (Subst1 _ _ _) := (@subst_tm m_tm n_tm). *)

(* Instance Up_tm_tm  {m n_tm : nat}: (Up_tm _ _) := (@up_tm_tm m n_tm). *)

(* Instance Ren_tm  {m_tm n_tm : nat}: (Ren1 _ _ _) := (@ren_tm m_tm n_tm). *)

(* Instance VarInstance_tm  {n_tm : nat}: (Var _ _) := (@var_tm n_tm). *)

(* Notation "[ sigma_tm ]" := (subst_tm sigma_tm) *)
(*   ( at level 1, left associativity, only printing) : fscope. *)

(* Notation "s [ sigma_tm ]" := (subst_tm sigma_tm s) *)
(*   ( at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "↑__tm" := up_tm (only printing) : subst_scope. *)

(* Notation "↑__tm" := up_tm_tm (only printing) : subst_scope. *)

(* Notation "⟨ xi_tm ⟩" := (ren_tm xi_tm) *)
(*   ( at level 1, left associativity, only printing) : fscope. *)

(* Notation "s ⟨ xi_tm ⟩" := (ren_tm xi_tm s) *)
(*   ( at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "'var'" := var_tm ( at level 1, only printing) : subst_scope. *)

(* Notation "x '__tm'" := (@ids _ _ VarInstance_tm x) *)
(*   ( at level 5, format "x __tm", only printing) : subst_scope. *)

(* Notation "x '__tm'" := (var_tm x) ( at level 5, format "x __tm") : *)
(*   subst_scope. *)

Instance subst_tm_morphism  {m_tm : list nat} {n_tm : list nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@subst_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => subst_tm f_tm s = subst_tm g_tm t')
         (ext_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Instance ren_tm_morphism  {m_tm : list nat} {n_tm : list nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@ren_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => ren_tm f_tm s = ren_tm g_tm t')
         (extRen_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

(* Ltac auto_unfold := repeat *)
(*                      unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1, *)
(*                       Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1. *)

(* Tactic Notation "auto_unfold" "in" "*" := repeat *)
(*                                            unfold VarInstance_tm, Var, ids, *)
(*                                             Ren_tm, Ren1, ren1, Up_tm_tm, *)
(*                                             Up_tm, up_tm, Subst_tm, Subst1, *)
(*                                             subst1 in *. *)

Ltac asimpl' := repeat (first
                 [ progress setoid_rewrite substSubst_tm_pointwise
                 | progress setoid_rewrite substSubst_tm
                 | progress setoid_rewrite renSubst_tm_pointwise
                 | progress setoid_rewrite renSubst_tm
                 | progress setoid_rewrite substRen_tm_pointwise
                 | progress setoid_rewrite substRen_tm
                 | progress setoid_rewrite renRen'_tm_pointwise
                 | progress setoid_rewrite renRen_tm
                 | progress setoid_rewrite varLRen'_tm_pointwise
                 | progress setoid_rewrite varLRen'_tm
                 | progress setoid_rewrite varL'_tm_pointwise
                 | progress setoid_rewrite varL'_tm
                 | progress setoid_rewrite rinstId'_tm_pointwise
                 | progress setoid_rewrite rinstId'_tm
                 | progress setoid_rewrite instId'_tm_pointwise
                 | progress setoid_rewrite instId'_tm
                 | progress
                    unfold up_tm_tm,
                     upRen_tm_tm, up_ren
                 | progress cbn[subst_tm ren_tm]
                   ]).

End renSubst.

Module fext.

Import
renSubst.

Require Import Coq.Logic.FunctionalExtensionality.

Lemma rinstInst_tm {m_tm : list nat} {n_tm : list nat} (xi_tm : fin m_tm -> fin n_tm) :
  ren_tm xi_tm = subst_tm (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => rinst_inst_tm xi_tm _ (fun n => eq_refl) x)).
Qed.

Lemma instId_tm {m_tm : list nat} : subst_tm (var_tm m_tm) = id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => idSubst_tm (var_tm m_tm) (fun n => eq_refl) (id x))).
Qed.

Lemma rinstId_tm {m_tm : list nat} : @ren_tm m_tm m_tm id = id.
Proof.
exact (eq_trans (rinstInst_tm (id _)) instId_tm).
Qed.

Lemma varL_tm {m_tm : list nat} {n_tm : list nat} (sigma_tm : fin m_tm -> tm n_tm) :
  funcomp (subst_tm sigma_tm) (var_tm m_tm) = sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma varLRen_tm {m_tm : list nat} {n_tm : list nat} (xi_tm : fin m_tm -> fin n_tm) :
  funcomp (ren_tm xi_tm) (var_tm m_tm) = funcomp (var_tm n_tm) xi_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma renRen'_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (ren_tm xi_tm) = ren_tm (funcomp zeta_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renRen_tm xi_tm zeta_tm n)).
Qed.

Lemma substRen'_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substRen_tm sigma_tm zeta_tm n)).
Qed.

Lemma renSubst'_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (ren_tm xi_tm) = subst_tm (funcomp tau_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renSubst_tm xi_tm tau_tm n)).
Qed.

Lemma substSubst'_tm {k_tm : list nat} {l_tm : list nat} {m_tm : list nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substSubst_tm sigma_tm tau_tm n)).
Qed.

Ltac asimpl_fext' := repeat (first
                      [ progress setoid_rewrite substSubst_tm_pointwise
                      | progress setoid_rewrite substSubst_tm
                      | progress setoid_rewrite renSubst_tm_pointwise
                      | progress setoid_rewrite renSubst_tm
                      | progress setoid_rewrite substRen_tm_pointwise
                      | progress setoid_rewrite substRen_tm
                      | progress setoid_rewrite renRen'_tm_pointwise
                      | progress setoid_rewrite renRen_tm
                      | progress setoid_rewrite substSubst'_tm
                      | progress setoid_rewrite renSubst'_tm
                      | progress setoid_rewrite substRen'_tm
                      | progress setoid_rewrite renRen'_tm
                      | progress setoid_rewrite varLRen_tm
                      | progress setoid_rewrite varL_tm
                      | progress setoid_rewrite rinstId_tm
                      | progress setoid_rewrite instId_tm
                      | progress
                         unfold up_tm_tm,
                          upRen_tm_tm, up_ren
                      | progress cbn[subst_tm ren_tm] ]).

End fext.

Module interface.

Export renSubst.

Export
fext.

Arguments var_tm {vs}.

Arguments lam {vs}.

Arguments app {vs}.

Hint Opaque subst_tm: rewrite.

Hint Opaque ren_tm: rewrite.

End interface.

Export interface.


(************************************************************************)
(*  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        *)
(************************************************************************)

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

Require Import Plus.
Require Import Mult.
Require Import Lt.
Open Local Scope nat_scope.

(** Factorial *)

Boxed Fixpoint fact (n:nat) : nat :=
  match n with
    | O => 1
    | S n => S n * fact n
  end.

Arguments Scope fact [nat_scope].

Lemma lt_O_fact : forall n:nat, 0 < fact n.
Proof.
  simple induction n; unfold lt in |- *; simpl in |- *; auto with arith.
Qed.

Lemma fact_neq_0 : forall n:nat, fact n <> 0.
Proof.
  intro.
  apply sym_not_eq.
  apply lt_O_neq.
  apply lt_O_fact.
Qed.

Lemma fact_le : forall n m:nat, n <= m -> fact n <= fact m.
Proof.
  induction 1.
  apply le_n.
  assert (1 * fact n <= S m * fact m).
  apply mult_le_compat.
  apply lt_le_S; apply lt_O_Sn.
  assumption.
  simpl (1 * fact n) in H0.
  rewrite <- plus_n_O in H0.
  assumption.
Qed.


(*********************************************************************************

 Limits of categories

 Contents:
 1. Final object
 2. Products
 3. Pullbacks
 4. Strict pullbacks
 5. Comma objects
 6. Inserters
 7. Equifiers
 8. Iso-inserters
 9. Eilenberg-Moore objects

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.categories.Dialgebras.
Require Import UniMath.CategoryTheory.categories.CatIsoInserter.
Require Import UniMath.CategoryTheory.categories.EilenbergMoore.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.IsoCommaCategory.
Require Import UniMath.CategoryTheory.CommaCategories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Products.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.CommaObjects.
Require Import UniMath.Bicategories.Limits.Inserters.
Require Import UniMath.Bicategories.Limits.Equifiers.
Require Import UniMath.Bicategories.Limits.IsoInserters.
Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats.

Local Open Scope cat.

(**
 1. Final object
 *)
Definition is_bifinal_cats
  : @is_bifinal bicat_of_univ_cats unit_category.
Proof.
  use make_is_bifinal.
  - exact (λ C, functor_to_unit (pr1 C)).
  - exact (λ C F G, unit_category_nat_trans F G).
  - intros Y f g α β.
    apply nat_trans_to_unit_eq.
Defined.

Definition bifinal_cats
  : bifinal_obj bicat_of_univ_cats
  := unit_category ,, is_bifinal_cats.

(**
 2. Products
 *)
Definition univ_cat_binprod_cone
           (C₁ C₂ : bicat_of_univ_cats)
  : binprod_cone C₁ C₂.
Proof.
  use make_binprod_cone.
  - exact (univalent_category_binproduct C₁ C₂).
  - apply pr1_functor.
  - apply pr2_functor.
Defined.

Section CatsBinprodUMP.
  Context (C₁ C₂ : bicat_of_univ_cats).

  Definition binprod_ump_1_univ_cat
    : binprod_ump_1 (univ_cat_binprod_cone C₁ C₂).
  Proof.
    intro q.
    use make_binprod_1cell.
    - exact (bindelta_pair_functor (binprod_cone_pr1 q) (binprod_cone_pr2 q)).
    - apply nat_z_iso_to_invertible_2cell.
      apply bindelta_pair_pr1_z_iso.
    - apply nat_z_iso_to_invertible_2cell.
      apply bindelta_pair_pr2_z_iso.
  Defined.

  Definition binprod_ump_2_cell_univ_cat
    : has_binprod_ump_2_cell (univ_cat_binprod_cone C₁ C₂).
  Proof.
    intros q F₁ F₂ α β ; cbn -[functor_composite] in *.
    use make_nat_trans.
    - exact (λ x, α x ,, β x).
    - intros x y f.
      use pathsdirprod.
      + apply (nat_trans_ax α).
      + apply (nat_trans_ax β).
  Defined.

  Definition binprod_ump_2_cell_pr1_univ_cat
    : has_binprod_ump_2_cell_pr1
        (univ_cat_binprod_cone C₁ C₂)
        binprod_ump_2_cell_univ_cat.
  Proof.
    intros q F₁ F₂ α β.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x ; cbn.
    apply idpath.
  Qed.

  Definition binprod_ump_2_cell_pr2_univ_cat
    : has_binprod_ump_2_cell_pr2
        (univ_cat_binprod_cone C₁ C₂)
        binprod_ump_2_cell_univ_cat.
  Proof.
    intros q F₁ F₂ α β.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x ; cbn.
    apply idpath.
  Qed.

  Definition binprod_ump_2_cell_unique_univ_cat
    : has_binprod_ump_2_cell_unique (univ_cat_binprod_cone C₁ C₂).
  Proof.
    intros q F₁ F₂ α β γ δ p₁ p₂ p₃ p₄.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use pathsdirprod.
    - exact (nat_trans_eq_pointwise p₁ x @ !(nat_trans_eq_pointwise p₃ x)).
    - exact (nat_trans_eq_pointwise p₂ x @ !(nat_trans_eq_pointwise p₄ x)).
  Qed.

  Definition has_binprod_ump_univ_cats
    : has_binprod_ump (univ_cat_binprod_cone C₁ C₂).
  Proof.
    use make_binprod_ump.
    - exact binprod_ump_1_univ_cat.
    - exact binprod_ump_2_cell_univ_cat.
    - exact binprod_ump_2_cell_pr1_univ_cat.
    - exact binprod_ump_2_cell_pr2_univ_cat.
    - exact binprod_ump_2_cell_unique_univ_cat.
  Defined.
End CatsBinprodUMP.

Definition has_binprod_bicat_of_univ_cats
  : has_binprod bicat_of_univ_cats.
Proof.
  intros C₁ C₂.
  simple refine (_ ,, _).
  - exact (univ_cat_binprod_cone C₁ C₂).
  - exact (has_binprod_ump_univ_cats C₁ C₂).
Defined.

(**
 3. Pullbacks
 *)
Definition iso_comma_pb_cone
           {C₁ C₂ C₃ : bicat_of_univ_cats}
           (F : C₁ --> C₃)
           (G : C₂ --> C₃)
  : pb_cone F G.
Proof.
  use make_pb_cone.
  - exact (univalent_iso_comma F G).
  - exact (iso_comma_pr1 F G).
  - exact (iso_comma_pr2 F G).
  - apply nat_z_iso_to_invertible_2cell.
    exact (iso_comma_commute F G).
Defined.

Section IsoCommaUMP.
  Context {C₁ C₂ C₃ : bicat_of_univ_cats}
          (F : C₁ --> C₃)
          (G : C₂ --> C₃).

  Definition pb_ump_1_iso_comma
    : pb_ump_1 (iso_comma_pb_cone F G).
  Proof.
    intro q.
    use make_pb_1cell.
    - use iso_comma_ump1.
      + exact (pb_cone_pr1 q).
      + exact (pb_cone_pr2 q).
      + apply invertible_2cell_to_nat_z_iso.
        exact (pb_cone_cell q).
    - apply nat_z_iso_to_invertible_2cell.
      apply iso_comma_ump1_pr1.
    - apply nat_z_iso_to_invertible_2cell.
      apply iso_comma_ump1_pr2.
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ; unfold pb_cone_cell ;
         rewrite (functor_id F), (functor_id G) ;
         rewrite !id_left, !id_right ;
         apply idpath).
  Defined.

  Section CellUMP.
    Let p := iso_comma_pb_cone F G.

    Context {q : bicat_of_univ_cats}
            (φ ψ : q --> p)
            (α : φ · pb_cone_pr1 p ==> ψ · pb_cone_pr1 p)
            (β : φ · pb_cone_pr2 p ==> ψ · pb_cone_pr2 p)
            (r : (φ ◃ pb_cone_cell p)
                 • lassociator _ _ _
                 • (β ▹ G)
                 • rassociator _ _ _
                 =
                 lassociator _ _ _
                 • (α ▹ F)
                 • rassociator _ _ _
                 • (ψ ◃ pb_cone_cell p)).

    Definition pb_ump_2_nat_trans
      : φ ==> ψ.
    Proof.
      use (iso_comma_ump2 _ _ _ _ α β).
      abstract
        (intros x ;
         pose (nat_trans_eq_pointwise r x) as z ;
         cbn in z ;
         unfold iso_comma_commute_nat_trans_data in z ;
         rewrite !id_left, !id_right in z ;
         exact z).
    Defined.

    Definition pb_ump_2_nat_trans_pr1
      : pb_ump_2_nat_trans ▹ pb_cone_pr1 (iso_comma_pb_cone F G) = α.
    Proof.
      apply iso_comma_ump2_pr1.
    Qed.

    Definition pb_ump_2_nat_trans_pr2
      : pb_ump_2_nat_trans ▹ pb_cone_pr2 (iso_comma_pb_cone F G) = β.
    Proof.
      apply iso_comma_ump2_pr2.
    Qed.
  End CellUMP.

  Definition pb_ump_2_iso_comma
    : pb_ump_2 (iso_comma_pb_cone F G).
  Proof.
    intros C φ ψ α β r.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros τ₁ τ₂ ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         exact (iso_comma_ump_eq _ _ _ _ α β (pr12 τ₁) (pr22 τ₁) (pr12 τ₂) (pr22 τ₂))).
    - simple refine (_ ,, _).
      + exact (pb_ump_2_nat_trans φ ψ α β r).
      + split.
        * exact (pb_ump_2_nat_trans_pr1 φ ψ α β r).
        * exact (pb_ump_2_nat_trans_pr2 φ ψ α β r).
  Defined.

  Definition iso_comma_has_pb_ump
    : has_pb_ump (iso_comma_pb_cone F G).
  Proof.
    split.
    - exact pb_ump_1_iso_comma.
    - exact pb_ump_2_iso_comma.
  Defined.
End IsoCommaUMP.

Definition has_pb_bicat_of_univ_cats
  : has_pb bicat_of_univ_cats.
Proof.
  intros C₁ C₂ C₃ F G.
  simple refine (_ ,, _).
  - exact (iso_comma_pb_cone F G).
  - exact (iso_comma_has_pb_ump F G).
Defined.

(**
 4. Strict pullbacks
 *)
Section ReindexingPullback.
  Context {C₁ C₂ : bicat_of_univ_cats}
          (F : C₁ --> C₂)
          (D₂ : disp_univalent_category (pr1 C₂))
          (HD₂ : iso_cleaving (pr1 D₂)).

  Let tot_D₂ : bicat_of_univ_cats
    := total_univalent_category D₂.
  Let pb : bicat_of_univ_cats
    := univalent_reindex_cat F D₂.
  Let π₁ : pb --> _
    := pr1_category _.
  Let π₂ : pb --> tot_D₂
    := total_functor (reindex_disp_cat_disp_functor F D₂).
  Let γ : invertible_2cell (π₁ · F) (π₂ · pr1_category D₂)
    := nat_z_iso_to_invertible_2cell
         (π₁ · F)
         (π₂ · pr1_category D₂)
         (total_functor_commute_z_iso (reindex_disp_cat_disp_functor F (pr1 D₂))).
  Let cone : pb_cone F (pr1_category _ : tot_D₂ --> C₂)
    := make_pb_cone pb π₁ π₂ γ.

  Definition reindexing_has_pb_ump_1_cell
             (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂))
    : q --> cone.
  Proof.
    use reindex_pb_ump_1.
    - exact HD₂.
    - exact (pb_cone_pr2 q).
    - exact (pb_cone_pr1 q).
    - apply invertible_2cell_to_nat_z_iso.
      exact (pb_cone_cell q).
  Defined.

  Definition reindexing_has_pb_ump_1_pr1
             (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂))
    : invertible_2cell
        (reindexing_has_pb_ump_1_cell q · pb_cone_pr1 cone)
        (pb_cone_pr1 q).
  Proof.
    use nat_z_iso_to_invertible_2cell.
    exact (reindex_pb_ump_1_pr1_nat_iso
             F D₂ HD₂
             (pb_cone_pr2 q)
             (pb_cone_pr1 q)
             (invertible_2cell_to_nat_z_iso
                _ _
                (pb_cone_cell q))).
  Defined.

  Definition reindexing_has_pb_ump_1_pr2
             (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂))
    : invertible_2cell
        (reindexing_has_pb_ump_1_cell q · pb_cone_pr2 cone)
        (pb_cone_pr2 q).
  Proof.
    use nat_z_iso_to_invertible_2cell.
    exact (reindex_pb_ump_1_pr2_nat_z_iso
             F D₂ HD₂
             (pb_cone_pr2 q)
             (pb_cone_pr1 q)
             (invertible_2cell_to_nat_z_iso
                _ _
                (pb_cone_cell q))).
  Defined.

  Definition reindexing_has_pb_ump_1_pb_cell
             (q : pb_cone F (pr1_category _ : tot_D₂ --> C₂))
    : reindexing_has_pb_ump_1_cell q ◃ pb_cone_cell cone
      =
      lassociator _ _ _
      • (reindexing_has_pb_ump_1_pr1 q ▹ F)
      • pb_cone_cell q
      • ((reindexing_has_pb_ump_1_pr2 q)^-1 ▹ _)
      • rassociator _ _ _.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    refine (!_).
    refine (id_right _ @ _).
    etrans.
    {
      do 2 refine (maponpaths (λ z, z · _) _).
      apply id_left.
    }
    etrans.
    {
      do 2 refine (maponpaths (λ z, z · _) _).
      exact (functor_id F _).
    }
    etrans.
    {
      refine (maponpaths (λ z, z · _) _).
      apply id_left.
    }
    etrans.
    {
      apply maponpaths.
      exact (inv_from_z_iso_in_total
               (is_invertible_2cell_to_is_nat_z_iso _ (pr2 (pb_cone_cell q)) x)
               _).
    }
    exact (nat_trans_eq_pointwise
             (vcomp_rinv
                (pb_cone_cell q))
             x).
  Qed.

  Definition reindexing_has_pb_ump_1
    : pb_ump_1 cone.
  Proof.
    intro q.
    use make_pb_1cell.
    - exact (reindexing_has_pb_ump_1_cell q).
    - exact (reindexing_has_pb_ump_1_pr1 q).
    - exact (reindexing_has_pb_ump_1_pr2 q).
    - exact (reindexing_has_pb_ump_1_pb_cell q).
  Defined.

  Definition reindexing_has_pb_ump_2
    : pb_ump_2 cone.
  Proof.
    intros C₀ G₁ G₂ τ₁ τ₂ p.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ;
         [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         exact (reindex_pb_ump_eq
                  _ _ _ _
                  τ₁ τ₂
                  _ _
                  (pr12 φ₁)
                  (pr22 φ₁)
                  (pr12 φ₂)
                  (pr22 φ₂))).
    - simple refine (_ ,, _ ,, _).
      + use reindex_pb_ump_2.
        * exact τ₁.
        * exact τ₂.
        * abstract
            (intro x ;
             pose (nat_trans_eq_pointwise p x) as q ;
             cbn in q ;
             rewrite !id_left, !id_right in q ;
             exact q).
      + apply reindex_pb_ump_2_pr1.
      + apply reindex_pb_ump_2_pr2.
  Defined.

  Definition reindexing_has_pb_ump
    : has_pb_ump cone.
  Proof.
    split.
    - exact reindexing_has_pb_ump_1.
    - exact reindexing_has_pb_ump_2.
  Defined.
End ReindexingPullback.

(**
 5. Comma objects
 *)
Section CommaObject.
  Context {C₁ C₂ C₃ : bicat_of_univ_cats}
          (F : C₁ --> C₃)
          (G : C₂ --> C₃).

  Definition comma_comma_cone
    : comma_cone F G.
  Proof.
    use make_comma_cone.
    - exact (univalent_comma F G).
    - exact (comma_pr1 F G).
    - exact (comma_pr2 F G).
    - exact (comma_commute F G).
  Defined.

  Definition comma_ump_1_comma
    : comma_ump_1 comma_comma_cone.
  Proof.
    intro q.
    use make_comma_1cell.
    - use comma_ump1.
      + exact (comma_cone_pr1 q).
      + exact (comma_cone_pr2 q).
      + exact (comma_cone_cell q).
    - apply nat_z_iso_to_invertible_2cell.
      apply comma_ump1_pr1.
    - apply nat_z_iso_to_invertible_2cell.
      apply comma_ump1_pr2.
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ; unfold pb_cone_cell ;
         rewrite (functor_id F), (functor_id G) ;
         rewrite !id_left, !id_right ;
         apply idpath).
  Defined.

  Section CellUMP.
    Let p := comma_comma_cone.

    Context {q : bicat_of_univ_cats}
            (φ ψ : q --> p)
            (α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p)
            (β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p)
            (r : (φ ◃ comma_cone_cell p)
                 • lassociator _ _ _
                 • (β ▹ G)
                 • rassociator _ _ _
                 =
                 lassociator _ _ _
                 • (α ▹ F)
                 • rassociator _ _ _
                 • (ψ ◃ comma_cone_cell p)).

    Definition comma_ump_2_nat_trans
      : φ ==> ψ.
    Proof.
      use (comma_ump2 _ _ _ _ α β).
      abstract
        (intros x ;
         pose (nat_trans_eq_pointwise r x) as z ;
         cbn in z ;
         unfold iso_comma_commute_nat_trans_data in z ;
         rewrite !id_left, !id_right in z ;
         exact z).
    Defined.

    Definition comma_ump_2_nat_trans_pr1
      : comma_ump_2_nat_trans ▹ comma_cone_pr1 comma_comma_cone = α.
    Proof.
      apply comma_ump2_pr1.
    Qed.

    Definition comma_ump_2_nat_trans_pr2
      : comma_ump_2_nat_trans ▹ comma_cone_pr2 comma_comma_cone = β.
    Proof.
      apply comma_ump2_pr2.
    Qed.
  End CellUMP.

  Definition comma_ump_2_comma
    : comma_ump_2 comma_comma_cone.
  Proof.
    intros C φ ψ α β r.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros τ₁ τ₂ ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         exact (comma_ump_eq_nat_trans
                  _ _ _ _
                  α β
                  (pr12 τ₁) (pr22 τ₁) (pr12 τ₂) (pr22 τ₂))).
    - simple refine (_ ,, _).
      + exact (comma_ump_2_nat_trans φ ψ α β r).
      + split.
        * exact (comma_ump_2_nat_trans_pr1 φ ψ α β r).
        * exact (comma_ump_2_nat_trans_pr2 φ ψ α β r).
  Defined.

  Definition comma_has_ump
    : has_comma_ump comma_comma_cone.
  Proof.
    split.
    - exact comma_ump_1_comma.
    - exact comma_ump_2_comma.
  Defined.
End CommaObject.

Definition has_comma_bicat_of_univ_cats
  : has_comma bicat_of_univ_cats
  := λ C₁ C₂ C₃ F G, comma_comma_cone F G ,, comma_has_ump F G.

(**
 6. Inserters
 *)
Definition dialgebra_inserter_cone
           {C₁ C₂ : bicat_of_univ_cats}
           (F G : C₁ --> C₂)
  : inserter_cone F G.
Proof.
  use make_inserter_cone.
  - exact (univalent_dialgebra F G).
  - exact (dialgebra_pr1 F G).
  - exact (dialgebra_nat_trans F G).
Defined.

Definition dialgebra_inserter_ump_1
           {C₁ C₂ : bicat_of_univ_cats}
           (F G : C₁ --> C₂)
  : has_inserter_ump_1 (dialgebra_inserter_cone F G).
Proof.
  intros q.
  use make_inserter_1cell.
  - exact (nat_trans_to_dialgebra
             (inserter_cone_pr1 q)
             (inserter_cone_cell q)).
  - use nat_z_iso_to_invertible_2cell.
    exact (nat_trans_to_dialgebra_pr1_nat_z_iso
             (inserter_cone_pr1 q)
             (inserter_cone_cell q)).
  - abstract
      (use nat_trans_eq ; [ apply homset_property | ] ;
       intro x ; cbn ;
       rewrite !(functor_id F), !(functor_id G) ;
       rewrite !id_left, !id_right ;
       apply idpath).
Defined.

Definition dialgebra_inserter_ump_2
           {C₁ C₂ : bicat_of_univ_cats}
           (F G : C₁ --> C₂)
  : has_inserter_ump_2 (dialgebra_inserter_cone F G).
Proof.
  intros C₀ K₁ K₂ α p.
  simple refine (_ ,, _).
  - apply (build_nat_trans_to_dialgebra K₁ K₂ α).
    abstract
      (intro x ;
       pose (nat_trans_eq_pointwise p x) as p' ;
       cbn in p' ;
       rewrite !id_left, !id_right in p' ;
       exact p').
  - abstract
      (use nat_trans_eq ; [ apply homset_property | ] ;
       intro x ; cbn ;
       apply idpath).
Defined.

Definition dialgebra_inserter_ump_eq
           {C₁ C₂ : bicat_of_univ_cats}
           (F G : C₁ --> C₂)
  : has_inserter_ump_eq (dialgebra_inserter_cone F G).
Proof.
  intros C₀ K₁ K₂ α p n₁ n₂ q₁ q₂.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x.
  use eq_dialgebra.
  exact (nat_trans_eq_pointwise q₁ x @ !(nat_trans_eq_pointwise q₂ x)).
Qed.

Definition has_inserters_bicat_of_univ_cats
  : has_inserters bicat_of_univ_cats.
Proof.
  intros C₁ C₂ F G.
  simple refine (univalent_dialgebra F G ,, _ ,, _ ,, _).
  - exact (dialgebra_pr1 F G).
  - exact (dialgebra_nat_trans F G).
  - refine (_ ,, _ ,, _).
    + exact (dialgebra_inserter_ump_1 F G).
    + exact (dialgebra_inserter_ump_2 F G).
    + exact (dialgebra_inserter_ump_eq F G).
Defined.

(**
 7. Equifiers
 *)
Section EquifiersCat.
  Context {C₁ C₂ : bicat_of_univ_cats}
          {F G : C₁ --> C₂}
          (n₁ n₂ : F ==> G).

  Definition equifier_bicat_of_univ_cats
    : bicat_of_univ_cats.
  Proof.
    use (subcategory_univalent C₁).
    intro x.
    use make_hProp.
    - exact (pr1 n₁ x = pr1 n₂ x).
    - apply homset_property.
  Defined.

  Definition equifier_bicat_of_univ_cats_pr1
    : equifier_bicat_of_univ_cats --> C₁
    := sub_precategory_inclusion _ _.

  Definition equifier_bicat_of_univ_cats_eq
    : equifier_bicat_of_univ_cats_pr1 ◃ n₁
      =
      equifier_bicat_of_univ_cats_pr1 ◃ n₂.
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    exact (pr2 x).
  Qed.

  Definition equifier_bicat_of_univ_cats_cone
    : equifier_cone F G n₁ n₂
    := make_equifier_cone
         equifier_bicat_of_univ_cats
         equifier_bicat_of_univ_cats_pr1
         equifier_bicat_of_univ_cats_eq.

  Section EquifierUMP1.
    Context (q : equifier_cone F G n₁ n₂).

    Definition equifier_bicat_of_univ_cats_ump_1_mor_data
      : functor_data
          (pr11 q)
          (pr1 equifier_bicat_of_univ_cats).
    Proof.
      use make_functor_data.
      - refine (λ x, pr1 (equifier_cone_pr1 q) x ,, _).
        exact (nat_trans_eq_pointwise (equifier_cone_eq q) x).
      - exact (λ x y f, # (pr1 (equifier_cone_pr1 q)) f ,, tt).
    Defined.

    Definition equifier_bicat_of_univ_cats_ump_1_mor_is_functor
      : is_functor equifier_bicat_of_univ_cats_ump_1_mor_data.
    Proof.
      split ; intro ; intros.
      - use subtypePath ; [ intro ; apply isapropunit | ] ; cbn.
        apply functor_id.
      - use subtypePath ; [ intro ; apply isapropunit | ] ; cbn.
        apply functor_comp.
    Qed.

    Definition equifier_bicat_of_univ_cats_ump_1_mor
      : q --> equifier_bicat_of_univ_cats_cone.
    Proof.
      use make_functor.
      - exact equifier_bicat_of_univ_cats_ump_1_mor_data.
      - exact equifier_bicat_of_univ_cats_ump_1_mor_is_functor.
    Defined.

    Definition equifier_bicat_of_univ_cats_ump_1_pr1
      : equifier_bicat_of_univ_cats_ump_1_mor ∙ equifier_bicat_of_univ_cats_pr1
        ⟹
        pr1 (equifier_cone_pr1 q).
    Proof.
      use make_nat_trans.
      - exact (λ _, identity _).
      - abstract
          (intros x y f ; cbn ;
           rewrite id_left, id_right ;
           apply idpath).
    Defined.

    Definition equifier_bicat_of_univ_cats_ump_1_pr1_nat_z_iso
      : nat_z_iso
          (equifier_bicat_of_univ_cats_ump_1_mor ∙ equifier_bicat_of_univ_cats_pr1)
          (equifier_cone_pr1 q).
    Proof.
      use make_nat_z_iso.
      - exact equifier_bicat_of_univ_cats_ump_1_pr1.
      - intro.
        apply identity_is_z_iso.
    Defined.
  End EquifierUMP1.

  Definition equifier_bicat_of_univ_cats_ump_1
    : has_equifier_ump_1 equifier_bicat_of_univ_cats_cone.
  Proof.
    intro q.
    use make_equifier_1cell.
    - exact (equifier_bicat_of_univ_cats_ump_1_mor q).
    - apply nat_z_iso_to_invertible_2cell.
      exact (equifier_bicat_of_univ_cats_ump_1_pr1_nat_z_iso q).
  Defined.

  Section EquifierUMP2.
    Context {C₀ : bicat_of_univ_cats}
            {K₁ K₂ : C₀ --> equifier_bicat_of_univ_cats_cone}
            (α : K₁ · equifier_cone_pr1 equifier_bicat_of_univ_cats_cone
                 ==>
                 K₂ · equifier_cone_pr1 equifier_bicat_of_univ_cats_cone).

    Definition equifier_bicat_of_univ_cats_ump_2_cell
      : K₁ ==> K₂.
    Proof.
      use make_nat_trans.
      - exact (λ x, pr1 α x ,, tt).
      - abstract
          (intros x y f ;
           use subtypePath ; [ intro ; apply isapropunit | ] ;
           cbn ;
           exact (nat_trans_ax α _ _ f)).
    Defined.

    Definition equifier_bicat_of_univ_cats_ump_2_eq
      : equifier_bicat_of_univ_cats_ump_2_cell ▹ _  = α.
    Proof.
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro x.
      apply idpath.
    Qed.
  End EquifierUMP2.

  Definition equifier_bicat_of_univ_cats_ump_2
    : has_equifier_ump_2 equifier_bicat_of_univ_cats_cone.
  Proof.
    intros C₀ K₁ K₂ α.
    simple refine (_ ,, _).
    - exact (equifier_bicat_of_univ_cats_ump_2_cell α).
    - exact (equifier_bicat_of_univ_cats_ump_2_eq α).
  Defined.

  Definition equifier_bicat_of_univ_cats_ump_eq
    : has_equifier_ump_eq equifier_bicat_of_univ_cats_cone.
  Proof.
    intros C₀ K₁ K₂ α β₁ β₂ p₁ p₂.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    exact (nat_trans_eq_pointwise p₁ x @ !(nat_trans_eq_pointwise p₂ x)).
  Qed.
End EquifiersCat.

Definition has_equifiers_bicat_of_univ_cats
  : has_equifiers bicat_of_univ_cats.
Proof.
  intros C₁ C₂ F G n₁ n₂.
  simple refine (_ ,, _ ,, _ ,, _).
  - exact (equifier_bicat_of_univ_cats n₁ n₂).
  - exact (equifier_bicat_of_univ_cats_pr1 n₁ n₂).
  - exact (equifier_bicat_of_univ_cats_eq n₁ n₂).
  - simple refine (_ ,, _ ,, _).
    + exact (equifier_bicat_of_univ_cats_ump_1 n₁ n₂).
    + exact (equifier_bicat_of_univ_cats_ump_2 n₁ n₂).
    + exact (equifier_bicat_of_univ_cats_ump_eq n₁ n₂).
Defined.

(**
 8. Iso-inserters
 *)
Definition iso_inserter_cone_bicat_of_univ_cats
           {C₁ C₂ : univalent_category}
           (F G : C₁ ⟶ C₂)
  : @iso_inserter_cone bicat_of_univ_cats _ _ F G.
Proof.
  use make_iso_inserter_cone.
  - exact (univalent_cat_iso_inserter F G).
  - exact (cat_iso_inserter_pr1 F G).
  - use nat_z_iso_to_invertible_2cell.
    exact (cat_iso_inserter_nat_iso F G).
Defined.

Definition iso_inserter_cone_bicat_of_univ_cats_ump_1
           {C₁ C₂ : univalent_category}
           (F G : C₁ ⟶ C₂)
  : has_iso_inserter_ump_1
      (iso_inserter_cone_bicat_of_univ_cats F G).
Proof.
  intros q.
  use make_iso_inserter_1cell.
  - refine (functor_to_cat_iso_inserter
              (iso_inserter_cone_pr1 q)
              _).
    apply invertible_2cell_to_nat_z_iso.
    exact (iso_inserter_cone_cell q).
  - apply nat_z_iso_to_invertible_2cell.
    apply functor_to_cat_iso_inserter_pr1_nat_z_iso.
  - abstract
      (use nat_trans_eq ; [ apply homset_property | ] ;
       intro x ; cbn ;
       rewrite (functor_id F), (functor_id G) ;
       rewrite !id_left, !id_right ;
       apply idpath).
Defined.

Definition iso_inserter_cone_bicat_of_univ_cats_ump_2
           {C₁ C₂ : univalent_category}
           (F G : C₁ ⟶ C₂)
  : has_iso_inserter_ump_2
      (iso_inserter_cone_bicat_of_univ_cats F G).
Proof.
  intros C₀ H₁ H₂ α p.
  simple refine (_ ,, _).
  - refine (nat_trans_to_cat_iso_inserter α _).
    abstract
      (intro x ;
       pose (nat_trans_eq_pointwise p x) as q ; cbn in q ;
       rewrite !id_left, !id_right in q ;
       exact q).
  - abstract
      (use nat_trans_eq ; [ apply homset_property | ] ;
       intro x ; cbn ;
       apply idpath).
Defined.

Definition iso_inserter_cone_bicat_of_univ_cats_ump_eq
           {C₁ C₂ : univalent_category}
           (F G : C₁ ⟶ C₂)
  : has_iso_inserter_ump_eq
      (iso_inserter_cone_bicat_of_univ_cats F G).
Proof.
  intros C₀ H₁ H₂ α p ζ₁ ζ₂ q₁ q₂.
  use nat_trans_eq.
  {
    apply homset_property.
  }
  intro x.
  use eq_cat_iso_inserter.
  refine (nat_trans_eq_pointwise q₁ x @ !_).
  exact (nat_trans_eq_pointwise q₂ x).
Qed.

Definition has_iso_inserters_bicat_of_univ_cats
  : has_iso_inserters bicat_of_univ_cats.
Proof.
  intros C₁ C₂ F G.
  simple refine (_ ,, _ ,, _ ,, _).
  - exact (univalent_cat_iso_inserter F G).
  - exact (cat_iso_inserter_pr1 F G).
  - use nat_z_iso_to_invertible_2cell.
    exact (cat_iso_inserter_nat_iso F G).
  - simple refine (_ ,, _ ,, _).
    + exact (iso_inserter_cone_bicat_of_univ_cats_ump_1 F G).
    + exact (iso_inserter_cone_bicat_of_univ_cats_ump_2 F G).
    + exact (iso_inserter_cone_bicat_of_univ_cats_ump_eq F G).
Defined.

(**
 9. Eilenberg-Moore objects
 *)
Section EilenbergMooreUMP.
  Context (m : mnd bicat_of_univ_cats).

  Let C : univalent_category := ob_of_mnd m.
  Let mC : Monad C := mnd_bicat_of_univ_cats_to_Monad m.

  Definition eilenberg_moore_cat_cone
    : em_cone m.
  Proof.
    use make_em_cone.
    - exact (eilenberg_moore_univalent_cat _ mC).
    - exact (eilenberg_moore_pr mC).
    - exact (eilenberg_moore_nat_trans mC).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite id_left ;
         exact (!(pr12 x))).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite (functor_id (endo_of_mnd m)) ;
         rewrite id_left, id_right ;
         exact (!(pr22 x))).
  Defined.

  Definition eilenberg_moore_cat_ump_1
    : em_ump_1 m eilenberg_moore_cat_cone.
  Proof.
    intro q.
    use make_em_cone_mor.
    - use functor_to_eilenberg_moore_cat.
      + exact (mor_of_mnd_mor (mor_of_em_cone _ q)).
      + exact (mnd_mor_endo (mor_of_em_cone _ q)).
      + abstract
          (intro x ;
           pose (nat_trans_eq_pointwise
                   (mnd_mor_unit (mor_of_em_cone _ q))
                   x) as p ;
           cbn in p ;
           rewrite (functor_id (mor_of_mnd_mor (mor_of_em_cone m q))) in p ;
           rewrite !id_left in p ;
           exact (!p)).
      + abstract
          (intro x ;
           pose (nat_trans_eq_pointwise
                   (mnd_mor_mu (mor_of_em_cone _ q))
                   x) as p ;
           cbn in p ;
           rewrite (functor_id (mor_of_mnd_mor (mor_of_em_cone m q))) in p ;
           rewrite !id_left, !id_right in p ;
           exact p).
    - use make_invertible_2cell.
      + use make_mnd_cell.
        * apply functor_to_eilenberg_moore_cat_pr.
        * abstract
            (use nat_trans_eq ; [ apply homset_property | ] ;
             intro x ; cbn ;
             rewrite (functor_id (endo_of_mnd m)) ;
             rewrite !id_left, !id_right ;
             apply idpath).
      + use is_invertible_mnd_2cell.
        use is_nat_z_iso_to_is_invertible_2cell.
        apply functor_to_eilenberg_moore_cat_pr_is_nat_z_iso.
  Defined.

  Definition eilenberg_moore_cat_ump_2
    : em_ump_2 m eilenberg_moore_cat_cone.
  Proof.
    intros C' F₁ F₂ α.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ; [ intro ; apply cellset_property | ] ;
         use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ;
         pose (nat_trans_eq_pointwise (maponpaths pr1 (pr2 φ₁)) x) as p₁ ;
         pose (nat_trans_eq_pointwise (maponpaths pr1 (pr2 φ₂)) x) as p₂ ;
         use eq_mor_eilenberg_moore ;
         exact (p₁ @ (!p₂))).
    - simple refine (_ ,, _).
      + use nat_trans_to_eilenberg_moore_cat.
        * exact (cell_of_mnd_cell α).
        * abstract
            (intro x ;
             pose (nat_trans_eq_pointwise (mnd_cell_endo α) x) as p ;
             simpl in p ;
             rewrite !id_left, !id_right in p ;
             unfold mor_of_eilenberg_moore_mor in p ;
             simpl in p ;
             rewrite !id_left, !id_right in p ;
             exact p).
      + abstract
          (use eq_mnd_cell ;
           use nat_trans_eq ; [ apply homset_property | ] ;
           intro x ;
           apply idpath).
  Defined.

  Definition eilenberg_moore_cat_ump
    : has_em_ump m eilenberg_moore_cat_cone.
  Proof.
    split.
    - exact eilenberg_moore_cat_ump_1.
    - exact eilenberg_moore_cat_ump_2.
  Defined.
End EilenbergMooreUMP.

Definition has_em_bicat_of_univ_cats
  : bicat_has_em bicat_of_univ_cats
  := λ m, eilenberg_moore_cat_cone m ,, eilenberg_moore_cat_ump m.


(*

 GOEDEL'S INCOMPLETENESS THEOREM

 Evgeny V Ivashkevich

 E-mail: ivashkev@yandex.ru

 April 13, 2019

 Abstract: In this file, we formalize the first chapter from
           Raymond Smullyan’s book “Goedel's Incompleteness Theorems”,
           where a simplified example of incompleteness is given.
           The entire text of the comments below is taken from the book.
*)

(*
   Let us consider a computing machine that prove and print
   out various expressions composed of the following
   symbols:
*)

Inductive symbol : Set :=
         | P   : symbol
         | PF  : symbol
         | NP  : symbol
         | NPF : symbol
         .

(*
   By an "expression", we mean any finite non-empty string
   of these symbols.
*)
Inductive expression : Set :=
         | one : symbol -> expression
         | app : expression -> expression -> expression
         .
Notation "# s" := (one s)(at level 60).
Notation "X [ Y ]" := (app X Y)(at level 60).

(*
   By the "norm" of an expression X, we shall mean the
   expression X [ X ] - e.g. the norm of PF is PF [ PF ].
*)
Definition norm (X : expression) : expression := X [ X ].

(*
   By "sentence" we mean any expression of one of the
   follwing four forms (X is any expression):
   (1) P [ X ]
   (2) PF [ X ]
   (3) NP [ X ]
   (4) NPF [ X ]
*)
Definition is_sentence (X : expression) : Prop
  := match X with
     | (# _) [ _ ] => True
     | _ => False
     end.

(*
   Any sentence has its head and tail.
*)
Fixpoint head (X : expression) : symbol
  := match X with
     | # s     => s
     | h [ t ] => head h
     end.

Definition tailSig (X : expression) :
  is_sentence X -> { Y : expression | X = #(head X) [ Y ] }.
Proof.
  intros H.
  destruct X as [ X0 | [ X1 | X2 ]]; simpl in *; try destruct H.
  exists X2. reflexivity.
Defined.

Definition tail (X : expression) (H : is_sentence X)
  := proj1_sig (tailSig X H).

(*
   An expression X is called "provable" if the machine can
   prove and print it. We assume the machine programmed so
   that any expression that the machine can prove will be
   printed sooner or later.
*)
Parameter provable : expression -> Prop.

(*
   Informally, P stands for "provable"; F stands for
   "the norm of" and N stands for "not". And so we define
   P [ X ] to be "true" if (and only if) X provable.
   We define PF [ X ] to be true if the "norm" of X is
   provable. We call NP [ X ] true iff X is not provable,
   and NPF [ X ] is defined to be true iff the norm of X
   is not provable. [This last sentence we read as
   "The norm of X is not provable".]
*)
Inductive true (X : expression) : Prop :=
         | tP (H : is_sentence X) :
             head X = P -> provable (tail X H) -> true X
         | tPF (H : is_sentence X) :
             head X = PF -> provable (norm (tail X H)) -> true X
         | tNP (H : is_sentence X) :
             head X = NP -> ~ provable (tail X H) -> true X
         | tNPF (H : is_sentence X) :
             head X = NPF -> ~ provable (norm (tail X H)) -> true X
         .
(*
   We have now given a perfectly precise definition of what
   it means for a sentence to be true, and we have here an
   interesting case of self-reference. The machine is
   printing out various sentences about what the machine
   can and cannot print, and so it is describing its own
   behavior!
*)

(*
   We are given that the machine is completely accurate
   in that all sentences proved and printed by the machine
   are true. And so, for example, if the machine ever
   prints P [ X ], then X really is provable (X will be
   printed by the machine sooner or later). Also, if
   PF [ X ] is provable, so is X [ X ] (the norm of X).
*)
Axiom provable_true :
  forall (X : expression),
  is_sentence X -> provable X -> true X.

(*
   Now, suppose X is provable. Does it follow that P [ X ]
   is provable? Not necessarily. If X is provable, then
   P [ X ] is certainly "true", but we are not given that
   the machine is capable of provin and printing all true
   sentences but only that the machine never prints any
   false ones.
*)
Lemma true_P :
  forall (X : expression),
  provable X
    <-> true ((# P) [ X ]).
Proof.
  split; intros.
  { assert (H0 : is_sentence ((# P) [X])). { simpl; auto. }
    eapply (tP ((# P) [X]) H0); simpl; auto.
    unfold tail, tailSig; simpl. destruct H0; simpl; auto.
  }
  { inversion H; try discriminate H1.
    assert (H3 : (tail ((# P) [X]) H0) = X).
    { unfold tail, tailSig; simpl; auto. destruct H0; simpl; auto. }
    rewrite H3 in H2; auto.
  }
Qed.
Lemma true_PF :
  forall (X : expression),
  provable (norm X)
    <-> true ((# PF) [ X ]).
Proof.
  split; intros.
  { assert (H0 : is_sentence ((# PF) [X])). { simpl; auto. }
    eapply (tPF ((# PF) [X]) H0); simpl; auto.
    unfold tail, tailSig; simpl. destruct H0; simpl; auto.
  }
  { inversion H; try discriminate H1.
    assert (H3 : (tail ((# PF) [X]) H0) = X).
    { unfold tail, tailSig; simpl; auto. destruct H0; simpl; auto. }
    rewrite H3 in H2; auto.
  }
Qed.
Lemma true_NP :
  forall (X : expression),
  ~ provable X
    <-> true ((# NP) [ X ]).
Proof.
  split; intros.
  { assert (H0 : is_sentence ((# P) [X])). { simpl; auto. }
    eapply (tNP ((# NP) [X]) H0); simpl; auto.
    unfold tail, tailSig; simpl. destruct H0; simpl; auto.
  }
  { inversion H; try discriminate H1.
    contradict H2.
    assert (H3 : (tail ((# NP) [X]) H0) = X).
    { unfold tail, tailSig; simpl; auto. destruct H0; simpl; auto. }
    rewrite H3; auto.
  }
Qed.
Lemma true_NPF :
  forall (X : expression),
  ~ provable (norm X)
    <-> true ((# NPF) [ X ]).
Proof.
  split; intros.
  { assert (H0 : is_sentence ((# NPF) [X])). { simpl; auto. }
    eapply (tNPF ((# NPF) [X]) H0); simpl; auto.
    unfold tail, tailSig; simpl. destruct H0; simpl; auto.
  }
  { inversion H; try discriminate H1.
    contradict H2.
    assert (H3 : (tail ((# NPF) [X]) H0) = X).
    { unfold tail, tailSig; simpl; auto. destruct H0; simpl; auto. }
    rewrite H3; auto.
  }
Qed.

(*
   Is it possible that the machine "can" prove and print
   all the true sentences? The answer is "no" and the
   problem is: Find a true sentence that the machine cannot
   prove and print.
*)
Definition Goedel := (# NPF) [ # NPF ].

(*
   The sentence is NPF [ NPF ]. By definition of "true",
   this sentence is true if and only if the norm of NPF
   is not provable and not printable. But the norm of NPF
   is the very sentence NPF [ NPF ]. And so the sentence
   is true if and only if it is not provable. This means
   that either the sentence is true and not provable, or
   it is provable and not true. The latter alternative
   violates the given hypothesis that the machine never
   prints sentences that are not true. Hence the sentence
   must be true, but the machine cannot print it.
*)
Lemma true_non_provable_Goedel :
  true Goedel <-> ~ provable Goedel.
Proof.
  unfold Goedel.
  split; intros; apply true_NPF; auto.
Qed.

Lemma provable_non_true_Goedel :
  provable Goedel -> ~ true Goedel.
Proof.
  unfold Goedel.
  intros. contradict H. apply true_NPF; auto.
Qed.

Theorem non_provable_Goedel :
  ~ provable Goedel.
Proof.
  intros H.
  assert (H0 : ~ true Goedel).
  { apply provable_non_true_Goedel; auto. }
  contradict H0.
  apply provable_true; auto.
  unfold Goedel. simpl; auto.
Qed.

Theorem true_Goedel :
  true Goedel.
Proof.
  apply true_non_provable_Goedel.
  apply non_provable_Goedel.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*           Definitions and lemmas about prime implicants  (Primes)        *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                             Prelude_Primes.v                             *)
(****************************************************************************)

Require Import Prelude_BDT.
Require Import CanonBDDs.rauzy.algorithme1.Boolean_functions.
Require Import CanonBDDs.rauzy.algorithme1.BDTs.
Require Import Prelude_Paths.
Require Import Prelude_Implicants.
Require Import Monotony.

Definition Prime (p : Path) (f : BF) :=
  Implicant p f /\
  (forall p' : Path, Implicant p' f -> Divides p' p -> Divides p p').

(*---------------           Prime of functions          --------------------*)

Lemma Prime_implicant :
 forall (p : Path) (f : BF), Prime p f -> Implicant p f.
Proof.
unfold Prime in |- *.
simple induction 1; auto with arith.
Qed.
Hint Resolve Prime_implicant.

Lemma Prime_ordered : forall (p : Path) (f : BF), Prime p f -> Ordered p.
Proof.
intros p f Hp.
elim (inv_Implicant p f (Prime_implicant p f Hp)); auto with arith.
Qed.

Lemma No_prime_FALSE : forall p : Path, ~ Prime p FALSE.
Proof.
intro p.
unfold Prime in |- *.
apply deMorgan_not_and.
left; exact (No_implicant_FALSE p).
Qed.

Lemma Nil_prime_of_TRUE : Prime Nil TRUE.
Proof.
unfold Prime in |- *.
split;
 [ apply Implicants_TRUE; trivial with arith
 | intros p H1p H2p; exact (Nil_divides_all p) ].
Qed.

Lemma Nil_only_prime_of_TRUE : forall p : Path, Prime p TRUE -> p = Nil.
Proof.
intro p.
unfold Prime in |- *.
simple induction 1; intros H1 H2; clear H.
apply (incl_nil_eq nat); change (Divides p Nil) in |- *.
apply H2;
 [ apply Implicants_TRUE; trivial with arith | exact (Nil_divides_all p) ].
Qed.

(*-----------           Prime of bdt functions               ----------*)

Lemma Vars_prime_le_dim :
 forall b : BDT,
 OBDT b -> forall p : Path, Prime p (Fun b) -> Head p <= Dim b.
Proof.
intros b HO p Hp.
elim (le_or_lt (Head p) (Dim b)); [ trivial with arith | intro Habsurde ].
elim (Nil_or_not_Nil p);
 [ intro H; rewrite H; auto with arith | simple induction 1; intros i Hi ].
absurd (Of (Head p) p); [ idtac | exact (Head_of_p_in_p p i Hi) ].
apply Contra with (Of (Head p) (Sub p (Head p)));
 [ idtac | exact (I_out_of_Sub_ip p (Head p)) ].
unfold Prime in Hp.
elim Hp; intros H1p H2p; clear Hp.
unfold Divides at 2 in H2p.
intro Hhead; apply H2p; try assumption.
  (* p-head(p) Implicant of Fun(b)  *)
exact (L14bis b HO p H1p (Head p) (lt_gt (Dim b) (Head p) Habsurde)).
  (* p-head(p) Divides p *)
exact (Of_sub_pi_of_p p (Head p)).
Qed.

Lemma Dim_highest_var_of_prime :
 forall b : BDT,
 OBDT b ->
 forall p : Path, Prime p (Fun b) -> forall i : nat, i > Dim b -> ~ Of i p.
Proof.
intros b HO p Hp i Hi.
unfold not in |- *; intro Habs.
absurd (i <= Dim b);
 [ exact (gt_not_le i (Dim b) Hi) | apply le_trans with (Head p) ].
exact (Head_max_of_ordered_path p (Prime_ordered p (Fun b) Hp) i Habs).
exact (Vars_prime_le_dim b HO p Hp).
Qed.

Lemma Prime_h_cons_ip_ordered :
 forall (i : nat) (h l : BDT),
 OBDT (Node i h l) -> forall p : Path, Prime p (Fun h) -> Ordered (Cons i p).
Proof.
intros i h l HO p Def_p.
apply Cons_ordered;
 [ exact (Prime_ordered p (Fun h) Def_p) | apply gt_le_trans with (Dim h) ].
elim (dim_node_dim_sons i h l HO); auto with arith.
apply Vars_prime_le_dim;
 [ elim (ordered_node_ordered_sons i h l HO); auto with arith | assumption ].
Qed.

(*-------                   From node to sons               -------------*)

Section Node_to_Sons.

Variable i : nat.
Variable h l : BDT.
Hypothesis HO : OBDT (Node i h l).
Hint Resolve HO.

Variable p : Path.

Remark Lb_4bis :
 Prime p (Fun (Node i h l)) -> Of i p -> forall j : nat, j > i -> ~ Of j p.
Proof.
intros Def_p Hi.
unfold Prime in Def_p; elim Def_p; intros H1 H2; clear Def_p.
unfold not in |- *; intros j H1j H2j.
absurd (Of j (Sub p j));
 [ exact (I_out_of_Sub_ip p j) | unfold Divides at 2 in H2 ].
apply H2;
 [ apply L14bis; auto with arith
 | unfold Divides in |- *; exact (Of_sub_pi_of_p p j)
 | assumption ].
Qed.

Remark Lc_4bis : Prime p (Fun (Node i h l)) -> Of i p -> i = Head p.
Proof.
intros Def_p Hi.
generalize Def_p.
unfold Prime in Def_p; elim Def_p; intros H1 H2.
(* Change (Prime p (Fun (Node i h l))) in Def_p. *)
clear Def_p; intro Def_p.
elim (inv_Implicant p (Fun (Node i h l)) H1); intros H11 H12.
apply La_4bis; try assumption.
exact (Lb_4bis Def_p Hi).
Qed.

Remark Ld_4bis :
 Prime p (Fun (Node i h l)) ->
 Of i p -> exists p' : Path, p = Cons i p' /\ Ordered (Cons i p').
Proof.
intros Def_p Hi.
generalize Def_p.
unfold Prime in Def_p; elim Def_p; intros H1 H2.
(* Change (Prime p (Fun (Node i h l))) in Def_p. *)
clear Def_p; intro Def_p.
elim (Tail_exists p i Hi); intros p' Def_p'.
exists p'; split; [ rewrite (Lc_4bis Def_p Hi); assumption | idtac ].
rewrite (Lc_4bis Def_p Hi).
rewrite <- Def_p'.
elim (inv_Implicant p (Fun (Node i h l)) H1); auto with arith.
Qed.

Remark Le_4bis :
 forall p : Path,
 Ordered (Cons i p) ->
 forall p' : Path,
 Implicant p' (Fun h) -> Divides p' p -> Ordered (Cons i p').
Proof.
intros p1 Hp p' H1p' H2p'.
apply Cons_ordered;
 [ elim (inv_Implicant p' (Fun h) H1p'); auto with arith | idtac ].
elim (Nil_or_not_Nil p').
     (* Case p'=Nil *)
intro Def_p'; rewrite Def_p'; simpl in |- *.
exact (Dim_node_gt_O i h l HO).
    (* Case p'=/=Nil *)
simple induction 1; intros k Def_k.
apply gt_le_trans with (Head p1).
elim (p_inv_Ordered (Cons i p1) Hp); auto with arith.
apply Head_max_of_ordered_path.
elim (p_inv_Ordered (Cons i p1) Hp); auto with arith.
unfold Divides in H2p'.
apply H2p'.
apply Head_of_p_in_p with k; assumption.
Qed.

Lemma L4bis :
 Prime p (Fun (Node i h l)) ->
 Of i p -> exists p' : Path, p = Cons i p' /\ Prime p' (Fun h).
Proof.
intros Def_p Hi.
generalize Def_p.
unfold Prime in Def_p; elim Def_p; intros H1 H2.
(* Change (Prime p (Fun (Node i h l))) in Def_p. *)
clear Def_p; intro Def_p.
elim (Ld_4bis Def_p Hi).
intros p' Hp'.
elim Hp'; intros Def_p' H.
exists p'; split; [ elim Hp'; auto with arith | idtac ].
unfold Prime in |- *; split.
(*--- (Implicant p' (Fun h)) ---*)
apply L40 with i l; [ auto with arith | idtac ].
rewrite <- Def_p'; assumption.
(*--- p' least implicant of (Fun h) ---*)
intros p'' H1p'' H2p''.
apply Divides_cons_divides_tail with i; [ assumption | idtac | idtac ].
(* (Ordered (Cons i p'')) *)
exact (Le_4bis p' H p'' H1p'' H2p'').
(* (Divides (Cons i p') (Cons i p'')) *)
elim Def_p'; apply H2.
apply L2; auto with arith.
elim (p_inv_Ordered (Cons i p'') (Le_4bis p' H p'' H1p'' H2p''));
 auto with arith.
rewrite Def_p'; apply Divides_tail_divides_cons; trivial with arith.
Qed.

Lemma L5bis : Prime p (Fun (Node i h l)) -> ~ Of i p -> Prime p (Fun l).
Proof.
intros Def_p Hi.
unfold Prime in Def_p; elim Def_p; intros H1 H2; clear Def_p.
unfold Prime in |- *; split;
 [ apply L5 with i h; assumption | intros p' H1p' H2p' ].
apply H2;
 [ apply L10; [ apply L80 with p; trivial with arith | assumption ]
 | assumption ].
Qed.

Lemma L12 : Prime (Cons i p) (Fun (Node i h l)) -> ~ Implicant p (Fun l).
Proof.
intro Def_p.
unfold not in |- *; intro Habsurde.
unfold Prime in Def_p; elim Def_p; intros H1 H2; clear Def_p.
absurd (Of i p).
(*  ~(Of i p)  *)
apply L11.
elim (inv_Implicant (Cons i p) (Fun (Node i h l)) H1); auto with arith.
(*   (Of i p)  *)
unfold Divides at 2 in H2.
apply H2; [ idtac | unfold Divides in |- *; auto with arith | auto with arith ].
apply L10; auto with arith.
apply L11.
elim (inv_Implicant (Cons i p) (Fun (Node i h l)) H1); auto with arith.
Qed.

End Node_to_Sons.

(*-------------              From sons to node              ---------------*)

Section Sons_to_Node.

Variable i : nat.
Variable h l : BDT.
Hypothesis HO : OBDT (Node i h l).
Hint Resolve HO.

Variable p : Path.

Lemma Prime_l_prime_node : Prime p (Fun l) -> Prime p (Fun (Node i h l)).
Proof.
unfold Prime in |- *; simple induction 1; intros H1p H2p; clear H.
split.
  (* p Implicant of Fun(Node) *)
apply (L10 i h l p); try assumption.
apply (Dim_highest_var_of_prime l);
 [ elim (ordered_node_ordered_sons i h l HO); auto with arith
 | unfold Prime in |- *; auto with arith
 | elim (dim_node_dim_sons i h l HO); auto with arith ].
  (* p smallest *)
intros p' H1p' H2p'.
apply H2p; try assumption.
apply (L5 i h l p' H1p').
apply Contra with (Of i p);
 [ unfold Divides in H2p'; exact (H2p' i) | idtac ].
apply (Dim_highest_var_of_prime l);
 [ elim (ordered_node_ordered_sons i h l HO); auto with arith
 | unfold Prime in |- *; auto with arith
 | elim (dim_node_dim_sons i h l HO); auto with arith ].
Qed.

Lemma Prime_h_prime_node :
 Prime p (Fun h) ->
 Monotonic (Fun l) ->
 ~ Implicant p (Fun l) -> Prime (Cons i p) (Fun (Node i h l)).
Proof.
intros H1p Hmon H2p.
unfold Prime in H1p; elim H1p; intros H1p_impl H1p_min; clear H1p.
unfold Prime in |- *; split.
(* Implicant *)
apply (L2 i h l HO p H1p_impl).
apply gt_le_trans with (Dim h);
 [ elim (dim_node_dim_sons i h l HO); trivial with arith
 | apply Vars_prime_le_dim ].
elim (ordered_node_ordered_sons i h l); auto with arith.
unfold Prime in |- *; auto with arith.
(* smallest *)
intros p' H1p' H2p'.
elim (Of_path_dec p' i); intro Cas.
  (*-- i in p' --*)
elim (Ordered_divisor_of_cons_ip i p) with p';
 [ intros tl' Def_tl'
 | apply (Prime_h_cons_ip_ordered i h l HO); unfold Prime in |- *;
    auto with arith
 | assumption
 | elim (inv_Implicant p' (Fun (Node i h l)) H1p'); auto with arith
 | assumption ].
rewrite Def_tl'; apply Divides_tail_divides_cons.
apply H1p_min;
 [ apply (L40 i h l HO); elim Def_tl'; assumption
 | apply Divides_cons_divides_tail with i ].
elim Def_tl'; elim (inv_Implicant p' (Fun (Node i h l)) H1p'); auto with arith.
apply (Prime_h_cons_ip_ordered i h l HO); unfold Prime in |- *; auto with arith.
elim Def_tl'; assumption.
  (*-- i not in p' --*)
absurd (Implicant p (Fun l));
 [ assumption | apply Divides_implic_implic with p' ].
assumption.
exact (L5 i h l p' H1p' Cas).
exact (L8 p' p i H2p' Cas).
elim (inv_Implicant p (Fun h) H1p_impl); auto with arith.
Qed.

End Sons_to_Node.

Lemma Prime_exists :
 forall b : BDT, OBDT b -> b <> Zero -> exists p : Path, Prime p (Fun b).
Proof.
simple induction 1.
(* b=Zero *)
simple induction 1; trivial with arith.
(* b=One  *)
intro H1; exists Nil; simpl in |- *; exact Nil_prime_of_TRUE.
(* b=Node *)
clear H b;
 intros bh bl HObh Hrec_bh HObl Hrec_bl i H1i H2i Hneq_sons Hneq_rec.
elim (eq_BDT_decidable bl Zero); intro Cas_bl.
  (*-- bl=Zero --*)
elim (eq_BDT_decidable bh Zero); intro Cas_bh.
      (*-- bh=Zero --*)
absurd (bh = bl);
 [ assumption | rewrite Cas_bh; rewrite Cas_bl; trivial with arith ].
      (*-- bh=/=Zero --*)
elim (Hrec_bh Cas_bh); intros ph Def_ph.
exists (Cons i ph).
apply (Prime_h_prime_node i bh bl) with (p := ph);
 [ auto with arith
 | assumption
 | rewrite Cas_bl; simpl in |- *; exact (Fcst_monotonic false)
 | rewrite Cas_bl; simpl in |- *; exact (No_implicant_FALSE ph) ].
  (*-- bl=/=Zero --*)
elim (Hrec_bl Cas_bl); intros pl Def_pl.
exists pl.
apply (Prime_l_prime_node i bh bl) with (p := pl); auto with arith.
Qed.


Require Import Reals.
Require Import Nsatz.

Open Scope R_scope.

Definition Real := R.

(* declare variables in height drop rule. *)
(*
   H0 is the height at the start of dropping;
   H is the height at the end of first stage in dropping;
   Hd1 is the speed during dropping of first stage;
   Hd2 is the accelerate speed during first stage dropping;
   t is the time in dropping.
*)
Variables H0 Hd2 t : R.

Definition H := H0 - /2 * Hd2 * t * t.

(* speed of helicopter during dropping. *)
Definition Hd1 := Hd2 * t.

(* the height of drop at first stage. *)
Definition deltaH := H0 - H.

(* INR 2 is the injection of the natural number 2 into R. *)

Lemma inr_two_not_zero : (INR 2 <> 0).
apply not_0_INR.
auto.
Qed.

Lemma two_eq_two : INR 2 = 2.
auto.
Qed.

(* real number 2 is not equal to real number 0. *)
Lemma two_not_zero : 2<>0.
rewrite <- two_eq_two.
apply inr_two_not_zero.
Qed.

Lemma zero_less_than_inr_two : (0 < INR 2).
apply lt_0_INR.
auto.
Qed.

(* real number 2 is not equal to real number 0. *)
Lemma zero_less_than_two : 0<2.
rewrite <- two_eq_two.
apply zero_less_than_inr_two.
Qed.

Lemma two_larger_than_zero : 2>0.
apply Rlt_gt.
apply zero_less_than_two.
Qed.

Lemma two_not_eq_zero : 2<>0.
apply Rgt_not_eq.
apply two_larger_than_zero.
Qed.

Lemma two_times_r : forall r, r>0 -> 2*r > 0.
intros.
apply Rmult_gt_0_compat.
apply two_larger_than_zero.
assumption.
Qed.

Lemma drop_height_aux :  (H0 - H) * (2 * Hd2) = Hd1 * Hd1 .
unfold H.
unfold Hd1.
ring_simplify. (* simplify expressions on a ring *)
rewrite Rinv_r.
ring.
apply two_not_zero.
Qed.

Lemma mul_2_div : forall (r x y: R), r<>0 -> x * r = y -> x = y * / r.
intros.
rewrite <- H2.
rewrite Rinv_r_simpl_l.
auto.
assumption.
Qed.

Lemma div_div : forall x y, x / y = x * /y.
auto.
Qed.

Lemma mul_2_div1 : forall (r x y: R), r<>0 -> x * r = y -> x = y / r.
intros.
rewrite div_div.
apply mul_2_div.
auto.
assumption.
Qed.

(* lemma for computing deltaH. *)
Lemma drop_height : Hd2 > 0 -> H0 - H = Hd1 * Hd1 / (2 * Hd2).
intro.
apply mul_2_div.
apply Rgt_not_eq.
apply two_times_r.
assumption.
apply drop_height_aux.
Qed.