Add LoadPath "C:/Coq/buffer".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Export Maps.

(*computation is a sequence of states, each adjacent pair of which
  is a transition. A program defines a form of its states, the set
  of transitions between states, and the set of computations it c-
  an produce *)

(*state is a function from string to bool defined for all inputs, default false *)
Definition state := total_map bool.
Definition empty_state : state := t_empty false.

Definition P : id := Id "P".
Definition Q : id := Id "Q".
Definition R : id := Id "R".
Definition S : id := Id "S".

Inductive atom : Type :=
| AVal : bool -> atom
| AVar : id -> atom.

Notation "^a A" := (AVal A) (at level 30).
Notation "^s A" := (AVar A) (at level 30).

Inductive formula : Type :=
| FAto : atom -> formula
| FNot : formula -> formula
| FOr : formula -> formula -> formula
| FAnd : formula -> formula -> formula
| FImp : formula -> formula -> formula
| FIff : formula -> formula -> formula.

(*somewhat clumsey using the ^ before every declaration*)
Notation "^~ A" := (FNot A) (at level 40).
Notation "A '^\/' B" := (FOr A B) (at level 60, right associativity).
Notation "A '^/\' B" := (FAnd A B) (at level 55, right associativity).
Notation "A '^->' B" := (FImp A B) (at level 65, right associativity).
Notation "A '^<->' B" := (FIff A B) (at level 70, right associativity).
Notation "^*? P" := (FAto P) (at level 35).
Notation "^* P" := (FAto (AVar P)) (at level 35).
Notation "^** P" := (FAto (AVal P)) (at level 35).

Reserved Notation  "A '<S' B" (at level 50, left associativity).

Inductive subformula : formula -> formula -> Prop :=
| sub_lit : forall l,
    FAto l <S FAto l
| sub_not : forall s f,
    s <S f -> s <S FNot f
| sub_orL : forall s f1 f2,
    s <S f1 -> s <S FOr f1 f2
| sub_orR : forall s f1 f2,
    s <S f2 -> s <S FOr f1 f2
| sub_andL : forall s f1 f2,
    s <S f1 -> s <S FAnd f1 f2
| sub_andR : forall s f1 f2,
    s <S f2 -> s <S FAnd f1 f2
| sub_impL : forall s f1 f2,
    s <S f1 -> s <S FImp f1 f2
| sub_impR : forall s f1 f2,
    s <S f2 -> s <S FImp f1 f2
| sub_iffL : forall s f1 f2,
    s <S f1 -> s <S FIff f1 f2
| sub_iffR : forall s f1 f2,
    s <S f2 -> s <S FIff f1 f2
| sub_triv : forall f1 f2,
    f1 = f2 -> f1 <S f2
(* f1 <S f1 *)
 where "A '<S' B" := (subformula A B) : type_scope.

Definition strict_subformula (f1 f2 : formula) : Prop :=
 f1 <> f2 /\ f1 <S f2.
Notation "A '<<S' B" := (strict_subformula A B) (at level 50, left associativity).

Module ex1p1.
  Definition f := ( ^*P ^/\ ^*Q) ^-> ( ^*P ^\/ (^~ ^*Q)).
  Definition s1 := ( ^*P ^/\ ^*Q).
  Definition s2 := (^~ ^*Q).
  Definition s3 := ( ^*P ^\/ ^~ ^*Q).
  Definition s4 := ^*P.
  Definition s5 := ^*Q.

  Example ex1p11 : f <S f.
  Proof. apply sub_triv. reflexivity.
  Qed.

  Example ex1p12 : s1 <<S f.
  Proof. unfold strict_subformula. split.
         -unfold not. intros. inversion H.
         -apply sub_impL. apply sub_triv. reflexivity.
  Qed.

  Example ex1p13 : s2 <<S f.
  Proof. unfold strict_subformula. split.
         -unfold not. intros. inversion H.
         -apply sub_impR. apply sub_orR. apply sub_triv. reflexivity.
  Qed.

  Example ex1p14 : s3 <<S f.
  Proof. unfold strict_subformula. split.
         -unfold not. intros. inversion H.
         -apply sub_impR. apply sub_triv. reflexivity.
  Qed.

  Example ex1p15 : s4 <<S f.
  Proof. unfold strict_subformula. split.
         -unfold not. intros. inversion H.
         -apply sub_impL. apply sub_andL. apply sub_triv. reflexivity.
   Qed.

  Example ex1p16 : s5 <<S f.
  Proof. unfold strict_subformula. split.
         -unfold not. intros. inversion H.
         -apply sub_impR. apply sub_orR. apply sub_not.
          apply sub_triv. reflexivity.
   Qed.
End ex1p1.

(*takes a list of (id, bool) pairs and returns a state*)
Definition IList : Type := list (id * bool).
Fixpoint interpret (I : IList) : state :=
  match I with
  | nil => empty_state
  | h :: t => (t_update (interpret t) (fst h) (snd h))
  end.

(*had choice between using boolean functions and if then else statements
  does it matter which one? Was worried that excluded middle would be a
  problem*)
Fixpoint eval_formula (st : state) (f : formula) : bool :=
  match f with
  | FAto a =>
    match a with
    | AVar a' => st a'
    | AVal a' => a'
    end
  | FNot A => if (eval_formula st A) then false else true
  | FOr A B =>  if (eval_formula st A) then true else (eval_formula st B)
  | FAnd A B => if (eval_formula st A) then (eval_formula st B) else false
  | FImp A B => if (eval_formula st A) then (eval_formula st B) else true
  | FIff A B => match (eval_formula st A) with
                | true => (eval_formula st B)
                | false => if (eval_formula st B) then false else true
                end
  end.

(*I am really happy with this notation *)
Notation " I |= f " := (eval_formula (interpret I) f = true) (at level 80).
Notation " I |/= f " := (eval_formula (interpret I) f = false) (at level 80).
(* this applies a formula to an interpretation, treating the interpretation as
   the function it is, and extending the domain of that function from strings
   to formulas *)
Notation "I ^* F" := (eval_formula I F) (at level 35).

Example ex1p3 : [(P,true);(Q,false)] |= (( ^*P ^/\ ^*Q) ^-> ( ^*P ^\/ ^~ ^*Q)).
Proof. reflexivity. Qed.

Theorem Ftrue_is_true : forall I, I |= ^**true.
Proof. intros I. reflexivity. Qed.

Theorem Ffalse_is_false : forall I, I |/= ^**false.
Proof. intros I. reflexivity. Qed.

Theorem Fvar_true_iff_true : forall I P,  I |= ^*P <-> interpret I P = true.
Proof. intros I P. split; try (intros H; simpl in H; apply H). Qed.

Theorem Fvar_false_iff_false : forall I P,  I |/= ^*P <-> interpret I P = false.
Proof. intros I P. split; try (intros H; simpl in H; apply H). Qed.
Theorem Fnot_true_iff : forall I F, I |= ^~ F <-> I |/= F.
Proof. intros I F. split.
       -intros H. simpl in H. apply negb_true_iff. rewrite <- H. reflexivity.
       -intros H. simpl. rewrite H. reflexivity.
Qed.

Theorem Fand_true_iff : forall I F1 F2, I |= F1 ^/\ F2 <-> I |= F1 /\ I |= F2.
Proof. intros I F1 F2. split.
       -intros H. simpl in H. apply andb_true_iff in H. apply H.
       -intros H. apply andb_true_iff. apply H.
Qed.

Theorem For_true_iff : forall I F1 F2, I |= F1 ^\/ F2 <-> I |= F1 \/ I |= F2.
Proof. intros I F1 F2. split.
       -intros H. simpl in H. apply orb_true_iff in H. apply H.
       -intros H. apply orb_true_iff. apply H.
Qed.

Lemma Fdemorgans : forall I F1 F2, I |= F1 ^/\ F2 <-> I |/= ^~ F1 ^\/ ^~ F2.
Proof. intros I F1 F2. split.
       -intros H. rewrite <- negb_false_iff in H. rewrite <- H. simpl.
        destruct (interpret I ^* F1). destruct (interpret I^*F2).
        reflexivity. reflexivity. reflexivity.
       -intros H. rewrite <- negb_false_iff. rewrite <- H. simpl.
        destruct (interpret I ^* F1). destruct (interpret I^*F2).
        reflexivity. reflexivity. reflexivity.
Qed.

Theorem Fnot_true_double_elim : forall I F, I |= F <-> I |= ^~ ^~ F.
Proof. intros I F. split;
       intros H; rewrite <- H; simpl; destruct (interpret I ^* F); try reflexivity.
Qed.

Theorem Fnot_false_double_elim : forall I F, I |/= F <-> I |/= ^~^~ F.
Proof. intros I F. split;
       intros H; rewrite <- H; simpl; destruct (interpret I ^* F); try reflexivity.
Qed.

Theorem For_false_elimL : forall I F1 F2, I |/= F1 ^\/ F2 -> I |/= F1.
Proof. intros I F1 F2 H. rewrite <- not_true_iff_false. unfold not.
       intros H1. rewrite <- not_true_iff_false in H. apply H.
       apply For_true_iff. left. apply H1.
Qed.

Theorem For_false_elimR : forall I F1 F2, I |/= F1 ^\/ F2 -> I |/= F2.
Proof. intros I F1 F2 H. rewrite <- not_true_iff_false. unfold not.
       intros H1. rewrite <- not_true_iff_false in H. apply H.
       apply For_true_iff. right. apply H1.
Qed.

Theorem For_false_iff : forall I F1 F2, I |/= F1 ^\/ F2 <-> I |/= F1 /\ I |/= F2.
Proof. intros I F1 F2. split.
       -intros H. split. apply For_false_elimL in H. apply H.
        apply For_false_elimR in H. apply H.
       -intros [H H1]. apply not_true_iff_false. intros H2.
        apply For_true_iff in H2. destruct H2.
        *apply not_true_iff_false in H. apply H. apply H0.
        *apply not_true_iff_false in H1. apply H1. apply H0.
Qed.

Theorem Fimp_true_iff : forall I F1 F2, I |= F1 ^-> F2 <-> (I |= F1 -> I |= F2).
Proof. intros I F1 F2. split.
       -intros H HF1. simpl in H. rewrite HF1 in H. apply H.
       -intros H. simpl. destruct (eval_formula (interpret I) F1).
        apply H. reflexivity. reflexivity.
Qed.

Theorem Fimp_true_elim : forall I F1 F2, I |= F1 ^-> F2 <-> I |/= F1 \/ I |= F2.
Proof. intros I F1 F2. split.
       -intros H. rewrite <- Fnot_true_iff. apply For_true_iff.
        rewrite <- H. simpl. destruct (interpret I ^* F1).
        reflexivity. reflexivity.
       -intros H. destruct H. apply Fimp_true_iff. intros contra.
        rewrite contra in H. inversion H.
        apply Fimp_true_iff. intros H1. apply H.
Qed.

Theorem Fimp_false_elim : forall I F1 F2, I |/= F1 ^-> F2 <-> I |= F1 /\ I |/= F2.
Proof. intros I F1 F2. split.
       -intros H. rewrite <- Fnot_true_iff. apply Fand_true_iff.
        rewrite <-  negb_false_iff. rewrite <- H. simpl.
        destruct (interpret I ^* F1); destruct (interpret I ^* F2); reflexivity.
       -intros H. apply not_true_iff_false. intros H1. destruct H.
        apply not_true_iff_false in H0. apply H0. rewrite Fimp_true_iff in H1.
        apply H1 in H. apply H.
Qed.

Theorem Fiff_true_iff : forall I F1 F2, I |= F1 ^<-> F2 <-> (I |= F1 <-> I |= F2).
Proof. split.
       -intros. split.
        +intros. simpl in H. rewrite H0 in H. apply H.
        +intros. simpl in H. destruct (eval_formula (interpret I) F1). reflexivity.
         rewrite H0 in H. inversion H.
       -intros. simpl. destruct (eval_formula (interpret I) F1). apply H. reflexivity.
        destruct H. destruct (eval_formula (interpret I) F2). apply H0. reflexivity.
        reflexivity.
Qed.

Theorem Fiff_iff_Fimp : forall I F1 F2, I |= F1 ^-> F2 /\ I |= F2 ^-> F1 <-> I |= F1 ^<-> F2.
Proof. intros I F1 F2. split.
       -intros H. destruct H. apply Fiff_true_iff. split.
        +apply Fimp_true_iff. apply H.
        +apply Fimp_true_iff. apply H0.
       -intros. split; apply Fiff_true_iff in H; destruct H; apply Fimp_true_iff.
        +apply H.
        +apply H0.
Qed.

Theorem Fiff_true_elim : forall I F1 F2,
    I |= F1 ^<-> F2 <-> I |= F1 ^/\ F2 \/ I |/= F1 ^\/ F2.
Proof. intros I F1 F2. split.
       -intros H. rewrite <- Fnot_true_iff. apply For_true_iff.
        rewrite <- H. simpl. destruct (interpret I ^* F1);
        destruct (interpret I ^* F2); reflexivity.
       -intros H. rewrite <- Fnot_true_iff in H. apply For_true_iff in H.
        rewrite <- H. simpl. destruct (interpret I ^* F1);
        destruct (interpret I ^* F2); reflexivity.
Qed.

Theorem Fiff_false_elim : forall I F1 F2,
    I |/= F1 ^<-> F2 <-> I |= F1 ^/\ ^~ F2 \/ I |= ^~F1 ^/\ F2.
Proof. intros I F1 F2. split.
       -intros H. apply For_true_iff. apply Fnot_true_iff in H.
        rewrite <- H. simpl. destruct (interpret I ^* F1);
        destruct (interpret I ^* F2); reflexivity.
       -intros H. apply Fnot_true_iff. apply For_true_iff in H.
        rewrite <- H. simpl. destruct (interpret I ^* F1);
        destruct (interpret I ^* F2); reflexivity.
Qed.

Theorem Fand_false_iff : forall I F1 F2, I |/= F1 ^/\ F2 <-> I |/= F1 \/ I |/= F2.
Proof. intros I F1 F2. split.
       -intros H. simpl. simpl in H. destruct (interpret I ^*F1). right. apply H. left. reflexivity.
       -intros H. simpl. simpl in H. destruct H. rewrite H. reflexivity. rewrite H. destruct (interpret I ^*F1); reflexivity.
Qed.

Theorem Fand_false_introL : forall I F1, I |/= F1 -> (forall F2, I |/= F1 ^/\ F2).
Proof. intros I F1 H F2.
       apply Fand_false_iff. left. apply H.
Qed.

Theorem Fand_false_introR : forall I F2, I |/= F2 -> (forall F1, I |/= F1 ^/\ F2).
Proof. intros I F2 H F1.
       apply Fand_false_iff. right. apply H.
Qed.

Theorem For_true_introL : forall I F1, I |= F1 -> (forall F2, I |= F1 ^\/ F2).
Proof. intros I F1 H F2. apply For_true_iff. left. apply H.
Qed.

Theorem For_true_intror : forall I F2, I |= F2 -> (forall F1, I |= F1 ^\/ F2).
Proof. intros I F2 H F1. apply For_true_iff. right. apply H.
Qed.

Theorem Fimp_false_intro : forall I F1, I |/= F1 -> (forall F2, I |= F1 ^-> F2).
Proof. intros I F1 H F2. apply Fimp_true_iff. intros HN.
       rewrite  H in HN. inversion HN.
Qed.

Theorem Fnot_false_elim : forall I F, I |/= ^~ F <-> I |= F.
Proof. intros I F. split.
       -intros H. apply Fnot_true_iff in H. apply Fnot_true_double_elim in H.
        apply H.
       -intros H. apply Fnot_true_iff. rewrite <- Fnot_true_double_elim. apply H.
Qed.

Theorem Fcontra_intro : forall I F, I |= F /\ I |/= F <-> I |= ^**false.
Proof. intros I F. split.
       -intros H. destruct H. rewrite H in H0. inversion H0.
       -intros H. rewrite Ffalse_is_false in H. inversion H.
Qed.

Example ex1p4 : forall I P Q, I |= ^*P /\ I |/= ^*Q -> I |= (^*P ^/\ ^*Q) ^-> (^*P ^\/ ^~^*Q).
Proof. intros I P0 Q0 H. destruct H.
       apply Fnot_true_iff in H0 as HQN.
       apply Fand_false_introR with (F1 := ^*P0) in H0.
       apply For_true_introL with (F2 := ^~ ^*Q0) in H.
       apply Fimp_false_intro with (F2 := (^* P0 ^\/ ^~ ^* Q0)) in H0.
       apply H0.
Qed.

(* 1.3 Satisfiability and Validity *)
Definition satisfiable (F : formula) : Prop := (exists I, I |= F).
Definition valid (F : formula) : Prop := (forall I, I |= F).

Lemma Fnot_exists_iff_forall : forall F, ~ (exists I, I |= ^~ F) <-> (forall I, I |/= ^~ F).
Proof. split; intros.
       -apply not_true_iff_false. unfold not. intros H0.
       unfold not in H. apply H. exists I. apply H0.
       -intros H0. destruct H0. apply Fnot_true_iff in H0.
        apply not_true_iff_false in H0. apply H0.
        apply Fnot_true_double_elim. apply Fnot_true_iff. apply H.
Qed.

Theorem Fvalid_iff_notsat : (forall F : formula,  valid F <-> ~ satisfiable (^~ F)).
Proof. intros F. unfold valid. unfold satisfiable. unfold not. split.
       -intros H [I]. apply Fnot_true_iff in H0. rewrite H in H0. inversion H0.
       -intros H I. apply Fnot_exists_iff_forall with (I := I) in H.
        apply Fnot_true_iff in H. apply Fnot_true_double_elim in H. apply H.
Qed.

Example ex1p5 : valid (^*P ^/\ ^*Q ^-> ^*P ^\/ ^~^*Q).
Proof. unfold valid. intros I. rewrite Fimp_true_iff.
       intros H. rewrite Fand_true_iff in H. destruct H.
       rewrite For_true_iff. left. apply H.
Qed.

(*inorder to prove not valid, have to prove the negation is satisfiable*)
Theorem ex1p6 : ~ valid (^*P ^\/ ^*Q ^-> ^*P ^/\ ^*Q).
Proof. unfold not. intros con. apply Fvalid_iff_notsat in con.
       apply con. unfold satisfiable. exists [(P,true);(Q,false)].
       simpl. reflexivity.
Qed.

Example ex1p7 : valid (^*P ^/\ ^*Q ^-> ^*P ^\/ ^~^*Q).
Proof. rewrite Fvalid_iff_notsat. unfold satisfiable. unfold not. intros H.
       destruct H as [I]. apply Fnot_true_iff in H. rewrite Fimp_false_elim in H.
       destruct H. apply Fand_true_iff in H. destruct H. apply For_false_iff in H0.
       destruct H0. rewrite H in H0. inversion H0.
Qed.

Example ex1p8 : valid ((^*P ^-> ^*Q)^/\(^*Q ^-> ^*R) ^-> (^*P ^-> ^*R)).
Proof. rewrite Fvalid_iff_notsat. unfold satisfiable. unfold not. intros H.
       destruct H as [I]. rewrite Fnot_true_iff in H. rewrite Fimp_false_elim in H.
       destruct H. apply Fand_true_iff in H. destruct H. apply Fimp_false_elim in H0.
       destruct H0. apply Fimp_true_elim in H. destruct H.
       -rewrite H in H0. inversion H0.
       -apply Fimp_true_elim in H1. destruct H1.
        *rewrite H in H1. inversion H1.
        *rewrite H1 in H2. inversion H2.
Qed.

Theorem Fmodus_ponens : forall I F1 F2, I |= F1 -> I |= F1 ^-> F2 -> I |= F2.
Proof. intros I F1 F2 H H0. rewrite Fimp_true_iff in H0. apply H0 in H. apply H.
Qed.

(*substitute every occurance of f1 for f2 in F*)
Fixpoint sub (f1 f2 F: formula) : list formula :=
  match F with
  | FAto a => FAto a :: nil
  | FNot A => [FNot A] ++  A
  | FOr A B =>  [FOr A B] ++ expand_formula A ++ expand_formula B
  | FAnd A B => [FAnd A B] ++ expand_formula A ++ expand_formula B
  | FImp A B => [FImp A B] ++ expand_formula A ++ expand_formula B
  | FIff A B => [FIff A B] ++ expand_formula A ++ expand_formula B
  end.

Fixpoint SYNeq (F1 F2 : formula) : bool :=
  match F1, F2 with
  | ^* A , ^* B => beq_id A B
  | ^** A, ^** B => eqb A B
  | ^~ A , ^~ B => SYNeq A B
  | A ^\/ B, C ^\/ D
  | A ^/\ B, C ^/\ D
  | A ^-> B, C ^-> D
  | A ^<-> B, C ^<-> D => andb (SYNeq A C) (SYNeq B D)
  | _, _ => false
  end.
Notation "A SYN= B" := (SYNeq A B = true) (at level 80).
Notation "A SYN<> B" := (SYNeq A B = false) (at level 80).

Definition SList : Type := list (formula*formula).
Fixpoint sub_function (f : formula -> formula) (l : SList) : formula -> formula :=
  match l with
  | nil => f
  | h :: t => (sub_function
              (fun (F : formula) => (if (SYNeq (fst h) F) then (snd h) else (f F)))
              t )
  end.


Definition f  (n:nat) := n = n.

Lemma f_refl : forall n , f n.
intros. reflexivity.
Qed.

Definition f'  (x:nat) (n:nat) := n = n.

Lemma f_refl' : forall n , f' n n.
Proof.
 intros. reflexivity.
Qed.

Require Import ZArith.

Definition f'' (a:bool) := if a then eq (A:= Z) else Z.lt.

Lemma f_refl'' : forall n , f'' true n n.
Proof.
 intro. reflexivity.
Qed.


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

Require Import OrderedRing.
Require Import RingMicromega.
Require Import ZArith.
Require Import InitialRing.
Require Import Setoid.

Import OrderedRingSyntax.

Set Implicit Arguments.

Section InitialMorphism.

Variable R : Type.
Variables rO rI : R.
Variables rplus rtimes rminus: R -> R -> R.
Variable ropp : R -> R.
Variables req rle rlt : R -> R -> Prop.

Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.

Notation "0" := rO.
Notation "1" := rI.
Notation "x + y" := (rplus x y).
Notation "x * y " := (rtimes x y).
Notation "x - y " := (rminus x y).
Notation "- x" := (ropp x).
Notation "x == y" := (req x y).
Notation "x ~= y" := (~ req x y).
Notation "x <= y" := (rle x y).
Notation "x < y" := (rlt x y).

Lemma req_refl : forall x, req x x.
Proof.
  destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_).
  apply Equivalence_Reflexive.
Qed.

Lemma req_sym : forall x y, req x y -> req y x.
Proof.
  destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_).
  apply Equivalence_Symmetric.
Qed.

Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
Proof.
  destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive).
  apply Equivalence_Transitive.
Qed.

Add Relation R req
  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
as sor_setoid.

Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
Proof.
exact sor.(SORplus_wd).
Qed.
Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
Proof.
exact sor.(SORtimes_wd).
Qed.
Add Morphism ropp with signature req ==> req as ropp_morph.
Proof.
exact sor.(SORopp_wd).
Qed.
Add Morphism rle with signature req ==> req ==> iff as rle_morph.
Proof.
exact sor.(SORle_wd).
Qed.
Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
Proof.
exact sor.(SORlt_wd).
Qed.
Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
Proof.
  exact (rminus_morph sor).
Qed.

Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.

Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
Declare Equivalent Keys gen_order_phi_Z gen_phiZ.

Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).

Notation "[ x ]" := (gen_order_phi_Z x).

Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req.
Proof.
constructor.
exact rplus_morph.
exact rtimes_morph.
exact ropp_morph.
Qed.

Lemma Zring_morph :
  ring_morph 0 1 rplus rtimes rminus ropp req
             0%Z 1%Z Z.add Z.mul Z.sub Z.opp
             Zeq_bool gen_order_phi_Z.
Proof.
exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
Qed.

Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x.
Proof.
induction x as [x IH | x IH |]; simpl;
try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor);
try apply (Rlt_0_1 sor); assumption.
Qed.

Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x.
Proof.
exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
        (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
Qed.

Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
Proof.
intros x y H. pattern y; apply Pos.lt_ind with x.
rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
assumption.
Qed.

Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
Proof.
intros x y H.
do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
destruct x; destruct y; simpl in *; try discriminate.
apply phi_pos1_pos.
now apply clt_pos_morph.
apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
apply phi_pos1_pos.
apply -> (Ropp_lt_mono sor); apply clt_pos_morph.
red. now rewrite Pos.compare_antisym.
Qed.

Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y].
Proof.
unfold Z.leb; intros x y H.
case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
le_less. now apply clt_morph.
discriminate.
Qed.

Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
Proof.
intros x y H. unfold Zeq_bool in H.
case_eq (Z.compare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
apply (Rlt_neq sor). now apply clt_morph.
fold (x > y)%Z in H1. rewrite Z.gt_lt_iff in H1.
apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
Qed.

End InitialMorphism.


(* CyclicPerm library *)
(* v 0.2  2017/07/24   Olivier Laurent *)

(* Release Notes
     v0.2: strengthening of cperm_map_inv
*)

(** * Cyclic Permutations
Definition and basic properties of cyclic permutations. *)

Require Import Morphisms.

Require Import List_more.
Require Import Permutation_more.

(** Definition *)
Inductive CPermutation {A} : list A -> list A -> Prop :=
| cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1).

Instance cperm_perm {A} : Proper (CPermutation ==> (@Permutation A)) id.
Proof.
intros l1 l2 HC.
inversion HC.
apply Permutation_app_comm.
Qed.

Instance cperm_refl {A} : Reflexive (@CPermutation A).
Proof.
intros l.
rewrite <- (app_nil_l l) at 2.
rewrite <- (app_nil_r l) at 1.
eapply cperm.
Qed.

Instance cperm_sym {A} : Symmetric (@CPermutation A).
Proof.
intros l1 l2 HC.
inversion HC.
eapply cperm.
Qed.

Instance cperm_trans {A} : Transitive (@CPermutation A).
Proof.
intros l1 l2 l3 HC1 HC2.
inversion HC1 ; inversion HC2 ; subst.
apply dichot_app in H1.
destruct H1 as [[l2' [Hl1 Hl2]] | [l4' [Hr1 Hr2]]] ; subst.
- rewrite <- app_assoc.
  rewrite app_assoc at 1.
  eapply cperm.
- rewrite app_assoc.
  rewrite <- app_assoc at 1.
  eapply cperm.
Qed.

Instance cperm_equiv {A} : Equivalence (@CPermutation A).
Proof.
split.
- apply cperm_refl.
- apply cperm_sym.
- apply cperm_trans.
Qed.

Lemma cperm_app {A} : forall l1 l2 l3 : list A,
  CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3.
Proof.
intros l1 l2 l3 HC.
transitivity (l1 ++ l2) ; try assumption.
eapply cperm.
Qed.

Lemma cperm_app_rot {A} : forall (l1 : list A) l2 l3,
   CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1).
Proof.
intros l1 l2 l3.
rewrite (app_assoc l2).
apply cperm.
Qed.

Lemma cperm_last {A} : forall (a : A) l, CPermutation (a :: l) (l ++ a :: nil).
Proof.
intros.
rewrite <- (app_nil_l l).
rewrite app_comm_cons.
apply cperm.
Qed.

Lemma cperm_swap {A} : forall a b : A, CPermutation (a :: b :: nil) (b :: a :: nil).
Proof.
intros.
change (a :: b :: nil) with ((a :: nil) ++ (b :: nil)).
change (b :: a :: nil) with ((b :: nil) ++ (a :: nil)).
apply cperm.
Qed.

Lemma cperm_cons {A} : forall l1 (a : A) l2,
  CPermutation (l1 ++ (a :: nil)) l2 -> CPermutation (a :: l1) l2.
Proof.
intros l1 a l2 HC.
apply (cperm_app l1 (a :: nil)) ; assumption.
Qed.

Lemma cperm_morph_cons {A} : forall P : list A -> Prop,
  (forall a l, P (l ++ a :: nil) -> P (a :: l)) -> Proper (CPermutation ==> iff) P.
Proof with try assumption.
assert (forall P : list A -> Prop,
         (forall a l, P (l ++ a :: nil) -> P (a :: l)) ->
         forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2)
  as Himp.
{
intros P HP l1 l2 HC.
inversion HC ; subst ; clear HC.
revert l0 ; induction l3 using rev_ind ; intros l0 HPl.
- rewrite app_nil_r in HPl...
- rewrite app_assoc in HPl.
  apply HP in HPl.
  rewrite <- app_assoc.
  rewrite <- app_comm_cons.
  rewrite app_nil_l...
  apply IHl3...
}
intros P HP l1 l2 HC.
split ; [ | symmetry in HC ] ; apply Himp...
Qed.

Lemma cperm_nil {A} : forall l : list A, CPermutation nil l -> l = nil.
Proof.
intros.
apply Permutation_nil.
apply cperm_perm.
assumption.
Qed.

Lemma cperm_nil_cons {A} : forall l (a : A), ~ CPermutation nil (a :: l).
Proof.
intros l a HC.
apply cperm_nil in HC.
inversion HC.
Qed.

Lemma cperm_one {A} : forall a b : A, CPermutation (a :: nil) (b :: nil) -> a = b.
Proof.
intros.
apply Permutation_length_1.
apply cperm_perm.
assumption.
Qed.

Lemma cperm_two {A} : forall a1 a2 b1 b2 : A,
  CPermutation (a1 :: a2 :: nil) (b1 :: b2 :: nil) ->
    a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1.
Proof.
intros.
apply Permutation_length_2.
apply cperm_perm.
assumption.
Qed.

Lemma cperm_one_inv {A} : forall l (a : A), CPermutation (a :: nil) l -> l = a :: nil.
Proof.
intros.
apply Permutation_length_1_inv.
apply cperm_perm.
assumption.
Qed.

Lemma cperm_two_inv {A} : forall (a : A) b l,
  CPermutation (a :: b :: nil) l -> l = a :: b :: nil \/ l = b :: a :: nil.
Proof.
intros.
apply Permutation_length_2_inv.
apply cperm_perm.
assumption.
Qed.

Lemma cperm_vs_elt_inv {A} : forall (a : A) l l1 l2,
  CPermutation l (l1 ++ a :: l2) ->
    exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''.
Proof.
intros a l l1 l2 HC.
inversion HC ; subst.
symmetry in H1.
dichot_elt_app_exec H1 ; subst.
- exists (l0 ++ l1) ; exists l ; split ;
    rewrite <- app_assoc ; reflexivity.
- exists l4 ; exists (l2 ++ l3) ; split ;
    rewrite <- app_assoc ; reflexivity.
Qed.

Lemma cperm_vs_cons_inv {A} : forall (a : A) l l1,
  CPermutation l (a :: l1) -> exists l2 l3, l1 = l3 ++ l2 /\ l = l2 ++ a :: l3.
Proof.
intros.
rewrite <- (app_nil_l (a::_)) in H.
apply cperm_vs_elt_inv in H.
destruct H as (l' & l'' & H1 & H2).
rewrite app_nil_r in H1 ; subst.
exists l' ; exists l'' ; split ; reflexivity.
Qed.

Lemma cperm_app_app_inv {A} : forall (l1 : list A) l2 l3 l4,
  CPermutation (l1 ++ l2) (l3 ++ l4) ->
     (exists l3' l3'' l4' l4'',
        CPermutation l1 (l3' ++ l4')  /\ CPermutation l2 (l3'' ++ l4'')
     /\
        CPermutation l3 (l3' ++ l3'') /\ CPermutation l4 (l4' ++ l4''))
  \/ (exists l l',
        CPermutation l1 (l4 ++ l) /\ CPermutation l3 (l2 ++ l')
          /\ CPermutation l l')
  \/ (exists l l',
        CPermutation l2 (l4 ++ l) /\ CPermutation l3 (l1 ++ l')
          /\ CPermutation l l')
  \/ (exists l l',
        CPermutation l1 (l3 ++ l) /\ CPermutation l4 (l2 ++ l')
          /\ CPermutation l l')
  \/ (exists l l',
        CPermutation l2 (l3 ++ l) /\ CPermutation l4 (l1 ++ l')
          /\ CPermutation l l').
Proof with try assumption ; try reflexivity.
intros l1 l2 l3 l4 HC.
inversion HC as [lx ly Hx Hy].
dichot_app_exec Hx ; dichot_app_exec Hy ; subst.
- right ; left.
  exists (l ++ l0) ; exists (l0 ++ l).
  split ; [ | split ] ;
    try (rewrite <- ? app_assoc ; apply cperm_app_rot)...
  apply cperm.
- dichot_app_exec Hy0 ; subst.
  + left.
    exists l ; exists l0 ; exists lx ; exists l5.
    split ; [ | split ; [ | split ]] ; try apply cperm...
  + right ; right ; right ; left.
    exists (l1 ++ lx) ; exists (lx ++ l1).
    split ; [ | split ] ;
      try (rewrite <- ? app_assoc ; apply cperm_app_rot)...
    apply cperm.
- dichot_app_exec Hy1 ; subst.
  + right ; right ; left.
    exists (ly ++ l2) ; exists (l2 ++ ly).
    split ; [ | split ] ;
      try (rewrite <- ? app_assoc ; apply cperm_app_rot)...
    apply cperm.
  + left.
    exists l ; exists ly ; exists l3 ; exists l0.
    split ; [ | split ; [ | split ]] ; try apply cperm...
- right ; right ; right ; right.
  exists (l5 ++ l0) ; exists (l0 ++ l5).
  split ; [ | split ] ;
    try (rewrite <- ? app_assoc ; apply cperm_app_rot)...
  apply cperm.
Qed.

(** [rev], [in], [map], [Forall], [Exists], etc. *)
Instance cperm_rev {A} : Proper (CPermutation ==> CPermutation) (@rev A).
Proof.
intro l ; induction l ; intros l' HC.
- apply cperm_nil in HC ; subst ; reflexivity.
- symmetry in HC.
  apply cperm_vs_cons_inv in HC.
  destruct HC as (l1 & l2 & Heq1 & Heq2) ; subst.
  simpl ; rewrite ? rev_app_distr ; simpl.
  rewrite <- app_assoc.
  apply cperm.
Qed.

Instance cperm_in {A} (a : A) : Proper (CPermutation ==> Basics.impl) (In a).
Proof with try eassumption.
intros l l' HC Hin.
eapply Permutation_in...
apply cperm_perm...
Qed.

Instance cperm_map {A B} (f : A -> B) :
   Proper (CPermutation ==> CPermutation) (map f).
Proof.
intros l l' HC.
inversion HC ; subst ; rewrite ? map_app.
apply cperm.
Qed.

Lemma cperm_map_inv {A B} : forall(f : A -> B) l1 l2,
  CPermutation l1 (map f l2) -> exists l3, l1 = map f l3 /\ CPermutation l2 l3.
Proof with try reflexivity ; try assumption.
induction l1 ; intros l2 HP.
- exists nil ; split...
  destruct l2...
  apply cperm_nil in HP.
  inversion HP.
- symmetry in HP.
  assert (Heq := HP).
  apply cperm_vs_cons_inv in Heq.
  destruct Heq as (l3 & l4 & Heq1 & Heq2).
  symmetry in Heq2.
  decomp_map Heq2 ; subst.
  exists (x :: l6 ++ l0).
  split.
  + list_simpl...
  + rewrite app_comm_cons.
    apply cperm.
Qed.

Instance cperm_Forall {A} (P : A -> Prop) :
  Proper (CPermutation ==> Basics.impl) (Forall P).
Proof with try eassumption.
intros l1 l2 HC HF.
eapply Permutation_Forall...
apply cperm_perm...
Qed.

Instance cperm_Exists {A} (P : A -> Prop) :
  Proper (CPermutation ==> Basics.impl) (Exists P).
Proof with try eassumption.
intros l1 l2 HC HE.
eapply Permutation_Exists...
apply cperm_perm...
Qed.

Lemma cperm_Forall2 {A B} (P : A -> B -> Prop) :
  forall l1 l1' l2, CPermutation l1 l1' -> Forall2 P l1 l2 -> exists l2',
    CPermutation l2 l2' /\ Forall2 P l1' l2'.
Proof.
intros l1 l1' l2 HC.
revert l2 ; induction HC ; intros l2' HF.
apply Forall2_app_inv_l in HF as (l2a & l2b & HF2a & HF2b & Heq) ; subst.
exists (l2b ++ l2a) ; split.
- constructor.
- apply Forall2_app ; assumption.
Qed.

Lemma cperm_image {A B} : forall (f : A -> B) a l l',
  CPermutation (a :: l) (map f l') -> exists a', a = f a'.
Proof.
intros f a l l' HP.
eapply Permutation_image.
apply cperm_perm ; eassumption.
Qed.


Set Printing Universes.
Set Universe Polymorphism.

Add LoadPath "../quotient".
Require Import Base.
Require Import NType.

Definition quotient A (R : A -> A -> hProp) := { P : A -> hProp | (trunc minus1 (isEqClass R P)) }.
(* Definition quotient@{i j k l m n r e3 e10 e11 e12 e13 e14 e15 e16 truc} (A : Type@{i}) (R : A -> A -> hProp@{j k l}) : Type@{i} *)
(*   := { P : A -> hProp@{m n r} | (trunc@{i} minus1 (isEqClass@{i i e3 j k l m n r e10 e11 e12 e13 e14 e15 e16} R P)) }. *)
Notation "A // R" := (quotient A R) (at level 90).

(* Section Foo. *)

(*   Universes i j k l. *)
(*   (*)Let X := Type@{i} : Type@{j}.*) *)
(*   Let Y := Type@{j} : Type@{k}. *)
(*   Parameter T : Type@{j}. *)
(*   Parameter R : T -> T -> hProp@{l j l}. *)

(*   Parameter P : T -> hProp@{l j l}. *)
(*   Parameter eqP : isEqClass R P. *)

(*   (* Definition foo : T // R := exist _ P (tr eqP). *) *)

(*   (* Goal T // R. *) *)
(*   (* unfold quotient. *) *)
(*   (* exists P. apply tr. exact eqP. *) *)
(*   (* Defined. *) *)

(*   Check T // R : Type@{j}. *)

(* End Foo. *)

(* Let's try it with Z/2Z *)

Require Import ZArith.

(* Definition Z@{i} := Z : let _ := Set : Type@{i} in Type@{i}. *)

Inductive R2Ztype : Z -> Z -> Type :=
| diff_even : forall n m k : Z, heq (m - n)%Z (2 * k)%Z -> R2Ztype n m.

Require Import MyEqDepDec.

(* I'll allow myself anything, we will hide it with Qed *)
Lemma division_unicity : forall n k l, heq n (2 * k)%Z -> heq n (2 * l)%Z -> heq k l.
Proof.
  intros n k l h1 h2.
  inversion h1 as [hh1].
  inversion h2 as [hh2].
  cut (eq k l).
  - intro h.
    now destruct h.
  - omega.
Qed.

Lemma division_unicity2 : forall n k l, heq n (2 * k + 1)%Z -> heq n (2 * l + 1)%Z -> heq k l.
Proof.
  intros n k l h1 h2.
  inversion h1 as [hh1].
  inversion h2 as [hh2].
  cut (eq k l).
  - intro h.
    now destruct h.
  - omega.
Qed.

(* To replace Z.eq_dec *)
Lemma Pos_eq_dec : forall p q : positive, hsum (heq p q) ((heq p q) -> False).
Proof.
  intro p.
  induction p ; destruct q ; try (now apply inl) ; try (now apply inr).
  - destruct (IHp q).
    + left.
      now destruct a.
    + right.
      intro absurd.
      apply b.
      now inversion absurd.
  - destruct (IHp q).
    + left ; now destruct a.
    + right ; intro absurd ; apply b ; now inversion absurd.
Qed.

Lemma Zeq_dec : forall x y : Z, hsum (heq x y) ((heq x y) -> False).
Proof.
  intro x.
  induction x ; destruct y ; try (now apply inl) ; try (now apply inr).
  - destruct (Pos_eq_dec p p0).
    + left ; now destruct a.
    + right ; intro absurd ; apply b ; now inversion absurd.
  - destruct (Pos_eq_dec p p0).
    + left ; now destruct a.
    + right ; intro absurd ; apply b ; now inversion absurd.
Qed.

Lemma R2ZhProp : forall n m : Z, ishType minus1 (R2Ztype n m).
Proof.
  intros n m.
  apply hsuc.
  intros x y.
  apply hctr.
  destruct x as [n m k e].
  destruct y as [n m l f].
  assert (heq k l) as k_l.
  {
    eapply (division_unicity).
    - exact e.
    - exact f.
  }
  destruct k_l.
  assert (heq e f) as e_f.
  - apply eq_proofs_unicity.
    intros x y.
    destruct (Zeq_dec x y).
    + now left.
    + now right.
  - destruct e_f.
    exists (heq_refl (diff_even n m k e)).
    intro p.
    apply eq_proofs_unicity.
    intros x y.
    destruct x as [n m k' e'].
    destruct y as [n m l f].
    assert (heq l k') as l_k'.
    {
      now apply (division_unicity (m - n)%Z).
    }
    destruct l_k'.
    assert (heq f e') as f_e'.
    + apply eq_proofs_unicity.
      intros x y.
      destruct (Zeq_dec x y).
      * now left.
      * now right.
    + destruct f_e'.
      now apply inl.
Defined.

Definition R2Z (n m : Z) : hProp := exist _ (R2Ztype n m) (R2ZhProp n m ).

Definition Z2 := Z // R2Z.

(* Even though Z fits in Set, it is not the case of Z/2Z which should be smaller (bool : Set!) *)
Fail Check Z2 : Set.

(* Alternative definition of Z2 (ie bool) *)
Inductive Z2' : Set := c0 | c1.

Inductive even : Z -> Type :=
  is_even : forall n k : Z, heq n (2 * k)%Z -> even n.

Inductive odd : Z -> Type :=
  is_odd : forall n k : Z, heq n (2 * k + 1)%Z -> odd n.

Lemma evenhProp : forall z, ishProp (even z).
Proof.
  intro z.
  apply hsuc.
  intros x y.
  apply hctr.
  destruct x.
  destruct y.
  cut (heq k k0).
  - intro hh.
    destruct hh.
    assert (heq h h0).
    + apply eq_proofs_unicity.
      intros x y.
      destruct (Zeq_dec x y).
      * destruct a.
        now apply inl.
      * apply inr.
        intro eqxy.
        destruct eqxy.
        now apply b.
    + destruct X.
      exists (heq_refl (is_even n k h)).
      intro p.
      apply eq_proofs_unicity.
      intros x y.
      destruct x ; destruct y.
      assert (heq k0 k1).
      {
        now apply (division_unicity n).
      }
      destruct X.
      assert (heq h0 h1).
      {
        apply eq_proofs_unicity.
        intros x y.
        destruct (Zeq_dec x y).
        - destruct a ; now left.
        - right ; intro eqxy ; destruct eqxy ; now apply b.
      }
      destruct X.
      now apply inl.
  - now apply (division_unicity n).
Defined.

Lemma oddhProp : forall z, ishProp (odd z).
Proof.
  intro z.
  apply hsuc.
  intros x y.
  apply hctr.
  destruct x.
  destruct y.
  cut (heq k k0).
  - intro hh.
    destruct hh.
    assert (heq h h0).
    + apply eq_proofs_unicity.
      intros x y.
      destruct (Zeq_dec x y).
      * destruct a.
        now apply inl.
      * apply inr.
        intro eqxy.
        destruct eqxy.
        now apply b.
    + destruct X.
      exists (heq_refl (is_odd n k h)).
      intro p.
      apply eq_proofs_unicity.
      intros x y.
      destruct x ; destruct y.
      assert (heq k0 k1).
      {
        now apply (division_unicity2 n).
      }
      destruct X.
      assert (heq h0 h1).
      {
        apply eq_proofs_unicity.
        intros x y.
        destruct (Zeq_dec x y).
        - destruct a ; now left.
        - right ; intro eqxy ; destruct eqxy ; now apply b.
      }
      destruct X.
      now apply inl.
  - now apply (division_unicity2 n).
Defined.

(* Random exercise *)
Goal forall x : True, forall e : heq x x, heq e (heq_refl _).
Proof.
  destruct x.
  inversion e.
Abort.

(* m - 0 = m *)
Lemma minus0_id : forall n, heq (n - 0)%Z n.
Proof.
  induction n ; easy.
Defined.

Unset Printing Universes.

Lemma conveq : forall n k, heq (n - 0)%Z (2 * k)%Z -> heq n (2 * k)%Z.
Proof.
  intros n k h.
  apply (heq_trans _ (n - 0)%Z).
  - apply heq_sym.
    apply minus0_id.
  - exact h.
Defined.

Definition g (y : Z) (p : R2Ztype 0%Z y) :=
  match p in (R2Ztype 0%Z z) return (even z) with
  | diff_even 0%Z n k h => is_even n k (conveq n k h)
  end.

Definition h (y : Z) (p : even y) :=
  match p in (even z) return (R2Ztype 0%Z z) with
  | is_even n k h => diff_even 0%Z n k (heq_trans (n-0)%Z n (2*k)%Z (minus0_id n) h)
  end.

Lemma hg_id0 : forall n k hh, heq (h n (g n (diff_even 0%Z n k hh))) (diff_even 0%Z n k hh).
Proof.
  intros n k hh.
  unfold g.
  unfold h.
  apply hf_equal.
  apply eq_proofs_unicity.
  apply Zeq_dec.
Defined.

Definition hg_id y a : heq (h y (g y a)) a :=
  match a as p in (R2Ztype 0%Z z) return (@heq (R2Ztype 0%Z z) (h z (g z p)) p) with
  | diff_even 0%Z n k hh => hg_id0 n k hh
  end.

Lemma gh_id0 : forall n k hh, heq (g n (h n (is_even n k hh))) (is_even n k hh).
Proof.
  intros n k hh.
  unfold h.
  unfold g.
  apply hf_equal.
  apply eq_proofs_unicity.
  apply Zeq_dec.
Defined.

Definition gh_id y a : heq (g y (h y a)) a :=
  match a as p in (even z) return (@heq (even z) (g z (h z p)) p) with
  | is_even n k hh => gh_id0 n k hh
  end.

(* Let's do it again but for odds *)

(* Let's use omega here too *)
Lemma g2_proof : forall n k, heq (n - 1)%Z (2 * k)%Z -> heq n (2 * k + 1)%Z.
Proof.
  intros n k hh.
  cut (eq n (2 * k + 1))%Z.
  - intro hhh ; now destruct hhh.
  - assert (eq (n - 1) (2 * k))%Z.
    + now inversion hh.
    + omega.
Qed.

Definition g2 (y : Z) (p : R2Ztype 1%Z y) :=
  match p in (R2Ztype 1%Z z) return (odd z) with
  | diff_even 1%Z n k hh => is_odd n k (g2_proof n k hh)
  end.

Lemma h2_proof : forall n k, heq n (2 * k + 1)%Z -> heq (n - 1)%Z (2 * k)%Z.
Proof.
  intros n k hh.
  assert (eq (n-1) (2*k))%Z.
  - inversion hh.
    omega.
  - now destruct H.
Qed.

Definition h2 (y : Z) (p : odd y) :=
  match p in (odd z) return (R2Ztype 1%Z z) with
  | is_odd n k hh => diff_even 1%Z n k (h2_proof n k hh)
  end.

Lemma h2g2_id0 : forall n k hh, heq (h2 n (g2 n (diff_even 1%Z n k hh))) (diff_even 1%Z n k hh).
Proof.
  intros n k hh.
  unfold g2.
  unfold h2.
  apply hf_equal.
  apply eq_proofs_unicity.
  apply Zeq_dec.
Defined.

Definition h2g2_id y a : heq (h2 y (g2 y a)) a :=
  match a as p in (R2Ztype 1%Z z) return (@heq (R2Ztype 1%Z z) (h2 z (g2 z p)) p) with
  | diff_even 1%Z n k hh => h2g2_id0 n k hh
  end.

Lemma g2h2_id0 : forall n k hh, heq (g2 n (h2 n (is_odd n k hh))) (is_odd n k hh).
Proof.
  intros n k hh.
  unfold h2.
  unfold g2.
  apply hf_equal.
  apply eq_proofs_unicity.
  apply Zeq_dec.
Defined.

Definition g2h2_id y a : heq (g2 y (h2 y a)) a :=
  match a as p in (odd z) return (@heq (odd z) (g2 z (h2 z p)) p) with
  | is_odd n k hh => g2h2_id0 n k hh
  end.

Let f (x : Z2') : Z2.
Proof.
  destruct x.
  - exists (fun z => exist _ (even z) (evenhProp z)).
    compute.
    apply tr.
    exists 0%Z.
    intro y.
    exists (g y).
    split.
    + exists (h y).
      apply hg_id.
    + exists (h y).
      apply gh_id.
  - exists (fun z => exist _ (odd z) (oddhProp z)).
    compute.
    apply tr.
    exists 1%Z.
    intro y.
    exists (g2 y) ; split.
    + exists (h2 y) ; apply h2g2_id.
    + exists (h2 y) ; apply g2h2_id.
Defined.

Axiom ff : forall X, X.

Set Printing Universes.
Fixpoint foo (n : nat) : Z2.
destruct n.
- exact (f c1).
- Fail simple refine (exist _ (fun z => (forall x : Z2, heq x (foo n) -> let (P, _) := x in pi1 (P z); _)) _).
  (*+ apply ff.
  + apply ff.
Defined.*)
Abort.

(*
Lemma eq_to_heq {A} : forall x y : A, eq x y -> heq x y.
Proof.
  intros x y eq.
  now destruct eq.
Defined.

(*! WARNING : use of omega AND Defined !*)
Lemma either_even_odd : forall z, hsum (exists k, heq z (2 * k)%Z) (exists k, heq z (2 * k + 1)%Z).
Proof.
  intro z.
  destruct z.
  - left. exists 0%Z. now compute.
  - destruct p.
    + right ; exists (Z.pos p) ; pose proof (Pos2Z.inj_xI p) ; easy.
    + left ; exists (Z.pos p) ; pose proof (Pos2Z.inj_xO p) ; easy.
    + right. exists 0%Z. now simpl.
  - destruct p.
    + right. exists (Z.neg p - 1)%Z. pose proof (Pos2Z.neg_xI p). apply eq_to_heq. omega.
    + left. exists (Z.neg p). pose proof (Pos2Z.neg_xO p). easy.
    + right. exists (-1)%Z. now simpl.
Defined.

Lemma even_odd_false : forall m k l, heq m (2 * k)%Z -> heq m (2 * l + 1)%Z -> False.
Proof.
  intros m k l even odd.
  rewrite odd in even.
  destruct k ; destruct l ;
  try (simpl in even ; easy).
  induction p0 ; try easy.
Defined.

Lemma inv_hProp : forall {A}, ishProp A -> forall x y : A, contractible (heq x y).
Proof.
  intros A h x y.
  inversion h.
  pose proof (X x y).
  now inversion X0.
Defined.

Axiom fun_ext : forall {A B} {f g : A -> B}, (forall x, heq (f x) (g x)) -> heq f g.

Lemma hsum_hProp : forall A, ishProp A -> ishProp (hsum A (A -> False)).
Proof.
  intros A h.
  apply hsuc.
  intros x y.
  apply hctr.
  assert (heq x y).
  - destruct x ; destruct y ; try easy.
    + pose proof (inv_hProp h a a0).
      destruct X as [p eq].
      now destruct p.
    + apply hf_equal.
      apply fun_ext.
      intro x.
      destruct (b x).
  - destruct X.
    exists (heq_refl _).
    intro p.
    apply eq_proofs_unicity.
    intros a b. destruct a ; destruct b ; try easy.
    + left.
      pose proof (inv_hProp h a a0).
      destruct X as [q eq].
      now destruct q.
    + left.
      apply hf_equal.
       apply fun_ext.
      intro tutu.
      destruct (b tutu).
Defined.

(*! WARNING : use of omega AND Defined !*)

Set Printing Universes.

Lemma either_in : forall (z : Z) (P : Z -> hProp) (h : trunc minus1 (isEqClass R2Z P)),
                    hsum (pi1 (P z)) (pi1 (P z) -> False).
Proof.
  intros z P h.
  refine (trunc_ind (fun aa => _) _ h).
  - intro hh.
    apply hsum_hProp.
    now destruct (P z).
  - intro p.
    destruct p as [a p].
    destruct (either_even_odd a) as [[k evena] | [k odda]] ;
      destruct (either_even_odd z) as [[l evenz] | [l oddz]].
    + left. apply p. apply (diff_even _ _ (l - k)%Z). inversion evena. inversion evenz.
      apply eq_to_heq. omega.
    + right. intro absurd. destruct (p z) as [f [[g gf] [g' g'f]]].
      destruct (g absurd) as [n m q eq].
      eapply (even_odd_false (m - n)%Z q (l - k)%Z).
      * exact eq.
      * apply eq_to_heq. inversion evena. inversion oddz. omega.
    + right. intro absurd. destruct (p z) as [f [[g gf] [g' g'f]]].
      destruct (g absurd) as [n m q eq].
      eapply (even_odd_false (m - n)%Z q (l - k - 1)%Z).
      * exact eq.
      * apply eq_to_heq. inversion evenz. inversion odda. omega.
    + left. apply p. apply (diff_even _ _ (l - k)%Z). inversion odda. inversion oddz.
      apply eq_to_heq. omega.
Defined.

Let ff (x : Z2) : Z2'.
  destruct x as [P h].
  pose (either_in 0%Z P h).
  destruct (either_in 0%Z P h).
  - exact c0.
  - exact c1.
Defined.

Class Decidable (A : Type) :=
  dec : hsum A (A -> False).
Arguments dec A {_}.

(* Two classes that share an element are equal *)
Lemma classes_share_eq :
  forall {A R} (a : A) (P Q : A -> hProp) (hp : trunc minus1 (isEqClass R P)) (hq : trunc minus1 (isEqClass R Q)),
    (forall x y, Decidable (pi1 (R x y))) -> isEqRel R -> pi1 (P a) -> pi1 (Q a) -> heq P Q.
Proof.
  intros A R a P Q hp hq dec eqrel pa qa.
  apply fun_ext.
  intro x.
  destruct eqrel as [rho sigma tau].
  destruct (dec x a).
  - assert (pi1 (P x)) as px.
    + refine (trunc_ind (fun aa => _) _ hp).
      * intro hp'. now destruct (P x).
      * intro hpp. destruct hpp as [e h]. apply h.
        { apply (tau _ a).
          - now apply sigma.
          - now apply h.
        }
    + assert (pi1 (Q x)) as qx.
      * { refine (trunc_ind (fun aa => _) _ hq).
          - intro hq'. now destruct (Q x).
          - intro hqq. destruct hqq as [e h]. apply h.
            apply (tau _ a).
            + now apply sigma.
            + now apply h.
        }
      * admit.
  - assert (pi1 (P x) -> False) as npx.
    + intro px. apply b.
      refine (trunc_ind (fun aa => _) _ hp).
      * intro hp'. now destruct (R x a).
      * intro hpp. destruct hpp as [e h].
        { apply (tau _ e).
          - now apply h.
          - apply sigma. now apply h.
        }
    + assert (pi1 (Q x) -> False) as nqx.
      * intro qx. apply b.
        { refine (trunc_ind (fun aa => _) _ hq).
          - intro hq'. now destruct (R x a).
          - intro hqq. destruct hqq as [e h].
            apply (tau _ e).
            + now apply h.
            + apply sigma. now apply h.
        }
      *

Lemma equiv_bool_Z2 : isEquiv f.
Proof.
  split.
  - exists ff. intro a. unfold comp. unfold id. destruct a ;
    unfold f ; unfold ff ; now simpl.
  - exists ff. intro a. unfold comp. unfold id. destruct a as [P h].
    unfold ff. destruct (either_in 0%Z P h).
    + unfold f. (* We probably need something to say that two equivalence classes that share an element are equal. *)
*)


(* 元の文 *)
(* ドラえもんはネズミが嫌い。 *)
(* すべての嫌いなものは好きものである。 *)
(* ドラえもんはネズミが好き。 *)
(* 論理式 *)
Require Export lib.
Parameter _ネズミ : Entity -> Prop.
Parameter _ドラえもん : Entity -> Prop.
Parameter _嫌い : Event -> Prop.
Parameter _好き : Event -> Prop.

Theorem t1:
  (exists x,(_ネズミ(x) /\ exists z4,(_ドラえもん(z4) /\ exists e,(_嫌い(e) /\ (Acc(e) = x) /\ (Nom(e) = z4)))))
  ->
  (forall x z, (exists e,_嫌い(e) /\ (Acc(e) = z) /\ (Nom(e) = x)) -> (exists e,(_好き(e) /\ (Acc(e) = z) /\ (Nom(e) = x))))
  ->
  (exists x,(_ドラえもん(x) /\ exists z22,(_ネズミ(z22) /\ exists e,(_好き(e)  /\ (Acc(e) = z22) /\ (Nom(e) = x))))).
Proof.
  intros H1 H2.
  destruct H1.
  destruct H.
  destruct H0 as [z4 [d eq]].
  exists z4.  split. assumption.
  exists x. split. assumption.
  specialize H2 with (z:=x) (x:=z4).
  destruct H2.
  apply eq.
  exists x0. assumption.
Qed.


Require Import SquiggleEq.list.
Require Import SquiggleEq.UsefulTypes.
Require Import common.
Require Import SquiggleEq.tactics.

Require Import EqdepFacts.

Require Import JMeq.

Set Implicit Arguments.

Require Import Trecord.

Definition dependsOnlyOnRel (V V₂ : Set) {T:(BestRel V V₂)->Type}
  (P: forall v: BestRel V V₂, T v):=
forall (V_R1 : BestRel V V₂) pt po,
let V_R2 := {| R:= BestR V_R1; Rtot := pt ; Rone := po |} in
 JMeq (P V_R1) (P V_R2).

Definition dependsOnlyOnRelTot (V V₂ : Set) {T:(BestRel V V₂)->Type}
  (P: forall v: BestRel V V₂, T v):=
forall (V_R1 : BestRel V V₂) po,
let V_R2 : BestRel V V₂
:= @Build_GoodRel allProps V V₂ (BestR V_R1) (@Rtot allProps _ _ V_R1) po in
 JMeq (P V_R1) (P V_R2).

Definition existsAGoodnessFreeImpl {T: forall (V V₂ : Set) (V_R : BestRel V V₂), Type}
(P : forall (V V₂ : Set) (V_R : BestRel V V₂), T V V₂ V_R) : Type :=
forall
(V V₂ : Set) (Rp: (V -> V₂ -> Prop)),
sigT (fun T:Type => sig (fun (f:T) =>
forall pt po,
let V_R : BestRel V V₂ := {| R:= Rp; Rtot := pt ; Rone := po|} in
JMeq (P V V₂ V_R) f)).

Definition existsAOneFreeImpl {T: forall (V V₂ : Set) (V_R : BestRel V V₂), Type}
(P : forall (V V₂ : Set) (V_R : BestRel V V₂), T V V₂ V_R) : Type :=
forall
(V V₂ : Set) (Rp: (V -> V₂ -> Prop)) pt,
sigT (fun T:Type => sig (fun (f:T) =>
forall po,
let V_R : BestRel V V₂ := {| R:= Rp; Rtot := pt ; Rone := po|} in
JMeq (P V V₂ V_R) f)).

Definition existsAGoodnessFreeImpl2
{T: forall (A A₂ : Set) (A_R : BestRel A A₂) (B B₂ : Set) (B_R : BestRel B B₂), Type}
(P : forall (A A₂ : Set) (A_R : BestRel A A₂)
(B B₂ : Set) (B_R : BestRel B B₂) , T A A₂ A_R B B₂ B_R) : Type :=
forall
(A A₂ : Set) (Ra: (A -> A₂ -> Prop))
(B B₂ : Set) (Rb: (B -> B₂ -> Prop)),
sigT (fun T:Type => sig (fun (f:T) =>
forall pta poa ptb pob,
let A_R : BestRel A A₂ := {| R:= Ra; Rtot := pta ; Rone := poa|} in
let B_R : BestRel B B₂ := {| R:= Rb; Rtot := ptb ; Rone := pob|} in
JMeq (P A A₂ A_R B B₂ B_R) f)).

Definition existsAOneFreeImpl2
{T: forall (A A₂ : Set) (A_R : BestRel A A₂) (B B₂ : Set) (B_R : BestRel B B₂), Type}
(P : forall (A A₂ : Set) (A_R : BestRel A A₂)
(B B₂ : Set) (B_R : BestRel B B₂) , T A A₂ A_R B B₂ B_R) : Type :=
forall
(A A₂ : Set) (Ra: (A -> A₂ -> Prop)) pta
(B B₂ : Set) (Rb: (B -> B₂ -> Prop)) ptb,
sigT (fun T:Type => sig (fun (f:T) =>
forall poa pob,
let A_R : BestRel A A₂ := {| R:= Ra; Rtot := pta ; Rone := poa|} in
let B_R : BestRel B B₂ := {| R:= Rb; Rtot := ptb ; Rone := pob|} in
JMeq (P A A₂ A_R B B₂ B_R) f)).


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

 Eso 1-cells

 One way to define epimorphisms in categories, is via 'strong epimorphisms.
 A strong epimorphism is a morphism that has a lifting property with respect
 to monomorphisms.
 We can generalize this definition to bicategories since fully faithful 1-cells
 generalize monomorphisms. This gives rise to the notion of eso 1-cells.

 Usually, eso 1-cells are defined as follows:

    a 1-cell `f : b₁ --> b₂` is eso if for all fully faithful `m : c₁ --> c₂`
    the follow square is a weak pullback of categories

       B(b₁, c₁) -------------> B(b₁, c₂)
           |                        |
           |                        |
           V                        V
       B(b₂, c₁) -------------> B(b₂, c₂)

 We also consider an alternative definition in which we say that the canonical
 map from `B(b₁, c₁)` to the iso-comma category is an equivalence. We can then
 construct esos by using that fully faithful and essentially surjective
 functors are equivalences if the involved categories are univalent. From this
 formulation, we can also deduce a universal mapping property.

 In this file, we consider both definitions, and we show that they are indeed
 equivalent.

 Contents
 1. Esos
 2. Constructing esos
 3. Projections for esos
 4. Esos via pullbacks
 5. Equivalence of the definitions
 6. (eso, ff)-factorization
 7. Closure under pullbacks

 *****************************************************************************)
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.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.IsoCommaCategory.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Import PullbackFunctions.Notations.
Require Import UniMath.Bicategories.Limits.PullbackEquivalences.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.

Local Open Scope cat.

Section EsoMorphisms.
  Context {B : bicat}
          {b₁ b₂ : B}
          (f : b₁ --> b₂).

  (**
   1. Esos
   *)
  Definition pre_comp_post_comp_commute
             {c₁ c₂ : B}
             (m : c₁ --> c₂)
    : pre_comp c₁ f ∙ post_comp b₁ m
      ⟹
      post_comp b₂ m ∙ pre_comp c₂ f.
  Proof.
    use make_nat_trans.
    - exact (λ _, rassociator _ _ _).
    - abstract
        (intros h₁ h₂ α ;
         cbn ;
         rewrite rwhisker_lwhisker_rassociator ;
         apply idpath).
  Defined.

  Definition pre_comp_post_comp_commute_z_iso
             {c₁ c₂ : B}
             (m : c₁ --> c₂)
    : nat_z_iso
        (pre_comp c₁ f ∙ post_comp b₁ m)
        (post_comp b₂ m ∙ pre_comp c₂ f).
  Proof.
    use make_nat_z_iso.
    - exact (pre_comp_post_comp_commute m).
    - intro.
      use is_inv2cell_to_is_z_iso ; cbn.
      is_iso.
  Defined.

  Definition is_eso_functor
             {c₁ c₂ : B}
             (m : c₁ --> c₂)
    : hom b₂ c₁ ⟶ iso_comma (post_comp b₁ m) (pre_comp c₂ f).
  Proof.
    use iso_comma_ump1.
    - exact (pre_comp c₁ f).
    - exact (post_comp b₂ m).
    - exact (pre_comp_post_comp_commute_z_iso m).
  Defined.

  Definition is_eso
    : UU
    := ∏ (c₁ c₂ : B)
         (m : c₁ --> c₂)
         (Hm : fully_faithful_1cell m),
       adj_equivalence_of_cats
         (is_eso_functor m).

  Definition isaprop_is_eso
             (HB_2_1 : is_univalent_2_1 B)
    : isaprop is_eso.
  Proof.
    use impred ; intro c₁.
    use impred ; intro c₂.
    use impred ; intro m.
    use impred ; intro H.
    use (isofhlevelweqf
             1
             (@adj_equiv_is_equiv_cat
                (univ_hom HB_2_1 b₂ c₁)
                (@univalent_iso_comma
                   (univ_hom HB_2_1 b₁ c₁)
                   (univ_hom HB_2_1 b₂ c₂)
                   (univ_hom HB_2_1 b₁ c₂)
                   (post_comp b₁ m)
                   (pre_comp c₂ f))
                (is_eso_functor m))).
    apply isaprop_left_adjoint_equivalence.
    exact univalent_cat_is_univalent_2_1.
  Defined.

  (**
   2. Constructing esos
   *)

  (**
   To construct an eso, one should do 3 things.
   First of all, one needs to construct a lift for diagrams of the following shape

              g₁
        b₁ -------> c₁
        |           |
      f |           | m
        |           |
        V           V
        b₂ -------> c₂
              g₂

   where m is a fully faithful 1-cell. This diagram commutes up to an invertible 2-cell.
   The resulting triangles should commute up to an invertible 2-cell and the obvious
   coherency must be satisfied up to equality.

   This expresses that the relevant functor is essentially surjective.
   *)
  Definition is_eso_essentially_surjective
    : UU
    := ∏ (c₁ c₂ : B)
         (m : c₁ --> c₂)
         (Hm : fully_faithful_1cell m)
         (g₁ : b₁ --> c₁)
         (g₂ : b₂ --> c₂)
         (α : invertible_2cell (g₁ · m) (f · g₂)),
       ∑ (l : b₂ --> c₁)
         (ζ₁ : invertible_2cell (f · l) g₁)
         (ζ₂ : invertible_2cell (l · m) g₂),
       (ζ₁ ▹ m) • α = rassociator _ _ _ • (f ◃ ζ₂).

  (**
   The second thing allows us to construct 2-cells between lifts.

   This expresses that the relevant functor is full.
   *)
  Definition is_eso_full
    : UU
    := ∏ (c₁ c₂ : B)
         (m : c₁ --> c₂)
         (Hm : fully_faithful_1cell m)
         (l₁ l₂ : b₂ --> c₁)
         (k₁ : f · l₁ ==> f · l₂)
         (k₂ : l₁ · m ==> l₂ · m)
         (p : (k₁ ▹ m) • rassociator _ _ _
              =
              rassociator _ _ _ • (f ◃ k₂)),
       ∑ (ξ : l₁ ==> l₂),
       f ◃ ξ = k₁
       ×
       ξ ▹ m = k₂.

  (**
   The last thing allows us to prove that 2-cells between lifts are equal.

   This expresses that the relevant functor is faithful.
   *)
  Definition is_eso_faithful
    : UU
    := ∏ (c₁ c₂ : B)
         (m : c₁ --> c₂)
         (Hm : fully_faithful_1cell m)
         (l₁ l₂ : b₂ --> c₁)
         (ζ₁ ζ₂ : l₁ ==> l₂),
       f ◃ ζ₁ = f ◃ ζ₂
       →
       ζ₁ ▹ m = ζ₂ ▹ m
       →
       ζ₁ = ζ₂.

  (**
   Now we can give a constructor for eso morphisms if the bicategory is locally univalent.

   Note that local univalence is needed so that we can get an equivalence from functors
   that are essentially surjective and fully faithful.
   *)
  Section MakeEso.
    Context (HB_2_1 : is_univalent_2_1 B)
            (H₁ : is_eso_full)
            (H₂ : is_eso_faithful)
            (H₃ : is_eso_essentially_surjective).

    Section MakeEsoHelp.
      Context {c₁ c₂ : B}
              {m : c₁ --> c₂}
              (Hm : fully_faithful_1cell m).

      Definition make_is_eso_full
        : full (is_eso_functor m).
      Proof.
        intros l₁ l₂.
        intro k.
        apply hinhpr.
        simple refine (_ ,, _) ; cbn.
        - exact (pr1 (H₁ c₁ c₂ m Hm l₁ l₂ (pr11 k) (pr21 k) (pr2 k))).
        - abstract
            (use subtypePath ; [ intro ; apply cellset_property | ] ;
             cbn ;
             exact (pathsdirprod
                      (pr12 (H₁ c₁ c₂ m Hm l₁ l₂ (pr11 k) (pr21 k) (pr2 k)))
                      (pr22 (H₁ c₁ c₂ m Hm l₁ l₂ (pr11 k) (pr21 k) (pr2 k))))).
      Defined.

      Definition make_is_eso_faithful
        : faithful (is_eso_functor m).
      Proof.
        intros l₁ l₂.
        intro im.
        use invproofirrelevance.
        intros ζ₁ ζ₂.
        use subtypePath.
        {
          intro.
          apply homset_property.
        }
        use (H₂ c₁ c₂ m Hm l₁ l₂ (pr1 ζ₁) (pr1 ζ₂)).
        - exact (maponpaths (λ z, pr11 z) (pr2 ζ₁)
                 @ !(maponpaths (λ z, pr11 z) (pr2 ζ₂))).
        - exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr2 ζ₁)
                            @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr2 ζ₂))).
      Qed.

      Definition make_is_eso_fully_faithful
        : fully_faithful (is_eso_functor m).
      Proof.
        use full_and_faithful_implies_fully_faithful.
        split.
        - exact make_is_eso_full.
        - exact make_is_eso_faithful.
      Defined.

      Definition make_is_eso_essentially_surjective
        : essentially_surjective (is_eso_functor m).
      Proof.
        intros h.
        pose (ℓ := H₃ c₁ c₂ m Hm (pr11 h) (pr21 h) (z_iso_to_inv2cell (pr2 h))).
        apply hinhpr.
        simple refine (_ ,, _).
        - exact (pr1 ℓ).
        - use make_z_iso'.
          + simple refine ((_ ,, _) ,, _) ; cbn.
            * exact (pr12 ℓ).
            * exact (pr122 ℓ).
            * exact (pr222 ℓ).
          + use is_z_iso_iso_comma.
            * use is_inv2cell_to_is_z_iso.
              apply property_from_invertible_2cell.
            * use is_inv2cell_to_is_z_iso.
              apply property_from_invertible_2cell.
      Defined.
    End MakeEsoHelp.

    Definition make_is_eso
      : is_eso.
    Proof.
      intros c₁ c₂ m Hm.
      use rad_equivalence_of_cats.
      - use is_univ_hom.
        exact HB_2_1.
      - exact (make_is_eso_fully_faithful Hm).
      - exact (make_is_eso_essentially_surjective Hm).
    Defined.
  End MakeEso.

  (**
   3. Projections for esos
   *)
  Section Projections.
    Context (H : is_eso).

    (** Lifting property for for 1-cells *)
    Section LiftOne.
      Context {c₁ c₂ : B}
              {m : c₁ --> c₂}
              (Hm : fully_faithful_1cell m)
              (g₁ : b₁ --> c₁)
              (g₂ : b₂ --> c₂)
              (α : invertible_2cell (g₁ · m) (f · g₂)).

      Definition is_eso_lift_1
        : b₂ --> c₁
        := right_adjoint (H c₁ c₂ m Hm) ((g₁ ,, g₂) ,, inv2cell_to_z_iso α).

      Definition is_eso_lift_1_comm_left
        : invertible_2cell (f · is_eso_lift_1) g₁.
      Proof.
        apply z_iso_to_inv2cell.
        exact (functor_on_z_iso
                (iso_comma_pr1 _ _)
                (counit_pointwise_z_iso_from_adj_equivalence
                   (H c₁ c₂ m Hm)
                   ((g₁ ,, g₂) ,, inv2cell_to_z_iso α))).
      Defined.

      Definition is_eso_lift_1_comm_right
        : invertible_2cell (is_eso_lift_1 · m) g₂.
      Proof.
        apply z_iso_to_inv2cell.
        exact (functor_on_z_iso
                 (iso_comma_pr2 _ _)
                 (counit_pointwise_z_iso_from_adj_equivalence
                    (H c₁ c₂ m Hm)
                    ((g₁ ,, g₂) ,, inv2cell_to_z_iso α))).
      Defined.

      Definition is_eso_lift_1_eq
        : (is_eso_lift_1_comm_left ▹ m) • α
          =
          rassociator _ _ _ • (f ◃ is_eso_lift_1_comm_right)
        := pr2 (counit_from_left_adjoint
                  (pr1 (H c₁ c₂ m Hm))
                  ((g₁ ,, g₂) ,, inv2cell_to_z_iso α)).
    End LiftOne.

    (** Lifting property for for 2-cells *)
    Section LiftTwo.
      Context {c₁ c₂ : B}
              {m : c₁ --> c₂}
              (Hm : fully_faithful_1cell m)
              (l₁ l₂ : b₂ --> c₁)
              (k₁ : f · l₁ ==> f · l₂)
              (k₂ : l₁ · m ==> l₂ · m)
              (p : (k₁ ▹ m) • rassociator _ _ _
                   =
                   rassociator _ _ _ • (f ◃ k₂)).

      Let R : iso_comma (post_comp b₁ m) (pre_comp c₂ f) ⟶ hom b₂ c₁
        := right_adjoint (H c₁ c₂ m Hm).

      Let φ : iso_comma (post_comp b₁ m) (pre_comp c₂ f)
        := (f · l₁ ,, l₁ · m) ,, inv2cell_to_z_iso (rassociator_invertible_2cell _ _ _).
      Let ψ : iso_comma (post_comp b₁ m) (pre_comp c₂ f)
        := (f · l₂ ,, l₂ · m) ,, inv2cell_to_z_iso (rassociator_invertible_2cell _ _ _).
      Let μ : φ --> ψ
        := (k₁ ,, k₂) ,, p.

      Let η₁ : l₁ ==> R φ
        := unit_from_left_adjoint (H c₁ c₂ m Hm) l₁.
      Let η₂ : R ψ ==> l₂
        := z_iso_to_inv2cell (unit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) l₂)^-1.
      Let ε₁ : f · R φ ==> f · l₁
        := pr11 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) φ).
      Let ε₂ : f · R ψ ==> f · l₂
        := pr11 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) ψ).
      Let ε₁' : R φ · m ==> l₁ · m
        := pr21 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) φ).
      Let ε₂' : R ψ · m ==> l₂ · m
        := pr21 (counit_from_left_adjoint (pr1 (H c₁ c₂ m Hm)) ψ).

      Definition is_eso_lift_2
        : l₁ ==> l₂
        := η₁ • #R μ • η₂.

      Local Lemma is_eso_lift_2_counit_invertible
        : is_invertible_2cell ε₂.
      Proof.
        exact (property_from_invertible_2cell
                 (z_iso_to_inv2cell
                    (functor_on_z_iso
                       (iso_comma_pr1 _ _)
                       (counit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) ψ)))).
      Qed.

      Local Lemma is_eso_lift_2_left_path_1
        : (f ◃ #R μ) • ε₂ = ε₁ • k₁.
      Proof.
        exact (maponpaths
                 (λ z, pr11 z)
                 (nat_trans_ax (counit_from_left_adjoint (H c₁ c₂ m Hm)) _ _ μ)).
      Qed.

      Local Lemma is_eso_lift_2_left_path_2
        : (f ◃ η₁) • ε₁ = id2 _.
      Proof.
        exact (maponpaths
                 (λ z, pr11 z)
                 (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₁)).
      Qed.

      Definition is_eso_lift_2_left
        : f ◃ is_eso_lift_2 = k₁.
      Proof.
        unfold is_eso_lift_2.
        rewrite <- !lwhisker_vcomp.
        use vcomp_move_R_Mp.
        {
          unfold η₂.
          is_iso.
        }
        use (vcomp_rcancel ε₂).
        {
          exact is_eso_lift_2_counit_invertible.
        }
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          exact is_eso_lift_2_left_path_1.
        }
        cbn.
        rewrite !vassocr.
        etrans.
        {
          apply maponpaths_2.
          exact is_eso_lift_2_left_path_2.
        }
        rewrite id2_left.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          exact (maponpaths
                   (λ z, pr11 z)
                   (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₂)).
        }
        cbn.
        rewrite id2_right.
        apply idpath.
      Qed.

      Local Lemma is_eso_lift_2_counit_invertible'
        : is_invertible_2cell ε₂'.
      Proof.
        exact (property_from_invertible_2cell
                 (z_iso_to_inv2cell
                    (functor_on_z_iso
                       (iso_comma_pr2 _ _)
                       (counit_pointwise_z_iso_from_adj_equivalence (H c₁ c₂ m Hm) ψ)))).
      Qed.

      Local Lemma is_eso_lift_2_right_path_1
        : (#R μ ▹ m) • ε₂' = ε₁' • k₂.
      Proof.
        exact (maponpaths
                 (λ z, dirprod_pr2 (pr1 z))
                 (nat_trans_ax (counit_from_left_adjoint (H c₁ c₂ m Hm)) _ _ μ)).
      Qed.

      Local Lemma is_eso_lift_2_right_path_2
        : (η₁ ▹ m) • ε₁' = id2 _.
      Proof.
        exact (maponpaths
                 (λ z, dirprod_pr2 (pr1 z))
                 (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₁)).
      Qed.

      Definition is_eso_lift_2_right
        : is_eso_lift_2 ▹ m = k₂.
      Proof.
        unfold is_eso_lift_2.
        rewrite <- !rwhisker_vcomp.
        use vcomp_move_R_Mp.
        {
          unfold η₂.
          is_iso.
        }
        cbn.
        use (vcomp_rcancel ε₂').
        {
          exact is_eso_lift_2_counit_invertible'.
        }
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          exact is_eso_lift_2_right_path_1.
        }
        rewrite !vassocr.
        etrans.
        {
          apply maponpaths_2.
          exact is_eso_lift_2_right_path_2.
        }
        rewrite id2_left.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          exact (maponpaths
                   (λ z, dirprod_pr2 (pr1 z))
                   (triangle_id_left_ad (pr21 (H c₁ c₂ m Hm)) l₂)).
        }
        apply id2_right.
      Qed.
    End LiftTwo.

    (** Lifting property for for equalities *)
    Definition is_eso_lift_eq
               {c₁ c₂ : B}
               {m : c₁ --> c₂}
               (Hm : fully_faithful_1cell m)
               {l₁ l₂ : b₂ --> c₁}
               (ζ₁ ζ₂ : l₁ ==> l₂)
               (p₁ : f ◃ ζ₁ = f ◃ ζ₂)
               (p₂ : ζ₁ ▹ m = ζ₂ ▹ m)
      : ζ₁ = ζ₂.
    Proof.
      pose (pr2 (fully_faithful_implies_full_and_faithful
                   _ _ _
                   (fully_faithful_from_equivalence _ _ _ (H c₁ c₂ m Hm)))
                l₁ l₂)
        as Heq.
      assert (((f ◃ ζ₁) ▹ m) • rassociator f l₂ m
              =
              rassociator f l₁ m • (f ◃ (ζ₁ ▹ m)))
        as r₁.
      {
        refine (!_).
        apply rwhisker_lwhisker_rassociator.
      }
      assert (((f ◃ ζ₂) ▹ m) • rassociator f l₂ m
              =
              rassociator f l₁ m • (f ◃ (ζ₂ ▹ m)))
        as r₂.
      {
        refine (!_).
        apply rwhisker_lwhisker_rassociator.
      }
      pose (proofirrelevance
              _
              (Heq ((f ◃ ζ₁ ,, ζ₁ ▹ m) ,, r₁)))
        as Hprop.
      refine (maponpaths pr1 (Hprop (_ ,, _) (_ ,, _))).
      - use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        cbn.
        apply idpath.
      - use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        cbn.
        use pathsdirprod.
        + exact (!p₁).
        + exact (!p₂).
    Qed.
  End Projections.

  (**
   4. Esos via pullbacks
   *)
  Definition is_eso_via_pb_cone
             (HB_2_1 : is_univalent_2_1 B)
             {c₁ c₂ : B}
             (m : c₁ --> c₂)
             (Hm : fully_faithful_1cell m)
    : @pb_cone
        bicat_of_univ_cats
        (univ_hom HB_2_1 b₁ c₁)
        (univ_hom HB_2_1 b₂ c₂)
        (univ_hom HB_2_1 b₁ c₂)
        (post_comp b₁ m)
        (pre_comp c₂ f).
  Proof.
    use make_pb_cone.
    - exact (univ_hom HB_2_1 b₂ c₁).
    - exact (pre_comp c₁ f).
    - exact (post_comp b₂ m).
    - use nat_z_iso_to_invertible_2cell.
      exact (pre_comp_post_comp_commute_z_iso m).
  Defined.

  Definition is_eso_via_pb
             (HB_2_1 : is_univalent_2_1 B)
    : UU
    := ∏ (c₁ c₂ : B)
         (m : c₁ --> c₂)
         (Hm : fully_faithful_1cell m),
       has_pb_ump (is_eso_via_pb_cone HB_2_1 m Hm).

  Definition isaprop_is_eso_via_pb
             (HB_2_1 : is_univalent_2_1 B)
    : isaprop (is_eso_via_pb HB_2_1).
  Proof.
    use impred ; intro c₁.
    use impred ; intro c₂.
    use impred ; intro m.
    use impred ; intro Hm.
    use isaprop_has_pb_ump.
    exact univalent_cat_is_univalent_2_1.
  Defined.

  (**
   5. Equivalence of the definitions
   *)
  Definition is_eso_to_is_eso_via_pb
             (HB_2_1 : is_univalent_2_1 B)
             (Hf : is_eso)
    : is_eso_via_pb HB_2_1.
  Proof.
    intros c₁ c₂ m Hm.
    specialize (Hf c₁ c₂ m Hm).
    use (left_adjoint_equivalence_to_pb
           _ _ _
           (@iso_comma_has_pb_ump
               (univ_hom HB_2_1 b₁ c₁)
               (univ_hom HB_2_1 b₂ c₂)
               (univ_hom HB_2_1 b₁ c₂)
               (post_comp b₁ m)
               (pre_comp c₂ f))
           _
           _).
    - exact univalent_cat_is_univalent_2_0.
    - exact (is_eso_functor m).
    - exact (@equiv_cat_to_adj_equiv
               (univ_hom HB_2_1 b₂ c₁)
               (@univalent_iso_comma
                  (univ_hom HB_2_1 b₁ c₁)
                  (univ_hom HB_2_1 b₂ c₂)
                  (univ_hom HB_2_1 b₁ c₂)
                  (post_comp b₁ m)
                  (pre_comp c₂ f))
               (is_eso_functor m)
               Hf).
    - use nat_z_iso_to_invertible_2cell.
      use make_nat_z_iso.
      + use make_nat_trans.
        * exact (λ _, id2 _).
        * abstract
            (intros h₁ h₂ α ; cbn ;
             rewrite id2_left, id2_right ;
             apply idpath).
      + intro.
        use is_inv2cell_to_is_z_iso ; cbn.
        is_iso.
    - use nat_z_iso_to_invertible_2cell.
      use make_nat_z_iso.
      + use make_nat_trans.
        * exact (λ _, id2 _).
        * abstract
            (intros h₁ h₂ α ; cbn ;
             rewrite id2_left, id2_right ;
             apply idpath).
      + intro.
        use is_inv2cell_to_is_z_iso ; cbn.
        is_iso.
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite id2_rwhisker, lwhisker_id2 ;
         rewrite !id2_left, !id2_right ;
         apply idpath).
  Defined.

  Definition is_eso_via_pb_to_is_eso_nat_trans
             (HB_2_1 : is_univalent_2_1 B)
             {c₁ c₂ : B}
             {m : c₁ --> c₂}
             (Hm : fully_faithful_1cell m)
    : is_eso_functor m
      ⟹
      pr1 (pb_ump_mor
             (@iso_comma_has_pb_ump
                (univ_hom HB_2_1 b₁ c₁)
                (univ_hom HB_2_1 b₂ c₂)
                (univ_hom HB_2_1 b₁ c₂)
                (post_comp b₁ m)
                (pre_comp c₂ f))
             (is_eso_via_pb_cone HB_2_1 m Hm)).
  Proof.
    use make_nat_trans.
    - intro h.
      simple refine ((id2 _ ,, id2 _) ,, _).
      abstract
        (cbn ;
         rewrite id2_rwhisker, lwhisker_id2, id2_left, id2_right ;
         apply idpath).
    - abstract
        (intros h₁ h₂ γ ;
         use subtypePath ; [ intro ; apply cellset_property | ] ;
         cbn ;
         rewrite !id2_left, !id2_right ;
         apply idpath).
  Defined.

  Definition is_eso_via_pb_to_is_eso
             (HB_2_1 : is_univalent_2_1 B)
             (Hf : is_eso_via_pb HB_2_1)
    : is_eso.
  Proof.
    intros c₁ c₂ m Hm.
    specialize (Hf c₁ c₂ m Hm).
    apply (@adj_equiv_to_equiv_cat
             (univ_hom HB_2_1 b₂ c₁)
             (@univalent_iso_comma
                (univ_hom HB_2_1 b₁ c₁)
                (univ_hom HB_2_1 b₂ c₂)
                (univ_hom HB_2_1 b₁ c₂)
                (post_comp b₁ m)
                (pre_comp c₂ f))
             (is_eso_functor m)).
    pose (pb_ump_mor_left_adjoint_equivalence
            _
            _
            (@iso_comma_has_pb_ump
               (univ_hom HB_2_1 b₁ c₁)
               (univ_hom HB_2_1 b₂ c₂)
               (univ_hom HB_2_1 b₁ c₂)
               (post_comp b₁ m)
               (pre_comp c₂ f))
            Hf)
      as p.
    use (left_adjoint_equivalence_invertible p).
    - exact (is_eso_via_pb_to_is_eso_nat_trans HB_2_1 Hm).
    - use is_nat_z_iso_to_is_invertible_2cell.
      intro.
      use is_z_iso_iso_comma.
      + use is_inv2cell_to_is_z_iso ; cbn.
        is_iso.
      + use is_inv2cell_to_is_z_iso ; cbn.
        is_iso.
  Defined.

  Definition is_eso_weq_is_eso_via_pb
             (HB_2_1 : is_univalent_2_1 B)
    : is_eso ≃ is_eso_via_pb HB_2_1.
  Proof.
    use weqimplimpl.
    - exact (is_eso_to_is_eso_via_pb HB_2_1).
    - exact (is_eso_via_pb_to_is_eso HB_2_1).
    - exact (isaprop_is_eso HB_2_1).
    - exact (isaprop_is_eso_via_pb HB_2_1).
  Defined.
End EsoMorphisms.

(**
 6. (eso, ff)-factorization
 *)
Definition eso_ff_factorization
           (B : bicat)
    : UU
  := ∏ (b₁ b₂ : B)
       (f : b₁ --> b₂),
     ∑ (im : B)
       (m : im --> b₂)
       (f' : b₁ --> im),
     fully_faithful_1cell m
     ×
     is_eso f'
     ×
     invertible_2cell (f' · m) f.

(**
 7. Closure under pullbacks
 *)
Definition is_eso_closed_under_pb
           (B : bicat_with_pb)
  : UU
  := ∏ (x y z : B)
       (f : x --> z)
       (Hf : is_eso f)
       (g : y --> z),
     is_eso (π₂ : f /≃ g --> y).