Require Import List.
Require Import Program.
Require Import Coq.Sets.Ensembles.

(** * Type classes for functors, applicatives, and monads *)

Local Notation "f ∘ g" := (fun x => f (g x)) (at level 40, left associativity).

Class Functor (f : Type -> Type) : Type :=
  { fmap         : forall {A B}, (A -> B) -> f A -> f B }.
Class Applicative (f : Type -> Type) `{F : Functor f} : Type :=
  { pure : forall {A}, A -> f A;
    liftA : forall {A B}, f (A -> B) -> f A -> f B
  }.
Class Monad (m: Type -> Type) `{M : Applicative m} : Type :=
  { bind: forall {A}, m A -> forall {B}, (A -> m B) -> m B
  }.
Definition return_ {m : Type -> Type} `{M : Monad m} {A : Type} : A -> m A := pure.

Class MonadTrans (t : (Type -> Type) -> (Type -> Type)) :=
  { liftT : forall {m} `{Monad m} {A}, m A -> t m A }.

(** ** Notations *)

Module MonadNotations.
  Notation "f <*> a" := (liftA f a) (left associativity, at level 64) : monad_scope.
  Notation "a >>= f" := (bind a f)  (left associativity, at level 66) : monad_scope.
  Notation "a >> b" := (bind a (fun _ => b)) (at level 66, left associativity) : monad_scope.
  Notation "'do' a ← e ; c" := (bind e (fun a => c)) (at level 80, right associativity) : monad_scope.
  Notation "'do' ( a , b ) ← e ; c" := (bind e (fun x => let (a,b) := x in c)) (at level 80, right associativity) : monad_scope.
End MonadNotations.

Import MonadNotations.
Open Scope monad_scope.

(** ** Functor, Applicative, and Monad Laws *)
Class Functor_Correct (f : Type -> Type) `{F : Functor f} :=
  { fmap_id      : forall {A}, fmap (fun (x:A)=> x) = (fun x => x);
    fmap_compose : forall {A B C} (g : A -> B) (f : B -> C),
        fmap (f ∘ g) = fmap f ∘ fmap g
  }.
Class Applicative_Correct (f : Type -> Type) `{Applicative f} :=
{ applicative_id : forall A, liftA (pure (fun  (x:A) => x)) = (fun  x => x);
  applicative_composition : forall {A B C} (u : f (B -> C)) (v : f (A -> B)) (w : f A),
    pure (fun  x => fun  y => x ∘ y) <*> u <*> v <*> w = u <*> (v <*> w);
  applicative_homomorphism : forall {A B} (f : A -> B) (x : A),
    pure f <*> pure x = pure (f x);
  applicative_interchange : forall {A B} (u : f (A -> B)) (y : A),
    u <*> pure y = pure (fun x => x y) <*> u
}.

Class Monad_Correct (m : Type -> Type) `{M : Monad m} := {
  bind_right_unit: forall A (a: m A), a = a >>= return_;
  bind_left_unit: forall A (a: A) B (f: A -> m B),
             f a = return_ a >>= f;
  bind_associativity: forall A (ma: m A) B f C (g: B -> m C),
                 bind ma (fun  x=> f x >>= g) = (ma >>= f) >>= g
}.

Arguments Functor f : assert.
Arguments Functor_Correct f {F}.
Arguments Applicative f [F].
Arguments Applicative_Correct f {F} {A} : rename.
Arguments Monad m [F] [M].
Arguments Monad_Correct m [F] [A] [M] : rename.

(** ** Helper functions *)
Section monadic_functions.
  Context (m : Type -> Type)
          `{Functor m}
          `{Applicative m}
          `{Monad m}.

   Definition wbind {A: Type} (ma: m A) {B: Type} (mb: m B) :=
   ma >>= fun  _=>mb.

   Definition liftM {A B: Type} (f: A->B) (ma: m A): m B :=
   ma >>= (fun  a => return_ (f a)).

   Definition join {A: Type} (mma: m (m A)): m A :=
   mma >>= (fun  ma => ma).

  Fixpoint foldM {A B}
                 (f : B -> A -> m B) (b : B) (ls : list A) : m B :=
    match ls with
    | nil      => return_ b
    | x :: ls' => do y ← f b x;
                  foldM f y ls'
    end.
End monadic_functions.

Section monadic_proofs.
  Lemma fmap_compose' {f} (F : Functor f) `{Functor_Correct f} :
    forall {A B C} (g : A -> B) (h : B -> C) (a : f A),
    fmap h (fmap g a) = fmap (h ∘ g) a.
  Proof.
    intros.
    rewrite (fmap_compose g h).
    reflexivity.
  Qed.

  Lemma bind_eq : forall {A B m} `{Monad m} (a a' : m A) (f f' : A -> m B),
      a = a' ->
      (forall x, f x = f' x) ->
      bind a f = bind a' f'.
  Proof.
    intros. subst.
    f_equal.
    apply functional_extensionality.
    auto.
  Qed.
End monadic_proofs.

(** ** Tactics *)
Module Tactics.

  Hint Transparent return_.

  (** Reduce by monad laws inside of a goal *)
 Ltac simplify_monad :=
  repeat match goal with
  | [ |- context[ Some ?e ] ] =>
    let tp := type of e in
    replace (Some e) with (return_ e : option tp)
    by reflexivity
  | [ |- context[ bind (return_ _) _ ] ] => rewrite <- bind_left_unit
  | [ |- context[ bind (bind _ _) _ ] ]  => rewrite <- bind_associativity
  | [ |- _ = _ ]                  => reflexivity
  | [ |- bind ?a ?f = _ ] => erewrite (bind_eq a);
                             [ reflexivity | intro; simplify_monad | ]
  end.

  Ltac simplify_under_monad :=
    repeat (try match goal with
    [ |- bind ?a _ = bind ?a _ ] => apply bind_eq; [ reflexivity | intros ]
    end; simplify_monad).
End Tactics.

(** * Some classic monads *)

Module Instances.

(** ** The list monad *)

Open Scope list_scope.
Definition list_fmap {A B : Type} := @map A B.
Definition list_liftA {A B} (fs : list (A -> B)) (xs : list A) : list B :=
  let g := fun a => list_fmap (fun f => f a) fs
  in concat (list_fmap g xs).
Fixpoint list_bind {A} (xs : list A) {B} (f : A -> list B) : list B :=
  match xs with
  | nil => nil
  | a :: xs' => f a ++ list_bind xs' f
  end.

Instance listF : Functor list := { fmap := @list_fmap }.
Instance listA : Applicative list := { pure := fun _ x => x :: nil
                                     ; liftA := @list_liftA }.
Instance listM : Monad list :=
  { bind := @list_bind }.

Instance listF_correct : Functor_Correct list.
Proof.
  constructor.
  * intros. simpl. apply functional_extensionality; intros x.
    induction x; simpl; auto.
    rewrite IHx; auto.
  * intros. simpl. apply functional_extensionality; intros x.
    induction x; simpl; auto.
    rewrite IHx.
    auto.
Qed.

Instance listA_correct : Applicative_Correct list.
Proof.
  constructor.
  * intros. simpl. apply functional_extensionality; intros l.
    induction l; simpl; auto.
    unfold list_liftA in *. simpl in *.
    rewrite IHl; easy.
Abort.

Instance listM_correct : Monad_Correct list.
Abort.

Lemma fmap_app : forall {A B} (f : A -> B) ls1 ls2,
      fmap f (ls1 ++ ls2) = fmap f ls1 ++ fmap f ls2.
Proof.
  induction ls1; intros; simpl; auto.
  rewrite IHls1. auto.
Qed.

(** ** The option monad *)

Definition option_fmap {A B} (f : A -> B) (x : option A) : option B :=
  match x with
  | None => None
  | Some a => Some (f a)
  end.
Definition option_liftA {A B} (f : option (A -> B)) (x : option A) : option B :=
  match f, x with
  | Some f', Some a => Some (f' a)
  | _, _ => None
  end.
Instance optionF : Functor option := { fmap := @option_fmap}.
Instance optionA : Applicative option := { pure := @Some;
                                           liftA := @option_liftA}.
Instance optionM : Monad option :=
  { bind := fun  A m B f => match m with None => None | Some a => f a end
  }.
Instance optionF_Laws : Functor_Correct option.
Proof. split.
  - intros A.
    apply functional_extensionality; intros op.
    destruct op; reflexivity.
  - intros A B C g f.
    apply functional_extensionality; intros op.
    destruct op; reflexivity.
Defined.
Instance optionA_Laws : Applicative_Correct option.
Proof. split.
  - intros A.
    apply functional_extensionality; intros op.
    destruct op; reflexivity.
  - intros A B C [f|] [g|] [a|]; reflexivity.
  - intros A B f x. reflexivity.
  - intros A B [f|] a; reflexivity.
Defined.

Instance optionM_Laws : Monad_Correct option.
Proof. split.
  - destruct a; auto.
  - intros; auto.
  - destruct ma; intros; auto.
Defined.

(** ** Option monad transformer *)
Definition optionT m (A : Type) : Type := m (option A).

Definition optionT_liftT {m} `{Monad m} {A} (x : m A) : optionT m A.
Proof.
  unfold optionT.
  refine (do a ← x; return_ (Some a)).
Defined.
Instance optionT_T : MonadTrans optionT := {liftT := @optionT_liftT}.

Definition optionT_fmap {f} `{Functor f}
                        {A B} (g : A -> B) (x : optionT f A) : optionT f B :=
  @fmap f _ _ _ (fmap g) x.
Definition optionT_liftA {f} `{Applicative f}
                         {A B} (g : optionT f (A -> B)) (x : optionT f A)
                       : optionT f B.
(*  @liftA f _ _ _ _ (fmap liftA g) x.*)
Proof.
  unfold optionT in *.
  exact (fmap liftA g <*> x).
Defined.
Definition optionT_pure {f} `{Applicative f}
                        {A} (a : A) : optionT f A := @pure f _ _ _ (pure a).
Definition optionT_bind {m} `{Monad m}
                        {A} (ma : optionT m A) {B} (f : A -> optionT m B)
                        : optionT m B.
  unfold optionT in *.
  exact (do oa ← ma;
         match oa with
         | None => pure None
         | Some a => f a
         end
  ).
Defined.

Instance optionT_F {f} `{Functor f} : Functor (optionT f) :=
    {fmap := @optionT_fmap f _}.
Instance optionT_A {f} `{Applicative f} : Applicative (optionT f) :=
  { pure := @optionT_pure f _ _;
    liftA := @optionT_liftA f _ _ }.
Instance optionT_M {m} `{Monad m} : Monad (optionT m) :=
  { bind := @optionT_bind m _ _ _ }.

(** ** The reader monad *)
Axiom Eta: forall A (B: A -> Type) (f: forall a, B a), f = fun  a=>f a.

Definition Reader (E : Type) := fun  X => E -> X.
Definition reader_fmap E A B (f : A -> B) (r : Reader E A) : Reader E B :=
  fun x => f (r x).
Definition reader_liftA E A B (f : Reader E (A -> B)) (r : Reader E A) :=
  fun x => (f x) (r x).
Definition reader_bind E A (r : Reader E A) B (f : A -> Reader E B) : Reader E B :=
  fun x => f (r x) x.

Instance readerF E : Functor (Reader E) :=
 { fmap := @reader_fmap E }.
Instance readerA E : Applicative (Reader E) :=
 { pure := fun  A (a:A) e=> a;
   liftA := @reader_liftA E }.
Instance readerM (E : Type): Monad (Reader E) :=
 { bind := @reader_bind E }.

(** ** The state monad *)

Section State.

  Variable S : Type.

  Definition State (A : Type) := S -> A * S.
  Definition state_fmap A B (f : A -> B) (st : State A) : State B :=
    fun  s => let (a,s) := st s in (f a,s).
  Definition state_liftA A B (st_f : State (A -> B)) (st_a : State A) :=
    fun  s => let (f,s) := st_f s in
              let (a,s) := st_a s in
              (f a,s).
  Definition state_bind A (st_a : State A) B  (f : A -> State B) :=
    fun  s => let (a,s) := st_a s in
              f a s.

  Definition put (x : S) : State () :=
    fun _ => (tt,x).
  Definition get : State S :=
    fun x => (x,x).
  Definition runState  {A} (op : State A) : S -> A * S := op.
  Definition evalState {A} (op : State A) : S -> A := fst ∘ op.
  Definition execState {A} (op : State A) : S -> S := snd ∘ op.

End State.
Ltac fold_evalState :=
  match goal with
  | [ |- context[fst (?c ?v)] ] => replace (fst (c v)) with (evalState c v)
                                                       by reflexivity
  end.

Arguments get {S}.
Arguments put {S}.

Instance stateF {A} : Functor (State A) :=
    { fmap := @state_fmap A }.
Instance stateA {A} : Applicative (State A) :=
    { pure := fun  A a s=> (a,s);
      liftA := @state_liftA A }.
Instance stateM {A} : Monad (State A) :=
    { bind := @state_bind A }.

Instance stateF_correct {A} : Functor_Correct (State A).
  Proof.
    split; intros;
      apply functional_extensionality; intros op;
      apply functional_extensionality; intros x;
      simpl; unfold state_fmap.
    - destruct (op x); reflexivity.
    - destruct (op x); reflexivity.
  Qed.

Instance stateA_correct {A} : Applicative_Correct (State A).
  Proof.
    split; intros;
      apply functional_extensionality; intros op;
      simpl; unfold state_liftA.
    - apply functional_extensionality; intros x.
      destruct (op x); reflexivity.
    - destruct (u op).
      destruct (v a).
      destruct (w a0).
      reflexivity.
    - reflexivity.
    - destruct (u op).
      reflexivity.
  Qed.

Instance stateM_correct {A} : Monad_Correct (State A).
  Proof.
    split; intros; simpl; unfold state_bind.
    - apply functional_extensionality; intros x.
      destruct (a x); reflexivity.
    - reflexivity.
    - apply functional_extensionality; intros x.
      destruct (ma x).
      reflexivity.
  Qed.

(** ** The Ensemble monad *)

Instance ensemble_F : Functor Ensemble.
Proof.
  split; intros A B f X.
  intros b.
  exact (exists (a : A), In _ X a /\ f a = b).
Defined.
Instance ensemble_A : Applicative Ensemble.
Proof.
  split.
  * intros A a. exact (Singleton _ a).
  * intros A B F X b.
    exact (exists f, F f /\ exists a, X a /\ f a = b).
Defined.
Instance ensemble_M : Monad Ensemble.
Proof.
  split.
  intros A X B f.
  intros b.
  exact (exists a, X a /\ f a b).
Defined.

(*
Ltac solve_ensemble_law :=
    repeat match goal with
    | [ |- forall x, _] => intros
    | [ |- ?A -> ?B ] => intros
    | [ |- ?A <-> ?B ] => split; simpl
    | [ H : In _ _ _ |- _ ] => unfold In in H
    | [ H : exists x, _ |- _] => destruct H; subst
    | [ H : _ /\ _ |- _] => destruct H; subst
    | [ H : Singleton _ _ _ |- _ ] => inversion H; subst; clear H
    | [ |- _ = _] => apply functional_extensionality

    (* irreversible *)
    (* this admit here is because the monad laws assert the results should be equal, but we only know that the propositions are equivalent *)
    | [ |- ?P = ?Q ] => assert (P <-> Q); [ | admit]
    end;
      repeat (try eexists; try split); eauto.

Instance ensemble_F_correct : Functor_Correct Ensemble.
Proof.
  split.
  * solve_ensemble_law.
  * solve_ensemble_law.
Admitted.

Instance ensemble_A_correct : Applicative_Correct Ensemble.
Proof.
  split.
  * solve_ensemble_law.
  * solve_ensemble_law.
  * solve_ensemble_law.
  * solve_ensemble_law.
Admitted.

Instance ensemble_M_correct : Monad_Correct Ensemble.
Proof.
  split.
  * solve_ensemble_law.
  * solve_ensemble_law.
  * solve_ensemble_law.
Admitted.
*)

End Instances.


Require Import Sublogic.
Require Import paths.

Lemma eq_trans_cancel_l {A} {x y z:A} (e:x=y) (e1 e2:y=z) :
  e * e1 = e * e2 -> e1 = e2.
destruct e; rewrite !eq_trans_idl; trivial.
Qed.
Lemma eq_trans_cancel_r {A} {x y z:A} (e1 e2:x=y) (e:y=z) :
  e1 * e = e2 * e -> e1 = e2.
destruct e; trivial.
Qed.

(*

Lemma transport_eql A (x y z:A) (e1:y=x)(e2:y=z):
  transport (fun x => x=z) e1 e2 = eq_sym e1 * e2.
destruct e1; simpl.
destruct e2; reflexivity.
Qed.
Lemma transport_eqr A (x y z:A) (e1:y=z)(e2:x=y):
  transport (fun z => x=z) e1 e2 = e2 * e1.
destruct e1; simpl.
reflexivity.
Qed.
*)
(*
Lemma f_app_trans {A B} {f g h:forall x:A,B x} (e1:f=g)(e2:g=h) x :
  f_app (e1*e2) x = f_app e1 x * f_app e2 x.
destruct e2; trivial.
Defined.
Lemma f_app_sym {A B} {f g:forall x:A,B x} (e:f=g) x :
  f_app (eq_sym e) x = eq_sym (f_app e x).
destruct e; trivial.
Defined.
 *)

Definition to_singl {A}{a b:A} (e:a=b) :
    existT (fun y => a = y) a eq_refl = existT(fun y=>a=y) b e :=
  match e in _=y return existT(fun c=>a=c) a eq_refl=existT(fun c=>a=c) y e
  with eq_refl => eq_refl end.

Class type_fun_ext : Prop :=
  Type_fun_ext :
    forall {A:Type}{B:A->Type}{f g:forall x:A,B x},
      (forall x, f x = g x) -> f = g.

(** h-levels *)

Definition isContr X := {x:X & forall y, y=x}.
Definition isProp X := forall x y:X, x=y.

Class prop_fun_ext : Prop :=
  Prop_fun_ext :
    forall {A:Type}{B:A->Prop}, (forall x, isProp (B x)) ->
    forall {f g:forall x:A,B x},
      (forall x, f x = g x) -> f = g.

Global Instance type_to_prop_fun_ext : type_fun_ext -> prop_fun_ext.
exact (fun ext A B Bs => ext A B).
Defined.

Lemma isContr_singl {A} (c:A) : isContr {x:A & x=c}.
exists (existT (fun x=>x=c) c eq_refl).
intros (y,e).
destruct e; reflexivity.
Defined.
Lemma isContr_singl_sym {A} (c:A) : isContr {x:A & c=x}.
exists (existT (fun x=>c=x) c eq_refl).
intros (y,e).
destruct e; reflexivity.
Defined.

Lemma isContr_intro {X} (c:X) (h:forall x, x=c) : isContr X.
exists c; trivial.
Defined.

Lemma isContr_True : isContr True.
apply isContr_intro with I.
destruct x; reflexivity.
Qed.

Lemma isContr_eqv A B : isContr A -> isContr B -> eqv A B.
intros (a,ea) (b,eb).
exists (fun _ => b) (fun _ =>a); auto.
Defined.

Lemma isContr_intro_prop {X} (x:X) (Xp:isProp X) : isContr X.
exists x.
intros; apply Xp.
Defined.

Lemma isContr_isProp {X} : isContr X -> isProp X.
red; intros.
transitivity (projT1 X0).
 apply (projT2 X0).

 symmetry; apply (projT2 X0).
Defined.

Lemma isProp_True : isProp True.
apply isContr_isProp.
apply isContr_True.
Qed.

Lemma isProp_False : isProp False.
red; intros; contradiction.
Qed.

Lemma isProp_conj (A B:Prop) :
  isProp A -> isProp B -> isProp (A/\B).
red; intros.
destruct x; destruct y.
f_equal.
 apply H.
 apply H0.
Qed.

Lemma is_prop_uip A (x y:A) :
  isProp A -> isProp (x=y).
red; intros.
assert (K : forall (r : x = y), r = H x x * eq_sym (H y x)).
 intro r; destruct r.
 destruct (H x x); reflexivity.
eapply eq_trans;[|symmetry];apply K.
Qed.

Lemma isProp_by_retr {A B} : isProp A -> retr B A -> isProp B.
intros Ap E x y.
rewrite <-(rgf _ _ E x).
rewrite <-(rgf _ _ E y).
apply f_equal with (f:=rg _ _ E).
apply Ap.
Qed.

Section isPropTheoryWithFunExt.

  Context {fun_ext : prop_fun_ext}.
(*
Axiom prop_fun_ext : forall A (P:A->Prop) (f g:forall x,P x),
  (forall x, f x = g x) -> f = g.
*)
Lemma isProp_forall : forall A (P:A->Prop),
  (forall x, isProp (P x)) -> isProp (forall x:A, P x).
red; intros.
apply Prop_fun_ext.
 intros a.
 apply H.

 intros a.
 apply H.
Qed.

Lemma isContr_forall_prop : forall A (B:A->Prop), (forall x:A, isContr (B x)) -> isContr(forall x,B x).
intros.
apply isContr_intro_prop.
 exact (fun x => projT1 (X x)).

 apply isProp_forall.
 intros.
 apply isContr_isProp; trivial.
Qed.

(* We need P to be a *set*...
Lemma prop_fun_ext' : forall A (P:A->Prop) (f g:forall x,P x),
  (forall x, f x = g x) -> f = g.
intros.
generalize (fun h => isProp_forall A (fun a=>{p:P a|p=f a}) h (fun a=>exist _ (f a) (eq_refl (f a))) (fun a => exist _ (g a) (eq_sym (H a)))).
intros.
generalize (fun h => f_equal (fun f a => proj1_sig (f a)) (H0 h)).
simpl.
intros.
apply H1.
red; intros x (p,e) (q,e').
apply sig_eq with (eq_trans e (eq_sym e')).
simpl.
 *)

Lemma isProp_iff {A B:Prop} : isProp A -> isProp B -> isProp (A<->B).
intros.
apply isProp_conj; apply isProp_forall; trivial.
Qed.

Lemma isProp_isContr X : isProp (isContr X).
red; intros (x1,e1) (x2,e2).
apply sigT_eq_intro with (e:=e2 x1); simpl.
unfold eqD.
rewrite transport_rng.
apply fun_ext; intros.
 apply is_prop_uip.
 apply isContr_isProp.
 exists x1; exact e1.
assert (h := f_eqD e2 (eq_sym (e1 x))).
red in h.
elim h.
clear h.
rewrite !transport_eq, !f_equal_cst, !f_equal_id; simpl.
rewrite eq_trans_idl, eq_sym_sym; trivial.
Qed.

Lemma isProp_isProp A : isProp (isProp A).
red; intros.
apply isProp_forall; intros a.
apply isProp_forall; intros a'.
apply is_prop_uip; trivial.
Qed.

End isPropTheoryWithFunExt.

Lemma sig_intro {A P} (p q:@sig A P) :
  (forall a, isProp (P a)) ->
  proj1_sig p = proj1_sig q ->
  p = q.
destruct p as (p,p'); destruct q as (q,q'); simpl; intros.
subst q.
f_equal.
apply H.
Defined.

Lemma sig_intro_proj1 {A P} (p q:@sig A P) Pp e :
 sig_proj1 (sig_intro p q Pp e) = e.
unfold sig_intro; simpl.
destruct p; destruct q; simpl in *.
revert p0; destruct e; simpl; intros.
destruct (Pp x p p0).
reflexivity.
Qed.
Lemma sig_proj1_intro {A} {P:A->Prop} Pp
      {p q:@sig A P} (e:p=q) :
  e = sig_intro p q Pp (sig_proj1 e).
destruct e.
simpl.
unfold sig_intro.
destruct p as (p,t); simpl.
replace (Pp p t t) with (eq_refl t); trivial.
apply is_prop_uip; trivial.
Qed.

Lemma isProp_sig :
  forall {A} {P:A->Prop}, (forall a, isProp (P a)) ->
  (forall a a', P a -> P a' -> a=a') ->
  isProp {x:A | P x}.
red; intros.
apply sig_intro; auto.
apply H0; apply proj2_sig.
Qed.

Definition isSet X :=
  forall (x y:X) (p q:x=y), p=q.

Lemma isSet_prop A :
  isProp A -> isSet A.
red; intros.
apply is_prop_uip; trivial.
Qed.

Lemma retr_paths {A B} (R:retr A B) {x y} : retr (x=y) (rf _ _ R x = rf _ _ R y).
exists (fun e => f_equal (rf _ _ R) e)
       (fun e => eq_sym (rgf _ _ R x) * (f_equal (rg _ _ R) e * rgf _ _ R y)).
intros e.
rewrite f_equal_compose.
rewrite (f_equal_qid _ (rgf _ _ R) e).
rewrite <- !eq_trans_assoc.
rewrite eq_sym_invl, eq_trans_idl.
rewrite eq_trans_assoc.
rewrite eq_sym_invl; trivial.
Qed.

  Lemma isSet_by_retr {A B} : isSet A -> retr B A -> isSet B.
intros As R x y.
eapply isProp_by_retr with (2:=retr_paths R).
red; intros; apply As.
Qed.

Lemma isSet_by_eqv {A B} : isSet A -> eqv B A -> isSet B.
intros As E.
apply isSet_by_retr with (1:=As).
apply eqv2retr; trivial.
Qed.

(** Set equivalences (isomorphisms) *)

Lemma isSet_sig X (R:X->Prop) :
   isSet X -> (forall x, isProp (R x)) -> isSet (@sig X R).
red; intros.
assert (forall e:x=y, e = sig_intro x y H0 (sig_proj1 e)).
 destruct e.
 simpl.
 unfold sig_intro.
 destruct x; simpl.
 replace (H0 x r r) with (eq_refl r); trivial.
 apply is_prop_uip; trivial.
rewrite (H1 p), (H1 q).
f_equal.
apply H.
Qed.

Lemma isSet_sigma X (R:X->Type) :
   isSet X -> (forall x, isSet (R x)) -> isSet (@sigT X R).
intros Xs Rs.
red; intros.
rewrite (sigT_proj1_intro p), (sigT_proj1_intro q).
pose (f:=fun c:{e1:projT1 x=projT1 y & eqD R e1 (projT2 x) (projT2 y)} => sigT_eq_intro x y (projT1 c) (projT2 c)).
change (f (existT _ (sigT_proj1 p) (sigT_proj2 p)) =
        f (existT _ (sigT_proj1 q) (sigT_proj2 q))).
apply f_equal with (f:=f).
eapply sigT_eq_intro with (e:=Xs _ _ _ _); simpl.
apply Rs.
Qed.

Section isSetTheoryWithFunExt.

  Context {fun_ext : type_fun_ext}.

  Lemma isContr_forall A B:
    (forall x:A, isContr (B x)) -> isContr(forall x,B x).
intros.
apply isContr_intro_prop.
 exact (fun x => projT1 (X x)).

 intros f g.
 apply fun_ext; intros x.
 apply isContr_isProp with (1:=X x).
Defined.

Definition fun_ext_singl_raw {A B}{f g:forall x:A,B x}(e:forall x, f x =g x) :
    (fun x => existT (fun y => f x = y) (f x) eq_refl) =
    (fun x => existT (fun y => f x = y) (g x) (e x)).
Proof Type_fun_ext (fun x=> to_singl (e x)).

Definition fun_ext_singl {A B}{f g:forall x:A,B x}(e:forall x, f x =g x) : f=g :=
  f_equal (fun (h : forall x, {u:_ & f x = u}) x => projT1 (h x))
          (fun_ext_singl_raw e).

Definition fun_ext_eqv {A B} {f g:forall x:A,B x} (w:f=g) :
  fun_ext_singl (f_app w) = w.
destruct w; simpl.
unfold fun_ext_singl.
replace (fun_ext_singl_raw (f:=f)(g:=f)(f_app eq_refl)) with
   (eq_refl (fun x => existT (fun y => f x = y) (f x) eq_refl)).
 reflexivity.

 apply is_prop_uip.
 apply isContr_isProp.
 apply isContr_forall.
 intros.
 apply isContr_singl_sym.
Qed.

Definition fun_ext_eqv2 {A B} {f g:forall x:A,B x} (w:forall x,f x=g x) :
  f_app (fun_ext_singl w) = w.
apply fun_ext; intros x.
unfold fun_ext_singl, f_app.
eapply eq_trans.
 apply f_equal_compose with
  (f0:=fun f0=>f0 x) (g0:= (fun (h:forall x,{u:_& f x = u}) x => projT1 (h x)))
  (e:=fun_ext_singl_raw w).
eapply eq_trans.
 symmetry; apply f_equal_compose with
  (f0:=fun x=>projT1 x) (g0:= fun h:forall x,{u:B x&f x=u} => h x)
  (e:=fun_ext_singl_raw w).
replace  (f_equal (fun h : forall x,{u:_&f x = u} => h x)
                  (fun_ext_singl_raw w))
  with (to_singl (w x)).
 unfold to_singl.
 destruct (w x); reflexivity.

 apply is_prop_uip.
 apply isContr_isProp.
 apply isContr_singl_sym.
Qed.

  Lemma isProp_forallT : forall {A B},
    (forall x:A, isProp (B x)) -> isProp (forall x, B x).
red; intros.
apply fun_ext; intros a.
apply H.
Qed.

  Lemma isProp_prod : forall {A B}, isProp A -> isProp B -> isProp (prod A B).
intros A B Ap Bp (x1,y1) (x2,y2).
f_equal; auto.
Qed.

(* fun_ext *)
  Lemma isProp_fun_eq {A B} {f g:forall x:A,B x} (Bp : forall x, isSet (B x)) : isProp (f=g).
intros e1 e2.
rewrite <-(fun_ext_eqv e1), <-(fun_ext_eqv e2).
apply f_equal with (f:=fun_ext_singl).
unfold f_app.
apply fun_ext.
intros.
apply Bp.
Qed.

Lemma isSet_forall : forall {A B},
  (forall x:A, isSet (B x)) -> isSet (forall x, B x).
red; intros; apply isProp_fun_eq; trivial.
Qed.

Lemma prop_eqv A B (As:isSet A)(e1 e2:eqv A B) :
  (forall a, ef e1 a = ef e2 a) ->
  e1 = e2.
assert (Bs := isSet_by_eqv As (eqv_sym e1)).
destruct e1 as (f,g,gf,fg); destruct e2 as (f',g',gf',fg'); simpl; intros.
assert (forall b, g b = g' b).
 intros.
 transitivity (g (f (g b))).
  symmetry; trivial.
 transitivity (g' (f' (g b))).
  rewrite gf,gf'; trivial.
  rewrite <-H,fg; trivial.
apply fun_ext in H.
apply fun_ext in H0.
revert gf' fg'.
destruct H; destruct H0.
intros.
apply f_equal2 with (f:=mkE f g).
 apply (isProp_forall _).
 red; intros; apply As.

 apply (isProp_forall _); intros.
 red; intros; apply Bs.
Qed.

(* Converse *)

  Hypothesis fext : forall A B, (forall x:A, isContr (B x)) -> isContr(forall x,B x).

  Lemma fun_ext_from_contr_forall : type_fun_ext.
red; intros.
pose (C x := {b:B x & b = f x}).
specialize fext with (1:=fun x=> isContr_singl (f x)).
apply isContr_isProp in fext.
red in fext.
specialize fext with
 (x:=fun x => existT (fun c=>c=f x) (f x) eq_refl)
 (y:=fun x => existT (fun c=>c=f x) (g x) (eq_sym (H x))).
simpl in fext.
pose (f1 :=fun (h:forall x:A, C x) x => projT1 (h x)).
apply f_equal with (f:=f1) in fext.
exact fext.
Qed.

End isSetTheoryWithFunExt.

(** Prop-truncation (with resizing since tr X : Prop !) *)

  Definition tr (X:Type) : Prop := forall P:Prop, isProp P -> (X->P) -> P.

  Definition tr_i {X} (x:X) : tr X := fun _ _ f => f x.
(*Definition tr_ind_nodep {X P} (Pp:isProp P) (h:X->P) (t:tr X) : P :=
  t P Pp h.*)

(*Parameter tr : Type -> Prop.
Parameter tr_prop : forall X, isProp (tr X).
Parameter tr_i : forall {X}, X -> tr X.*)
(*Axiom tr_ind_nodep : forall {X P:Type},
  isProp P -> (X->P) -> tr X -> P.*)

  Axiom tr_elim : forall {P:Type}, isProp P -> tr P -> P.

  Lemma tr_elim_eq : forall P (Pp:isProp P) x, tr_elim Pp (tr_i x) = x.
intros.
apply Pp.
Qed.

  Lemma tr_elim_prop {P:Prop} :
    isProp P -> tr P -> P.
intros Pp t; apply t; trivial.
Defined.

  Lemma tr_map {X Y} (f:X->Y) (t:tr X) : tr Y.
intros P Pp yp.
apply t.
 exact Pp.

 auto.
Qed.

Lemma tr_ind_nodep : forall {X P},
  isProp P -> (X->P) -> tr X -> P.
intros.
apply tr_map in X0; trivial.
apply tr_elim in X0; trivial.
Qed.

Lemma tr_ind_nodep_eq {X P} (Pp:isProp P) (f:X->P) x :
  tr_ind_nodep Pp f (tr_i x) = f x.
apply Pp.
Qed.

(*
Lemma tr_elim : forall {P:Type},
  isProp P -> tr P -> P.
intros P Pp t.
assert (iPp : isProp (itr P)).
 apply @isProp_by_retr with (A:=P); trivial.

apply tr_map with (1:=itr_i _) in t.
 apply tr_elim_prop in t.
apply @coe with (A:=itr P).
2:appl
apply (coe (prop_univ
*)
(*Lemma tr_elim : forall {P:Type},
  isProp P -> tr P -> P.
intros.
apply @tr_ind_nodep with (X:=P); trivial.
Qed.
*)

Definition tr_f {P:Type} (tt:tr(tr P)) : tr P :=
  fun Q Qp (f:P->Q) => tt Q Qp (fun t => t Q Qp f).

Module trSub <: ConsistentSublogic.
  Definition Tr := fun P:Prop => tr P.
  Definition TrI (P:Prop) (p:P) : Tr P := tr_i p.
  Definition TrP (P:Prop) (p:Tr (Tr P)) : Tr P := tr_f p.
  Definition TrMono (P Q:Prop) (f:P->Q) (p:Tr P) : Tr Q := tr_map f p.
  Notation "# T" := (Tr T).
  Definition TrCons : ~ Tr False := tr_elim_prop isProp_False.
End trSub.
Module TrSubThms <: SublogicTheory := BuildConsistentSublogic trSub.
Import trSub TrSubThms.
Lemma isL_tr : forall P, isL (tr P).
red; intros.
apply tr_f; trivial.
Qed.
Hint Resolve isL_tr.

Instance Tr_morph : Proper (iff ==> iff) Tr.
do 2 red; intros.
split; apply TrMono; apply H.
Qed.

Definition tr_ind_tr {X} (P : Type)
           (h:X -> tr P) (x:tr X) : tr P :=
  tr_f (tr_map h x).

Lemma descr :
  forall {A} {P:A->Prop}, (forall a, isProp (P a)) ->
  (forall a a', P a -> P a' -> a=a') ->
  (tr {a:A | P a}) -> {a:A | P a}.
intros.
elim H1 using tr_ind_nodep; trivial.
apply isProp_sig; trivial.
Qed.

Lemma descr_eq A (P:A->Prop) (Pp:forall a, isProp(P a))
      (uniq : forall a a', P a -> P a' -> a=a')
      (w:tr{a|P a}) (x:A) (px : P x) :
  proj1_sig (descr Pp uniq w) = x.
apply uniq; trivial.
exact (proj2_sig (descr Pp uniq w)).
Qed.

Lemma tr_ex_sig {A} {P:A->Prop} :
  (tr (exists x, P x)) <-> tr{x|P x}.
split; intros h; elim h using tr_ind_tr; intros; auto.
 destruct H; apply tr_i; eauto.
 destruct X; apply tr_i; eauto.
Qed.

Lemma tr_neg X : tr (X->False) -> X -> False.
intros.
elim H using tr_ind_nodep; intros.
 apply isProp_False.
auto.
Qed.

Section Truncation.

Context {fun_ext : prop_fun_ext}.

Lemma tr_prop X : isProp (tr X).
apply (isProp_forall _); intros P.
apply (isProp_forall _); intros Pp.
apply (isProp_forall _); trivial.
Qed.

Inductive itr (A:Type) : Prop := itr_i (_:A).
Lemma itr_prop {A} : isProp A -> isProp (itr A).
intros As.
apply @isProp_by_retr with (A:=A); trivial.
exists (fun i:itr A => tr_elim As (let (i) := i in tr_i i)) (fun i => itr_i _ i).
intros; destruct a.
replace (tr_elim As (tr_i a)) with a; trivial.
Qed.

Lemma tr_ind {X} (P : tr X -> Type) :
    (forall t, isProp (P t)) ->
    (forall x, P (tr_i x)) ->
    forall t:tr X, P t.
intros Pp h t.
elim t using tr_ind_nodep; trivial.
intros x.
replace t with (tr_i x); trivial.
apply tr_prop.
Qed.

Lemma tr_ind_eq {X} (P:tr X->Type) Pp h x :
  tr_ind P Pp h (tr_i x) = h x.
apply Pp.
Qed.

Section TruncationSetInduction.
  Context
    {X : Type}
    (P : tr X -> Type)
    (Ps : forall x, isSet (P x))
    (h : forall (x:X), P (tr_i x))
    (hcomp :
       forall x y, eqD P (tr_prop X (tr_i x) (tr_i y)) (h x) (h y)).

  Let P' (x:tr X) := {p:P x | tr{x':X|eqD P (tr_prop X (tr_i x') x) (h x') p}}.

  Let P'_prop x : isProp (P' x).
apply isProp_sig.
 intros; apply tr_prop.

 intros p1 p2 i1 i2.
 elim i1 using tr_ind; clear i1.
  red; intros; apply Ps.
 intros (x1,e1).
 elim i2 using tr_ind; clear i2.
  red; intros; apply Ps.
 intros (x2,e2).
  red in e1,e2.
  rewrite <-e1,<-e2.
  rewrite <- (hcomp x1 x2).
  transitivity (transport P (tr_prop _ (tr_i x1) (tr_i x2) * tr_prop _ (tr_i x2) x) (h x1)).
   f_equal.
   apply is_prop_uip; apply tr_prop.

   rewrite transport_trans; trivial.
Qed.

 Lemma tr_ind_set (q:tr X) : P q.
assert (p:P' q).
 apply tr_ind.
  intros; apply P'_prop.

  intros x ; exists (h x).
  apply tr_i; exists x.
  replace (tr_prop _ (tr_i x) (tr_i x)) with (eq_refl (tr_i x)).
   reflexivity.

   apply is_prop_uip; apply tr_prop.
exact (projT1 p).
Defined.

 Lemma tr_ind_set_eq (x:X) :
  tr_ind_set (tr_i x) = h x.
unfold tr_ind_set.
rewrite tr_ind_eq; simpl.
reflexivity.
Qed.

End TruncationSetInduction.

Lemma tr_ind_set_nodep X P (Ps:isSet P) (h:X->P) (hcomp : forall x y, h x = h y) (q:tr X) : P.
apply tr_ind_set with (P0:=fun _ =>P) (h0:=h); trivial.
intros.
destruct (tr_prop X (tr_i x) (tr_i y)); apply hcomp.
Defined.

Lemma tr_ind_set_nodep_ind X P Ps h hcomp Q (Qs:forall p, isProp(Q p)) q :
  (forall x, Q (h x)) ->
  Q (tr_ind_set_nodep X P Ps h hcomp q) .
intros.
unfold tr_ind_set_nodep.
unfold tr_ind_set.
elim q using tr_ind.
 intros; apply Qs.

 intros x; rewrite tr_ind_eq; simpl.
 apply X0.
Qed.

Hint Resolve tr_prop isProp_forall isProp_conj isProp_iff.

(*
Lemma prop_fun_ext_type {A B} (Bp:forall x:A, isProp (B x)) {f g:forall x:A,B x} :
  (forall x, f x = g x) -> f = g.
intros eqfg.
pose (f' := fun x => itr_i _ (f x)).
pose (g' := fun x => itr_i _ (g x)).
assert (f' = g').
 apply fun_ext;[intros; apply itr_prop; apply Bp|].
 intros x.
 apply f_equal with (f:=itr_i _).
 apply eqfg.
assert (f = fun x => tr_elim (Bp x) (f' x)).
red in fun_ext.

pose (f' := fun x => tr_i (f x)).
pose (g' := fun x => tr_i (g x)).
assert (f' = g').
 apply fun_ext;[intros; apply tr_prop|].
 intros x.
 apply f_equal with (f:=tr_i).
 apply eqfg.
assert (f = fun x => tr_elim (Bp x) (f' x)).
red in fun_ext.

unfold tr_elim.
_ *)

End Truncation.
Global Hint Resolve tr_prop isProp_forall isProp_conj isProp_iff.
Arguments tr_ind {_} X P _ _ t.
Arguments tr_prop {_} X x y.
Arguments isProp_isProp {_} A _ _.
Arguments isProp_forall {_} A P _ x y.

(** Predicate extensionality: consequence of univalence *)
Definition iffT A B := tr A <-> tr B.

Lemma iffT_trans {A B C}: iffT A B -> iffT B C -> iffT A C.
intros (?,?) (?,?); split; auto.
Defined.

Class type_predicate_ext :=
  Type_pred_ext :
    forall {A} {P Q:A->Type},
      (forall a, isProp (P a)) ->
      (forall a, isProp (Q a)) ->
      (forall a, iffT (P a) (Q a)) ->
      P = Q.

Section PredExt.

  Context
    {fun_ext : type_fun_ext}
    {pred_ext :type_predicate_ext}.

(*
Lemma isProp_forall' A (P:A->Prop) :
  (forall x, isProp (P x)) -> isProp (forall x:A, P x).
red; intros.
assert (P = fun _ => True).
 apply pred_ext; auto.
 red; intros.
 destruct x0; destruct y0; reflexivity.
 split; trivial.
 generalize x y.
rewrite H0.
intros.
*)

Definition pred_eqv {A} {P Q:A->Type} (e:P=Q) a : iffT (P a) (Q a).
Proof conj (fun x => match f_equal (fun A x=>tr (A x)) e in _=X return X a with eq_refl => x end)
           (fun x => match eq_sym (f_equal (fun A x=>tr(A x)) e) in _=X return X a with eq_refl => x end).

(* Version of pred_ext that returns the reflexivity when
   given the identity equivalence, so it is the inverse of pred_eqv *)
Definition pred_ext' {A} {P Q:A->Type}
  (Pp : forall a, isProp (P a)) (Qp : forall a, isProp (Q a))
  (e:forall a, iffT (P a) (Q a)) : P=Q :=
  eq_sym (Type_pred_ext Pp Pp (pred_eqv eq_refl)) *
  Type_pred_ext Pp Qp e.

Definition pred_ext_eqv {A} {P Q:A->Type}
           (Pp : forall a, isProp (P a)) (Qp : forall a, isProp (Q a))
           (w:P=Q) :
  pred_ext' Pp Qp (pred_eqv w) = w.
revert Qp; destruct w.
simpl; intros.
unfold pred_ext'.
replace Qp with Pp.
2:apply isProp_forall; intros; apply isProp_isProp.
destruct (Type_pred_ext Pp Pp (pred_eqv eq_refl)); reflexivity.
Qed.

Lemma isProp_pred_eq {A} {P Q:A->Type} :
  (forall a, isProp (P a)) ->
  (forall a, isProp (Q a)) ->
  isProp (P=Q).
intros Pp Qp e1 e2.
rewrite <-(pred_ext_eqv Pp Qp e1), <-(pred_ext_eqv Pp Qp e2).
apply f_equal with (f:=pred_ext' Pp Qp).
apply isProp_forall; intros a.
apply isProp_iff; auto with *.
Qed.

Lemma prop_ext (P Q:Type) (Pp:isProp P) (Qp:isProp Q) :
  iffT P Q -> P=Q.
intros.
apply (@f_app _ _ (fun _ => P) (fun _ =>Q)) with (2:=tt).
apply pred_ext; auto.
Qed.

End PredExt.

(** Quotient *)

Require Import Setoid.

Module Quo.

Section Quo.
Context
  {fun_ext : type_fun_ext}
  {pred_ext : type_predicate_ext}.

Class isClass {X} (R:X->X->Prop) (P:X->Type) := mkCl {
  cl_prop : forall x, isProp (P x);
  wit : X;
  wit_ok : P wit;
  uniq :  forall y, iffT (P y) (R wit y)
}.

Class isRel {X} (R:X->X->Prop) := {
  isP : forall x y, isProp (R x y);
  isR :> Equivalence R
  }.

Instance isClass_eq {X} {R:X->X->Prop} (Rr:isRel R) x :
  isClass R (fun y => R x y).
exists x; intros; auto with *.
 apply isP.
split; trivial.
Qed.

Definition quo (X:Type) (R:X->X->Prop) :=
  { P : X->Type | tr (isClass R P) }.

Lemma isProp_quo_proj1 {X R} (x:quo X R) (z:X) :
  isProp (proj1_sig x z).
destruct x as (x,clx); simpl.
elim clx using tr_ind_nodep; intros.
 apply (isProp_isProp _).

 apply X0.
Qed.

Lemma quo_proj1_wit {X R} (q:quo X R) :
  tr {x:_ & proj1_sig q x}.
destruct q as (x,clx); simpl.
elim clx using tr_ind_nodep; intros.
 apply (tr_prop _).

 apply tr_i.
 exists wit.
 apply X0.
Qed.

Lemma quo_ext X R (Rr:isRel  R) (q1 q2:quo X R) :
  (forall x, iffT (proj1_sig q1 x) (proj1_sig q2 x)) ->
  q1 = q2.
intros.
apply sig_intro.
 intros.
 apply tr_prop.

 apply Type_pred_ext; trivial.
  apply isProp_quo_proj1.
  apply isProp_quo_proj1.
Qed.

Lemma isSet_quo X (R:X->X->Prop) (Rr:isRel R) : isSet (quo X R).
red; intros.
rewrite (sig_proj1_intro (fun _ => tr_prop _) p).
rewrite (sig_proj1_intro (fun _ => tr_prop _) q).
f_equal.
apply isProp_pred_eq; apply isProp_quo_proj1.
Qed.

Definition quo_i {X} {R:X->X->Prop} (Rr:isRel R) (x:X) : quo X R :=
  exist (fun P => tr(isClass R P))
    (fun y => R x y)
    (tr_i (isClass_eq Rr x)).

Lemma quo_i_eq {X R} (Rr:isRel  R) {x y:X} :
  quo_i _ x = quo_i _ y <-> R x y.
split.
 intros.
 apply sig_proj1 in H; simpl in H.
 apply (coe (eq_sym (f_app H y))).
 reflexivity.

 intros; apply quo_ext; simpl; intros; trivial.
 red.
 split; apply tr_map; rewrite H; auto.
Qed.

Lemma class_quo_proj1 X R (Rr:isRel R) (q:quo X R) w :
  iffT (proj1_sig q w) (q = quo_i _ w).
split; apply tr_map; intros.
 apply quo_ext; trivial.
 intros; simpl.
 assert (Pp := isProp_quo_proj1 q).
 destruct q as (P,Pc); simpl in *.
 elim Pc using tr_ind_nodep; intros.
  apply isProp_iff; auto with *.
 destruct X1 as (_,w',_,eqvP).
 red.
 transitivity (tr(R w' x)); auto.
  apply eqvP.

  assert (tr (R w' w)).
   destruct eqvP with w.
   apply H; apply tr_i; trivial.
  split; intros.
   elim H using tr_ind_nodep; auto with *.
   clear H; intro.
   elim H0 using tr_ind_nodep; auto with *.
   clear H0; intro.
   apply tr_i; rewrite <-H; trivial.

   elim H using tr_ind_nodep; auto with *.
   clear H; intro.
   elim H0 using tr_ind_nodep; auto with *.
   clear H0; intro.
   apply tr_i; rewrite H; trivial.

 subst q; simpl.
 reflexivity.
Qed.

Lemma quo_ind {X} {R:X->X->Prop} (Rr:isRel R) (P:quo X R->Type):
  (forall x, isProp (P x)) ->
  (forall (x:X), P (quo_i Rr x)) ->
  forall x:quo X R, P x.
intros Pp h x.
assert (w := quo_proj1_wit x).
elim w using tr_ind_nodep; auto.
clear w; intros (w,wdef).
apply tr_i in wdef; apply class_quo_proj1 with (Rr:=Rr) in wdef.
elim wdef using tr_ind_nodep; auto with *.
clear wdef; intros wdef.
rewrite wdef; trivial.
Qed.

Lemma quo_ind_eq {X} {R:X->X->Prop} {Rr:isRel R} {P:quo X R->Type} Pp h (x:X) :
  quo_ind _ P Pp h (quo_i _ x) = h x.
apply Pp.
Qed.

Section QuotientSetInduction.
  Variable X : Type.
  Variable R : X->X->Prop.
  Variable Rr : isRel R.
  Variable P : quo X R -> Type.
  Variable Ps : forall x, isSet (P x).
  Variable h : forall (x:X), P (quo_i _ x).
  Variable hcomp :
    forall x y (r:R x y), eqD P (proj2 (quo_i_eq _) r) (h x) (h y).

  Let img x p := {x':X & { e: quo_i _ x' = x | eqD P e (h x') p}}.

  Lemma img_ex q : img (quo_i Rr q) (h q).
exists q.
exists (eq_refl (quo_i _ q)).
reflexivity.
Defined.

  Lemma img_uniq q (p p':P q) : img q p -> img q p' -> p = p'.
intros (x0,(eqx0,imgx0)) (x1,(eqx1,imgx1)).
rewrite <- imgx0, <- imgx1.
clear imgx0 imgx1.
revert eqx0; destruct eqx1.
simpl; intros.
assert (R x0 x1).
 apply quo_i_eq in eqx0; trivial.
replace eqx0 with (proj2 (quo_i_eq _) H).
 apply hcomp.

 apply isSet_quo; trivial.
Qed.

  Lemma img_uniq_tr q (p p':P q) : tr (img q p) -> tr (img q p') -> p=p'.
intros.
elim H using tr_ind_nodep; intros.
 red; intros; apply Ps.
elim H0 using tr_ind_nodep; intros.
 red; intros; apply Ps.
apply img_uniq; trivial.
Qed.

  Let imgP x := tr { p:P x | tr (img x p) }.

  Lemma quo_imgP (q:quo X R) : imgP q.
elim q using (quo_ind Rr).
 intros; apply tr_prop.
intros.
apply tr_i; exists (h x).
apply tr_i; apply img_ex.
Qed.

 Lemma quo_ind_set (q:quo X R) : P q.
assert (p' := quo_imgP q).
apply descr in p'.
 exact (proj1_sig p').

 intros; apply tr_prop.

 apply img_uniq_tr.
Defined.

 Lemma quo_ind_set_eq (x:X) :
  quo_ind_set (quo_i _ x) = h x.
unfold quo_ind_set.
apply descr_eq.
apply tr_i; apply img_ex.
Qed.

End QuotientSetInduction.

 Lemma quo_ind_set_nodep {X} {R:X->X->Prop} (Rr:isRel R) {P:Type}:
  isSet P ->
  forall h:X->P,
  (forall x y (r:R x y), h x = h y) ->
  quo X R -> P.
intros.
apply quo_ind_set with (Rr:=Rr) (P:=fun _ => P) (h:=h); trivial.
intros.
destruct (proj2 (quo_i_eq _) r); simpl; auto.
apply H0; trivial.
Defined.

End Quo.
End Quo.
Export Quo.

Module Quo1.

Section Quo.
Context
  {fun_ext : type_fun_ext}
  {pred_ext : type_predicate_ext}.

Class isClass {X} (R:X->X->Prop) (P:X->Type) := mkCl {
  cl_prop : forall x, isProp (P x);
  wit : X;
  wit_ok : P wit;
  uniq :  forall y, iffT (P y) (R wit y)
}.

Class isRel {X} (R:X->X->Prop) := {
  isP : forall x y, isProp (R x y);
  isR :> Equivalence R
  }.

Instance isClass_eq {X} {R:X->X->Prop} (Rr:isRel R) x :
  isClass R (fun y => R x y).
exists x; intros; auto with *.
 apply isP.
split; trivial.
Qed.

Definition quo (X:Type) (R:X->X->Prop) :=
  { P : X->Type | tr (isClass R P) }.

Lemma isProp_quo_proj1 {X R} (x:quo X R) (z:X) :
  isProp (proj1_sig x z).
destruct x as (x,clx); simpl.
elim clx using tr_ind_nodep; intros.
 apply (isProp_isProp _).

 apply X0.
Qed.

Lemma quo_proj1_wit {X R} (q:quo X R) :
  tr {x:_ & proj1_sig q x}.
destruct q as (x,clx); simpl.
elim clx using tr_ind_nodep; intros.
 apply (tr_prop _).

 apply tr_i.
 exists wit.
 apply X0.
Qed.

Lemma quo_ext X R (Rr:isRel  R) (q1 q2:quo X R) :
  (forall x, iffT (proj1_sig q1 x) (proj1_sig q2 x)) ->
  q1 = q2.
intros.
apply sig_intro.
 intros.
 apply tr_prop.

 apply Type_pred_ext; trivial.
  apply isProp_quo_proj1.
  apply isProp_quo_proj1.
Qed.

Lemma isSet_quo X (R:X->X->Prop) (Rr:isRel R) : isSet (quo X R).
red; intros.
rewrite (sig_proj1_intro (fun _ => tr_prop _) p).
rewrite (sig_proj1_intro (fun _ => tr_prop _) q).
f_equal.
apply isProp_pred_eq; apply isProp_quo_proj1.
Qed.

Definition quo_i {X} {R:X->X->Prop} (Rr:isRel R) (x:X) : quo X R :=
  exist (fun P => tr(isClass R P))
    (fun y => R x y)
    (tr_i (isClass_eq Rr x)).

Lemma quo_i_eq {X R} (Rr:isRel  R) {x y:X} :
  quo_i _ x = quo_i _ y <-> R x y.
split.
 intros.
 apply sig_proj1 in H; simpl in H.
 apply (coe (eq_sym (f_app H y))).
 reflexivity.

 intros; apply quo_ext; simpl; intros; trivial.
 split; apply tr_map; intros.
  transitivity x; auto with *.
  transitivity y; auto with *.
Qed.

Lemma class_quo_proj1 X R (Rr:isRel R) (q:quo X R) w :
  iffT (proj1_sig q w) (q = quo_i _ w).
split; apply tr_map; intros.
 apply quo_ext; trivial.
 intros; simpl.
 assert (Pp := isProp_quo_proj1 q).
 destruct q as (P,Pc); simpl in *.
 elim Pc using tr_ind_nodep; intros.
  apply isProp_iff; auto with *.
 destruct X1 as (_,w',_,eqvP).
 red.
 transitivity (tr(R w' x)); auto.
  apply eqvP.

  assert (tr (R w' w)).
   destruct eqvP with w.
   apply H; apply tr_i; trivial.
  split; intros.
   elim H using tr_ind_nodep; auto with *.
   clear H; intro.
   elim H0 using tr_ind_nodep; auto with *.
   clear H0; intro.
   apply tr_i; rewrite <-H; trivial.

   elim H using tr_ind_nodep; auto with *.
   clear H; intro.
   elim H0 using tr_ind_nodep; auto with *.
   clear H0; intro.
   apply tr_i; rewrite H; trivial.

 subst q; simpl.
 reflexivity.
Qed.

Lemma quo_ind {X} {R:X->X->Prop} (Rr:isRel R) (P:quo X R->Type):
  (forall x, isProp (P x)) ->
  (forall (x:X), P (quo_i Rr x)) ->
  forall x:quo X R, P x.
intros Pp h x.
assert (w := quo_proj1_wit x).
elim w using tr_ind_nodep; auto.
clear w; intros (w,wdef).
apply tr_i in wdef; apply class_quo_proj1 with (Rr:=Rr) in wdef.
elim wdef using tr_ind_nodep; auto with *.
clear wdef; intros wdef.
rewrite wdef; trivial.
Qed.

Lemma quo_ind_eq {X} {R:X->X->Prop} {Rr:isRel R} {P:quo X R->Type} Pp h (x:X) :
  quo_ind _ P Pp h (quo_i _ x) = h x.
apply Pp.
Qed.

Section QuotientSetInduction.
  Variable X : Type.
  Variable R : X->X->Prop.
  Variable Rr : isRel R.
  Variable P : quo X R -> Type.
  Variable Ps : forall x, isSet (P x).
  Variable h : forall (x:X), P (quo_i _ x).
  Variable hcomp :
    forall x y (r:R x y), eqD P (proj2 (quo_i_eq _) r) (h x) (h y).

  Let img x p := {x':X & { e: quo_i _ x' = x | eqD P e (h x') p}}.

  Lemma img_ex q : img (quo_i Rr q) (h q).
exists q.
exists (eq_refl (quo_i _ q)).
reflexivity.
Defined.

  Lemma img_uniq q (p p':P q) : img q p -> img q p' -> p = p'.
intros (x0,(eqx0,imgx0)) (x1,(eqx1,imgx1)).
rewrite <- imgx0, <- imgx1.
clear imgx0 imgx1.
revert eqx0; destruct eqx1.
simpl; intros.
assert (R x0 x1).
 apply quo_i_eq in eqx0; trivial.
replace eqx0 with (proj2 (quo_i_eq _) H).
 apply hcomp.

 apply isSet_quo; trivial.
Qed.

  Lemma img_uniq_tr q (p p':P q) : tr (img q p) -> tr (img q p') -> p=p'.
intros.
elim H using tr_ind_nodep; intros.
 red; intros; apply Ps.
elim H0 using tr_ind_nodep; intros.
 red; intros; apply Ps.
apply img_uniq; trivial.
Qed.

  Let imgP x := tr { p:P x | tr (img x p) }.

  Lemma quo_imgP (q:quo X R) : imgP q.
elim q using (quo_ind Rr).
 intros; apply tr_prop.
intros.
apply tr_i; exists (h x).
apply tr_i; apply img_ex.
Qed.

 Lemma quo_ind_set (q:quo X R) : P q.
assert (p' := quo_imgP q).
apply descr in p'.
 exact (proj1_sig p').

 intros; apply tr_prop.

 apply img_uniq_tr.
Defined.

 Lemma quo_ind_set_eq (x:X) :
  quo_ind_set (quo_i _ x) = h x.
unfold quo_ind_set.
apply descr_eq.
apply tr_i; apply img_ex.
Qed.

End QuotientSetInduction.

 Lemma quo_ind_set_nodep {X} {R:X->X->Prop} (Rr:isRel R) {P:Type}:
  isSet P ->
  forall h:X->P,
  (forall x y (r:R x y), h x = h y) ->
  quo X R -> P.
intros.
apply quo_ind_set with (Rr:=Rr) (P:=fun _ => P) (h:=h); trivial.
intros.
destruct (proj2 (quo_i_eq _) r); simpl; auto.
apply H0; trivial.
Defined.

End Quo.
End Quo1.

(** Predicate extensionality: consequence of univalence *)
Class predicate_ext :=
  Pred_ext :
    forall {A} {P Q:A->Prop},
      (forall a, isProp (P a)) ->
      (forall a, isProp (Q a)) ->
      (forall a, P a <-> Q a) ->
      P = Q.

(* Set-truncation form Prop-truncation + quotients *)

Section SetTrunc.
Context
  {fun_ext : type_fun_ext}
  {pred_ext : type_predicate_ext}.

Definition tr0 X := quo X (fun x y => tr(x=y)).

Instance isRel_treq {X} : isRel (fun x y:X => tr(x=y)).
split; auto with *.
split ;red; intros.
 apply tr_i; reflexivity.

 elim H using tr_ind_tr; intros; auto.
 apply tr_i; symmetry; trivial.

 elim H using tr_ind_tr; intros.
 elim H0 using tr_ind_tr; intros; auto.
 apply tr_i; transitivity y; trivial.
Qed.

Definition tr0_i {X} (x:X) : tr0 X := quo_i _ x.

Definition tr0_ind_set {X} (P:tr0 X->Type) :
  (forall x, isSet (P x)) ->
  (forall x:X, P (tr0_i x)) ->
  forall x', P x'.
intros.
apply (quo_ind_set _ _) with (h:=X0); trivial.
red.
intros.
elim r using tr_ind.
 red; intros; apply H.

 clear r; intros e.
 destruct e.
 assert (proj2 (quo_i_eq _) (tr_i (eq_refl x)) = eq_refl (quo_i _ x)).
  apply isSet_quo; auto with *.
 rewrite H0; reflexivity.
Defined.

Lemma tr0_ind_set_eq {X} (P:tr0 X->Type)
  (Pp:forall x, isSet (P x))
  (h:forall x:X, P (tr0_i x)) (x:X) :
  tr0_ind_set P Pp h (tr0_i x) = h x.
unfold tr0_ind_set.
apply quo_ind_set_eq.
Qed.

End SetTrunc.

Section PropUnivalence.

  Definition prop_univ :=
    forall (A B:Prop), isProp A -> isProp B -> (A<->B) -> A=B.

  Hypothesis univ : prop_univ.
  Hypothesis fun_ext : type_fun_ext.

  Lemma pred_ext_from_prop_fun_ext :
    forall A (P Q : A -> Prop),
       (forall a, isProp (P a)) ->
       (forall a, isProp (Q a)) -> (forall a : A, P a <-> Q a) -> P = Q.
intros A P Q Pp Qp e.
apply fun_ext; intros a.
apply univ; trivial.
Qed.

End PropUnivalence.

(** Univalence for sets *)

Section SetUnivalence.

  Definition set_univ :=
    forall {A B:Type}{f:A->B}{g:B->A},
      isSet A ->
      (forall a, g (f a) = a) /\ (forall b, f (g b) = b) ->
      A=B.
  Definition set_univ_comp (ax:set_univ) :=
    forall {A B:Type}{f:A->B}{g:B->A}{As:isSet A}
      (e:(forall a, g (f a) = a) /\ (forall b, f (g b) = b)),
    transport (fun X=>X) (ax _ _ _ _ As e) = f.

  Definition uni (ax:set_univ) {A B} As (e:eqv A B) : A=B :=
    ax A B _ _ As (conj (egf e) (efg e)).

  Lemma univ_inv {A B:Type} : A=B -> eqv A B.
intros e.
exists (transport (fun X=>X) e) (transport (fun X=>X) (eq_sym e)).
destruct e; reflexivity.
destruct e; reflexivity.
Defined.

  Hypothesis univ : set_univ.
  Hypothesis univ_comp : set_univ_comp univ.

  Definition univ' {A B} (As:isSet A) (e:eqv A B) :=
    eq_sym (uni univ As (univ_inv eq_refl)) * uni univ As e.

Lemma univ_inv_eq A B As (e:A=B) :
  univ' As (univ_inv e) = e.
destruct e.
unfold univ'.
apply eq_sym_invl.
Qed.

Lemma univ_inv_comp_f A B C (e1:A=B)(e2:B=C):
  ef (univ_inv (e1 * e2)) =
  (fun a => ef (univ_inv e2) (ef (univ_inv e1) a)).
unfold univ_inv; simpl.
destruct e2; simpl; trivial.
Qed.
Lemma univ_inv_comp_g A B C (e1:A=B)(e2:B=C):
  eg (univ_inv (e1 * e2)) =
  (fun c => eg (univ_inv e1) (eg (univ_inv e2) c)).
unfold univ_inv; simpl.
destruct e2; simpl; trivial.
Qed.
Lemma univ_inv_inv_f A B (e:A=B):
  ef (univ_inv (eq_sym e)) =
  eg (univ_inv e).
  reflexivity.
Qed.
Lemma univ_inv_inv_g A B (e:A=B):
  eg (univ_inv (eq_sym e)) =
  ef (univ_inv e).
unfold univ_inv; simpl.
destruct e; reflexivity.
Qed.
Lemma univ_inv_inv_f' A B (e:A=B):
  ef (univ_inv (eq_sym e)) =
  fun b => transport (fun X=>X) (eq_sym e)
              (ef (univ_inv e) (transport (fun X=>X) (eq_sym e) b)).
simpl.
destruct e; reflexivity.
Qed.

(*Hypothesis fun_ext : forall {A B} {f g:A->B}, (forall x, f x=g x) -> f=g.*)

(*

Lemma transp_univ A B As Bs (e:eqv A B) a :
    transport (fun X=>X) (univ' As Bs e) a = ef _ _ e a.
unfold univ'.
transitivity (ef _ _ (univ_inv As Bs (univ' As Bs e)) a); auto.
apply f_equal with (f:=fun e => ef A B e a).

apply prop_eqv; trivial.
simpl.
intros.
unfold univapply  2:rewrite fg; trivial.
 transitivity (
 unfold univ_inv0 at 2; simpl.
reflexivity.
replace iso with (univ_inv As As eq_refl).

transitivity (id f a); auto.
generalize (id f).
 *)

Lemma prop_ext_from_univ (P Q:Prop) (Pp:isProp P) (Qp:isProp Q) :
  (P<->Q) -> P=Q :>Type.
intros (f,g).
red in univ.
apply univ with f g.
 red; intros; apply is_prop_uip; trivial.
 split; intros; auto.
Qed.

End SetUnivalence.

Section Univalence.

  Lemma eq_weqv {X Y:Type} (e:X=Y) : weqv X Y.
refine (exist _ (univ_inv e) _).
destruct e; simpl; reflexivity.
Defined.

  Definition type_univ := forall X:Type, isContr {Y:Type & weqv X Y}.

  Hypothesis univ : type_univ.

  Lemma weqv_eq {X Y} : weqv X Y -> X=Y.
intros.
specialize isContr_isProp with (1:=univ X); intros wp.
red in wp.
specialize wp with (x:=existT _ X (eq_weqv eq_refl)) (y:=existT _ Y X0).
apply f_equal with (f:=projT1 (P:=_)) in wp; trivial.
Defined.

  Lemma univ_comp {A B:Type}(e:weqv A B) :
    transport (fun X=>X) (weqv_eq e) = ef (proj1_sig e).
unfold weqv_eq.
set (aux := isContr_isProp (univ A) (existT (weqv A) A (eq_weqv eq_refl)) (existT (weqv A) B e)).
change ((fun (w:{Y:Type&weqv A Y}) (e:existT (weqv A) A (eq_weqv eq_refl) = w) =>
           transport (fun X=>X) (f_equal (projT1 (P:=_)) e) =
           ef (proj1_sig (projT2 w))) (existT (weqv A) B e) aux).
case aux; simpl.
reflexivity.
Qed.

  Lemma univ_comp_sym {A B:Type}(e:weqv A B) :
    transport (fun X=>X) (eq_sym (weqv_eq e)) = eg (proj1_sig e).
unfold weqv_eq.
set (aux := isContr_isProp (univ A) (existT (weqv A) A (eq_weqv eq_refl)) (existT (weqv A) B e)).
change ((fun (w:{Y:Type&weqv A Y}) (e:existT (weqv A) A (eq_weqv eq_refl) = w) =>
           transport (fun X=>X) (eq_sym (f_equal (projT1 (P:=_)) e)) =
           eg (proj1_sig (projT2 w))) (existT (weqv A) B e) aux).
case aux; simpl.
reflexivity.
Qed.

End Univalence.


Add LoadPath "~/fcf/src".
Add LoadPath "../".
Require Import FCF.Rat.
Require Import FCF.Fold.
Require Import FcfLems.
Require Import CpdtTactics.
Add LoadPath ".".
Require Import Dist.

Require Import List.

Definition rel {A B : Set} (P : A -> A -> Prop) (d1 d2 : A -> Dist B) (Q : B -> B -> Prop) :=
  exists (mu : (A * A) -> Dist (B * B)), forall x y, P x y ->
      (d1 x) ~~ (p <- mu (x,y); ret (fst p)) /\
      (d2 y) ~~ (p <- mu (x,y); ret (snd p)) /\
      forall p, In p (distSupport (mu (x, y))) -> Q (fst p) (snd p).

Lemma relCase {A B : Set} (P : A -> A -> Prop) (d1 d2 : A -> Dist B) (Q : B -> B -> Prop) (b : A -> A -> bool) :
  rel (fun x y => (P x y) /\ (b x y) = true) d1 d2 Q /\
  rel (fun x y => (P x y) /\ (b x y) = false) d1 d2 Q ->
  rel P d1 d2 Q.
  intros.
  unfold rel; intros.
  unfold rel in H; destruct H.
  destruct H as [C H].
  destruct H0 as [C' H'].
  exists (fun p => if (b (fst p) (snd p)) then C p else C' p).
  intros.
  remember (b x y) as b0; destruct b0; simpl; subst; symmetry in Heqb0.
  rewrite Heqb0.
  apply H; crush.
  rewrite Heqb0;
  apply H'; crush.
Qed.

  Lemma in_concat_iff {A : Set} : forall (x : A) (ls : list (list A)),
      In x (concat ls) <-> exists l, In l ls /\ In x l.
    intros.
    split.
    induction ls.
    intros.
    inversion H.
    intros.
    simpl in H.
    apply in_app_or in H.
    destruct H.
    exists a.
    crush.
    destruct (IHls H).
    exists x0.
    crush.

    intros.
    destruct H.
    induction ls.
    crush.
    simpl.
    destruct H.
    apply in_app_iff.
    crush.
  Qed.

Lemma distBind_in {A B : Set} (d : Dist A) (d' : A -> Dist B) :
  forall y, In y (distSupport (distBind d d')) -> exists x,
      In x (distSupport d) /\ In y (distSupport (d' x)).
  unfold distBind, distSupport, distJoin.
  unfold distSum.
  rewrite map_map.
  simpl.
  intros.
  apply in_map_iff in H.
  destruct H.
  destruct H.
  apply in_concat_iff in H0.
  destruct H0.
  destruct H0.
  apply in_map_iff in H0.
  destruct H0.
  exists (snd x1).
  split.
  apply in_map_iff.
  exists x1; crush.
  subst.
  crush.
  apply in_map_iff.
  unfold distScale in H1.
  apply in_map_iff in H1.
  destruct H1.
  destruct H.
  subst.
  simpl.
  exists x0; crush.
 Qed.

Lemma relBind {A B C : Set} (P : A -> A -> Prop) (d1 d2 : A -> Dist B) (d1' d2' : B -> Dist C) (Q : B -> B -> Prop) (R : C -> C -> Prop) :
  rel P d1 d2 Q ->
  rel Q d1' d2' R ->
  rel P (fun a => x <- d1 a; d1' x) (fun a => x <- d2 a; d2' x) R.
  intros.
  unfold rel in H, H0.
  unfold rel; intros.
  destruct H as [c H].
  destruct H0 as [c' H'].
  exists (fun p => x <- c p; c' x).
  intros.
  destruct (H x y H0).
  destruct H2.
  split.

  rewrite bindAssoc.
  etransitivity.
  apply distBind_cong_l.
  apply H1.
  rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret.
  destruct x0.
  simpl.
  destruct (H' b b0 (H3 (b,b0) H4)).
  apply H5.

  split.
  rewrite bindAssoc.
  etransitivity.
  apply distBind_cong_l.
  apply H2.
  rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret.
  destruct x0.
  simpl.
  destruct (H' b b0 (H3 (b,b0) H4)).
  destruct H6.
  apply H6.

  intros.
  apply distBind_in in H4.
  destruct H4.
  destruct H4.
  destruct (H' (fst x0) (snd x0) (H3 x0 H4)).
  destruct H7.
  apply H8.
  rewrite <- surjective_pairing.
  crush.
Qed.

Lemma relSound {A B : Set} (d1 d2 : A -> Dist B) :
  rel (fun _ _ => True) d1 d2 eq ->
  forall x, (d1 x) ~~ (d2 x).
  unfold rel.
  intro H; destruct H.
  intros.
  destruct (H x0 x0).
  crush.
  rewrite H0.
  destruct H1.
  rewrite H1.
  apply distBind_cong_r.
  intros.
  unfold distEquiv; crush.
Qed.

Definition unif {A : Set} (xs : list A) `{StdNat.nz (length xs)} : Dist A :=
  map (fun x => (1 / (length xs), x)) xs.

Lemma wf_unif {A : Set} : forall (xs : list A) `{StdNat.nz (length xs)}, wf_Dist (unif xs).
    intros.
    unfold wf_Dist.
    split.
    unfold unif.
    unfold distMass.
    rewrite sumList_map.
    rewrite sumList_map.
    simpl.
    rewrite sumList_body_const.
    apply ratMult_eq_rat1.
    intros.
    unfold unif in H0.
    apply in_map_iff in H0; repeat destruct H0.
    apply in_map_iff in H1; repeat destruct H1.
    crush.
Qed.

Definition unifNats (n : nat) `{StdNat.nz n} : Dist (nat).
  eapply (@unif _ (allNatsLt n)).
  rewrite allNatsLt_length.
  auto.
Defined.

Lemma relConseq {A B : Set} (P P' : A -> A -> Prop) (d1 d2 : A -> Dist B) (Q Q' : B -> B -> Prop) :
  rel P d1 d2 Q ->
  (forall x y, P' x y -> P x y) ->
  (forall x y, Q x y -> Q' x y) ->
  rel P' d1 d2 Q'.
  intros.
  unfold rel in *.
  destruct H.
  exists x; intros.
  destruct (H x0 y (H0 _ _ H2)) as [G1 [G2 G3]].
  split.
  apply G1.
  split.
  apply G2.
  intros; apply H1; apply G3.
  crush.
Qed.

Lemma relFalse {A B : Set} (d1 d2 : A -> Dist B) (Q : B -> B -> Prop) :
  rel (fun _ _ => False) d1 d2 Q.
  unfold rel.
  exists (fun _ => nil).
  intros; crush.
Qed.


From iVM Require Export Init.

Unset Suggest Proof Using.

Declare Scope lens_scope.
Delimit Scope lens_scope with lens.

Ltac mixer_rewrite0 := rewrite_strat (repeat (outermost (hints mixer))).
Tactic Notation "mixer_rewrite0" "in" hyp(H) :=
  rewrite_strat (repeat (outermost (hints mixer))) in H.

(** * Mixers

[Mixer] represents lenses with the target type abstracted away.
I don't know if this has an established name. *)

Class Mixer A :=
{
  mixer: A -> A -> A;
  mixer_id x : mixer x x = x;
  mixer_left x y z : mixer (mixer x y) z = mixer x z;
  mixer_right x y z : mixer x (mixer y z) = mixer x z;
}.
#[export]
Hint Mode Mixer ! : typeclass_instances.

Bind Scope lens_scope with Mixer.

Hint Rewrite @mixer_id : mixer.
Hint Rewrite @mixer_left : mixer.
Hint Rewrite @mixer_right : mixer.

Coercion mixer : Mixer >-> Funclass.

Proposition mixer_assoc {A} {f: Mixer A} {x y z} : f (f x y) z = f x (f y z).
Proof.
  intros. mixer_rewrite0. reflexivity.
Qed.

Program Instance fstMixer {A} : Mixer A :=
{
  mixer x _ := x;
}.

Program Instance sndMixer {A} : Mixer A :=
{
  mixer _ y := y;
}.

(** ** Equality *)

(** Equivalent to "f = g" if we assume extensionality and proof irrelevance. *)
Definition mixerEq {A} (f g: Mixer A) : Prop := forall x y, f x y = g x y.

(* "\simeq" : Same level and associativity as "=". *)
Notation "f ≃ g" := (mixerEq f g) (at level 70, no associativity) : type_scope.

Section equality_section.

  Context {A : Type}.

  (** Useful to have as separate fact. *)
  Proposition mixer_refl {f: Mixer A} : f ≃ f.
  Proof.
    intros a x. reflexivity.
  Qed.

  #[global] Instance mixerEq_equivalence : Equivalence (@mixerEq A).
  Proof.
    split.
    - intro f. exact mixer_refl.
    - intros f g Hfg x y. rewrite Hfg. reflexivity.
    - intros f g h Hfg Hgh x y.
      transitivity (g x y).
      + apply Hfg.
      + apply Hgh.
  Qed.

  (* TODO: Is this safe? *)
  #[global] Instance mixer_proper :
    Proper (@mixerEq A ==> eq ==> eq ==> eq) (@mixer A).
  Proof.
    repeat intro.
    repeat subst.
    intuition.
  Qed.

End equality_section.

(** ** Submixers *)

Set Typeclasses Unique Instances.

Class Submixer {A} (f g: Mixer A) : Prop :=
  submixer x y z : f (g x y) z = g x (f y z).

Unset Typeclasses Unique Instances.

#[export]
Hint Mode Submixer ! ! - : typeclass_instances.

(** Adding [@submixer] as a rewrite hint may cause loops. *)

(* Cf. the notation for Z.divide. *)
Notation "( f | g )" := (Submixer f g) : type_scope.

Section submixer_section.

  Context {A: Type}.

  (** Making this a global instance is somewhat problematic since
      [Submixer] is itself a class. *)
  #[global] Instance submixer_proper :
    Proper (@mixerEq A ==> @mixerEq A ==> iff) (@Submixer A).
  Proof.
    intros f f' Hf g g' Hg.
    split; intros H x y z.
    - repeat rewrite <- Hf.
      repeat rewrite <- Hg.
      rewrite submixer.
      reflexivity.
    - repeat rewrite Hf.
      repeat rewrite Hg.
      rewrite submixer.
      reflexivity.
  Qed.

  #[global] Instance submixer_refl {f: Mixer A} : (f | f).
  Proof. repeat intro. apply mixer_assoc. Qed.

  #[global] Instance submixer_reflexive : Reflexive (@Submixer A).
  Proof.
    intro. apply submixer_refl.
  Qed.

  (** Not global by the same argument as for [submixer_proper]. *)
  Instance eq_submixer_subrelation : subrelation (@mixerEq A) (@Submixer A).
  Proof.
    intros f g H. rewrite H. reflexivity.
  Qed.

  (** *** Rewriting *)

  Proposition submixer_left {f g: Mixer A} {Hs: (f|g)} x y z :
    g (f x y) z = g x z.
  Proof.
    transitivity (g (g x (f x y)) z).
    - rewrite <- submixer, mixer_id. reflexivity.
    - rewrite mixer_left. reflexivity.
  Qed.

  Proposition submixer_right {f g: Mixer A} {Hs: (f|g)} x y z :
    f x (g y z) = f x z.
  Proof.
    transitivity (f x (f (g y z) z)).
    - rewrite submixer, mixer_id. reflexivity.
    - rewrite mixer_right. reflexivity.
  Qed.

  Proposition submixer_right' {f g: Mixer A} {Hs: (f|g)} x y :
    g x (f x y) = f x y.
  Proof.
    now rewrite <- Hs, mixer_id.
  Qed.

End submixer_section.

(** ** Independence *)

Section independence_section.

  Context {A: Type}.

  Class Independent (f g: Mixer A) :=
    independent x y z : f (g x z) y = g (f x y) z.

  #[global] Instance independent_symmetric : Symmetric Independent.
  Proof.
    intros f g H x y z; symmetry; apply H.
  Qed.

  (** This can be used with [setoid_rewrite]. *)
  Corollary independent_symm (f g: Mixer A) : Independent f g <-> Independent g f.
  Proof.
    split; apply independent_symmetric.
  Qed.

  Proposition independent_left (f g: Mixer A) {Hi: Independent f g} x y :
    g (f x y) x = f x y.
  Proof.
    rewrite <- Hi. mixer_rewrite0. reflexivity.
  Qed.

  (** Indicate canonical "direction" *)

  Class Independent0 (f g: Mixer A) :=
    independent0 :> Independent f g.

  (** The following is used to add symmetry hints while avoiding loops. *)

  Context (f g: Mixer A).

  Class Independent' :=
    independent' : Independent0 f g.

  #[global] Instance independent_forward (Hi: Independent f g): Independent' := Hi.

  #[global] Instance independent_backward (Hi: Independent g f): Independent' :=
    independent_symmetric _ _ Hi.

  Corollary independent_forward' : Independent f g <-> Independent'.
  Proof.
    split; intros H.
    - now apply independent_forward.
    - apply H.
  Qed.

  Corollary independent_backward' : Independent g f <-> Independent'.
  Proof.
    setoid_rewrite independent_symm at 1.
    exact independent_forward'.
  Qed.

  Context {Hi: Independent'}.

  Proposition independent_right x y z : g x (f y z) = g x y.
  Proof.
    transitivity (g x (f (g y y) z)); [ now mixer_rewrite0 | ].
    set (H := independent').
    rewrite independent.
    now mixer_rewrite0.
  Qed.

End independence_section.

Instance independent_symmetric' {A} : Symmetric (@Independent' A).
Proof.
  intros f g H.
  apply independent_backward, independent'.
  exact H.
Qed.

#[export] Hint Mode Independent0 ! ! - : typeclass_instances.
#[export] Hint Mode Independent0 ! - ! : typeclass_instances.
#[export] Hint Mode Independent  ! ! - : typeclass_instances.
#[export] Hint Mode Independent' ! ! - : typeclass_instances.
#[export] Hint Mode Independent' ! - ! : typeclass_instances.

Arguments independent_symmetric {_ _ _} _.
Arguments independent_symm {_ _ _}.
Arguments independent' {_ _ _} _.
Arguments independent_right {_ _ _ _}.
Arguments independent_symmetric' {_ _ _} _.
Arguments independent_forward' {_ _ _}.
Arguments independent_backward' {_ _ _}.

Corollary independent_right2
          {A} {f g h: Mixer A} {Hi: Independent' f g} {Hi': Independent' f h}
          x y z u:
  g x (h (f y z) u) = g x (h y u).
Proof.
  rewrite <- Hi', independent_right. reflexivity.
Qed.

(** ** Rewrite/reduction tactic *)

Ltac mixer_rewrite1 :=
  let H := fresh "Hmr" in
  match goal with

  | [ |- context [ @mixer _ ?f _ (@mixer _ ?g _ _)] ] =>
    first
      [ assert (f | g) as H;
        (* f x (g y z)  ~>  f x z *)
        [ typeclasses eauto
        | setoid_rewrite (@submixer_right _ f g H) ]

      | assert (g | f) as H;
        (* f x (g x y)  ~>  g x y *)
        [ typeclasses eauto
        | setoid_rewrite (@submixer_right' _ g f H) ]

      | assert (Independent' g f) as H;
        (* f x (g y z)  ~>  f x y *)
        [ typeclasses eauto
        | setoid_rewrite (@independent_right _ g f H) ] ]

  | [ |- context [ @mixer _ ?f (@mixer _ ?g _ _) _] ] =>
    first
      [ assert (g | f) as H;
        (* f (g x y) z  ~>  f x z *)
        [ typeclasses eauto
        | setoid_rewrite (@submixer_left _ g f H) ]

      | assert (f | g) as H;
        (* f (g x y) z  ~>  g x (f y z) *)
        [ typeclasses eauto
        | setoid_rewrite (H _ _ _) ]

      | assert (Independent0 f g) as H;
        (* f (g x z) y  ~>  g (f x y) z *)
        [ typeclasses eauto
        | setoid_rewrite (H _ _ _) ]

      | assert (Independent0 g f) as H;
        (* g (f x y) x  ~>  f x y *)
        [ typeclasses eauto
        | setoid_rewrite (@independent_left _ g f H) ] ]

  | [ |- context [ @mixer _ ?f _ (@mixer _ ?g (@mixer _ ?h _ _) _)] ] =>
    assert (Independent' h f) as H; [ typeclasses eauto | ];
    let H' := fresh "Hmr" in
    assert (Independent' h g) as H'; [ typeclasses eauto | ];
    (* f x (g (h y z) u)  ~>  f x (g y u) *)
    setoid_rewrite (@independent_right2 _ h f g H H')

  | [ |- context [ @mixer _ ?f _ _ ] ] =>
    (* f x x  ~>  x *)
    setoid_rewrite mixer_id
  end.

Ltac mixer_rewrite := repeat mixer_rewrite1; try reflexivity.
Ltac mixer_rewrite' := repeat intro; cbn; mixer_rewrite.

Instance fstMixer_independent {A} (f: Mixer A) : Independent fstMixer f.
Proof.
  mixer_rewrite'.
Qed.

(** ** More submixer properties *)

Lemma submixer_antisymm {A} {f g: Mixer A} (Hs: (f|g)) (Hs': (g|f)) : f ≃ g.
Proof.
  intros a a'.
  transitivity (g (f a a') (f a a')).
  - now mixer_rewrite0.
  - mixer_rewrite.
Qed.

Lemma submixer_trans {A} {f g h : Mixer A} : (f | g) -> (g | h) -> (f | h).
Proof.
  intros Hfg Hgh x y z.
  transitivity (f (g (h x y) (h x y)) z).
  - now mixer_rewrite0.
  - mixer_rewrite.
Qed.

Instance submixer_transitive {A} : Transitive (@Submixer A).
Proof.
  intros f g h. apply submixer_trans.
Qed.

Proposition submixer_fst {A} (f: Mixer A) : (fstMixer | f).
Proof. mixer_rewrite'. Qed.

Instance submixer_snd {A} (f: Mixer A) : (f | sndMixer).
Proof. mixer_rewrite'. Qed.

(** *** Propriety *)

Section propriety_section.

  Context {A: Type}.

  Instance independent_proper_sub0 {f: Mixer A} :
    Proper (@Submixer A ==> flip impl) (Independent f).
  Proof.
    intros g g' Hg
           H x y z.
    rewrite <- (mixer_id (Mixer:=g') x) at 2.
    rewrite H.
    rewrite Hg.
    rewrite <- H.
    mixer_rewrite.
  Qed.

  #[global] Instance independent_proper_sub :
    Proper (@Submixer A ==> @Submixer A ==> flip impl) (@Independent A).
  Proof.
    (* The rewrites use [independent_proper_sub0]. *)
    intros f f' Hf
           g g' Hg.
    rewrite Hg. setoid_rewrite independent_symm.
    rewrite Hf. reflexivity.
  Qed.

  (* Corollary *)
  #[global] Instance independent_proper_sub' :
    Proper (@Submixer A ==> @Submixer A ==> flip impl) (@Independent' A).
  Proof.
    intros f f' Hf
           g g' Hg.
    setoid_rewrite <- independent_forward'.
    now apply independent_proper_sub.
  Qed.

  #[global] Instance independent_proper :
    Proper (@mixerEq A ==> @mixerEq A ==> iff) (@Independent A).
  Proof.
    (* The direct proof is not much longer. *)
    set (Hsub := @eq_submixer_subrelation).
    intros f f' Hf
           g g' Hg.
    split; intro H.
    - rewrite <- Hf, <- Hg. exact H.
    - rewrite Hf, Hg. exact H.
  Qed.

  (* Corollary *)
  #[global] Instance independent_proper' :
    Proper (@mixerEq A ==> @mixerEq A ==> iff) (@Independent' A).
  Proof.
    intros f f' Hf
           g g' Hg.
    setoid_rewrite <- independent_forward'.
    now apply independent_proper.
  Qed.

End propriety_section.

(** ** Products *)

Section prod_section.

  Context {A} (f g: Mixer A) {Hi: Independent' f g}.

  Instance ind_prod : Independent0 f g := independent' Hi.

  #[refine] #[global] Instance prodMixer : Mixer A :=
  {
    mixer x y := g (f x y) y;
  }.
  Proof.
    all: abstract mixer_rewrite'.
  Defined.

  Instance submixer_prod1 : (f | prodMixer).
  Proof. mixer_rewrite'. Qed.

  Instance submixer_prod2 : (g | prodMixer).
  Proof. mixer_rewrite'. Qed.

  #[global] Instance submixer_prod_right
         (h: Mixer A)
         {Hf: (f | h)}
         {Hg: (g | h)} : (prodMixer | h).
  Proof. mixer_rewrite'. Qed.

  (** Thus, [prodMixer] is a least upper bound w.r.t. [Submixer]. *)

  #[global] Instance submixer_prod_left1
         (h: Mixer A) {Hf: (h | f)} : (h | prodMixer).
  Proof.
    transitivity f.
    - exact Hf.
    - exact submixer_prod1.
  Qed.

  #[global] Instance submixer_prod_left2
         (h: Mixer A) {Hg: (h | g)} : (h | prodMixer).
  Proof.
    transitivity g.
    - exact Hg.
    - exact submixer_prod2.
  Qed.

  #[global] Instance independent_prod
           (h: Mixer A)
           {Hf: Independent' f h}
           {Hg: Independent' g h} : Independent prodMixer h.
  Proof.
    intros x y z. cbn.
    apply independent' in Hf, Hg.
    mixer_rewrite.
  Qed.

End prod_section.

(* "\times" : The same level and associativity as "*". *)
Infix "×" := prodMixer (at level 40, left associativity) : lens_scope.

(** I am not sure how to make this an actual instance of [Proper]. *)
Proposition prodMixer_proper {A}
            {f f': Mixer A} (Hf: f ≃ f')
            {g g': Mixer A} (Hg: g ≃ g')
            {Hi: Independent' f g}
            (* [Hi'] follows from [Hi] *)
            {Hi': Independent' f' g'} :
  f × g ≃ f' × g'.
Proof.
  intros x y. cbn. rewrite Hf, Hg. reflexivity.
Qed.


Require Import
  MathClasses.interfaces.canonical_names.

(*
  The following class is nice to parametrize instances by additional properties, for example:
  [∀ z, PropHolds (z ≠ 0) → LeftCancellation op z]
  This tool is very powerful as we can combine it with instances as:
  [∀ x y, PropHolds (x ≠ 0) → PropHolds (y ≠ 0) → PropHolds (x * y ≠ 0)]
  Of course, one should be very careful not to make too many instances as that could
  easily lead to a blow-up of the search space (or worse, cycles).
*)
Class PropHolds (P : Prop) := prop_holds: P.

Hint Extern 0 (PropHolds _) => assumption : typeclass_instances.

Instance: Proper (iff ==> iff) PropHolds.
Proof. now repeat intro. Qed.

Ltac solve_propholds :=
  match goal with
  | [ |- PropHolds (?P) ] => apply _
  | [ |- ?P ] => change (PropHolds P); apply _
  end.


Lemma Coq_01: forall A B C:Prop, (A->B->C) -> (A->B) -> A -> C.
intros.
apply H.
apply H1.
apply H0.
apply H1.
Qed.


(* Copyright 2021 Joshua M. Cohen

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

(*Definitions and Lemmas about lists indexed by Z, rather than n*)
Require Import VST.floyd.functional_base.
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".
Require Import CommonSSR.

(*Version of [iota] for nonnegative integers*)

Section Ziota.

Definition Ziota (x len : Z) :=
  map (fun y => Z.of_nat y) (iota (Z.to_nat x) (Z.to_nat len)).

Lemma Zlength_iota: forall a b,
  Zlength (iota a b) = Z.of_nat b.
Proof.
  move => a b. by rewrite Zlength_correct -size_length size_iota.
Qed.

Lemma Zlength_Ziota: forall x len,
  (0<=x) ->
  (0<= len) ->
  Zlength (Ziota x len) = len.
Proof.
  move => x len Hx Hlen. rewrite /Ziota Zlength_map Zlength_iota. by lia.
Qed.

Lemma Znth_Ziota: forall x len i,
  0 <= x ->
  0 <= len ->
  0 <= i < len ->
  Znth i (Ziota x len) = x + i.
Proof.
  move => x len i Hx Hlen Hi.  rewrite /Ziota Znth_map. rewrite -nth_Znth. rewrite -nth_nth nth_iota.
  - have->: (Z.to_nat x + Z.to_nat i)%N = (Z.to_nat x + Z.to_nat i)%coq_nat by []. lia.
  - apply /ltP. lia.
  - rewrite Zlength_iota; lia.
  - rewrite Zlength_iota; lia.
Qed.

Lemma Ziota_In: forall x len z,
  (0 <= x) ->
  (0 <= len) ->
  In z (Ziota x len) <-> (x <= z < x + len).
Proof.
  move => x len z Hx Hlen. rewrite /Ziota in_map_iff. split => [[i [Hiz Hin]] | Hb].
  move : Hin; rewrite -in_mem_In mem_iota. move => /andP[Hxi Hixlen].
  have {} Hxi: (Z.to_nat x <= i)%coq_nat by apply (elimT leP).
  have {} Hixlen: (i < Z.to_nat x + Z.to_nat len)%coq_nat by apply (elimT ltP). subst.
  split. lia. rewrite Z2Nat.inj_lt; try lia. by rewrite Nat2Z.id Z2Nat.inj_add; try lia.
  exists (Z.to_nat z). split. rewrite Z2Nat.id; lia. rewrite -in_mem_In mem_iota.
  apply (introT andP). split. by apply (introT leP); lia. apply (introT ltP).
  move : Hb => [Hxz Hzxlen]. move: Hzxlen. rewrite Z2Nat.inj_lt; try lia. by rewrite Z2Nat.inj_add; try lia.
Qed.

Lemma Ziota_NoDup: forall x len,
  NoDup (Ziota x len).
Proof.
  move => x len. rewrite /Ziota. apply FinFun.Injective_map_NoDup.
  - rewrite /FinFun.Injective => x' y' Hxy. lia.
  - rewrite -uniq_NoDup. apply iota_uniq.
Qed.

Lemma Ziota_plus_1: forall (x len : Z),
  0 <= x ->
  0 <= len ->
  Ziota x (len + 1) = Ziota x len ++ [:: (x +len)%Z].
Proof.
  move => x len Hx Hlen. rewrite /Ziota.
  have ->: (Z.to_nat (len + 1) = Z.to_nat len + 1%nat)%nat by rewrite Z2Nat.inj_add; try lia.
  rewrite iotaD map_cat /=.
  f_equal. f_equal.
  have ->: ((Z.to_nat x + Z.to_nat len)%nat = Z.to_nat (x + len)%Z) by rewrite Z2Nat.inj_add; try lia.
  lia.
Qed.

End Ziota.

(*Z version of [mkseq]*)
Section MkSeqZ.

Definition mkseqZ {A: Type} (f: Z -> A) (bound: Z) :=
  mkseq (fun x => f (Z.of_nat x)) (Z.to_nat bound).

Lemma mkseqZ_Zlength: forall {A} (f: Z -> A) b,
  0 <= b ->
  Zlength (mkseqZ f b) = b.
Proof.
  move => A f b Hb. rewrite /mkseqZ Zlength_correct -size_length size_mkseq. lia.
Qed.

Lemma mkseqZ_Znth: forall {A} `{Inhabitant A} (f: Z -> A) b i,
  0 <= i < b ->
  Znth i (mkseqZ f b) = f i.
Proof.
  move => A Hinhab f b i Hi. rewrite -nth_Znth.
  - rewrite -nth_nth nth_mkseq. f_equal. lia. apply /ltP. lia.
  - rewrite mkseqZ_Zlength; lia.
Qed.

Lemma mkseqZ_plus_1: forall {A} (f: Z -> A) z,
  0 <= z ->
  mkseqZ f (z + 1) = mkseqZ f z ++ [:: f z].
Proof.
  move => A f z Hz. rewrite /mkseqZ /mkseq. have->: (z + 1) = Z.succ z by lia.
  by rewrite Z2Nat.inj_succ // iota_plus_1 map_cat /= add0n Z2Nat.id.
Qed.

End MkSeqZ.

(* Similar to above, but with lists indexed by bytes*)
Section MkSeqByte.

Definition mkseqByte {A: Type} (f: byte -> A) (bound: Z) :=
  mkseqZ (fun z => f (Byte.repr z)) bound.

Lemma mkseqByte_Zlength: forall {A} (f: byte -> A) b,
  0 <= b ->
  Zlength (mkseqByte f b) = b.
Proof.
  move => A f b Hb. by apply mkseqZ_Zlength.
Qed.

Lemma mkseqByte_Znth_Z: forall {A} `{Inhabitant A} (f: byte -> A) b i,
  0 <= i < b ->
  Znth i (mkseqByte f b) = f (Byte.repr i).
Proof.
  move => A Hinhab f b i Hi. by rewrite mkseqZ_Znth.
Qed.

Lemma mkseqByte_Znth_byte: forall {A} `{Inhabitant A} (f: byte -> A) b (i: byte),
  0 <= Byte.unsigned i < b ->
  Znth (Byte.unsigned i) (mkseqByte f b) = f i.
Proof.
  move => A Hinhab f b i Hi. by rewrite mkseqZ_Znth //Byte.repr_unsigned.
Qed.

End MkSeqByte.

(*Z version of nseq*)
Section ZSeq.

Definition zseq {A: Type} (z: Z) (x: A) :=
  nseq (Z.to_nat z) x.

Lemma zseq_Zlength: forall {A: Type} z (x: A),
  0 <= z ->
  Zlength (zseq z x) = z.
Proof.
  move => A z x Hz. rewrite /mkseqZ Zlength_correct -size_length size_nseq. lia.
Qed.

Lemma zseq_Znth: forall {A: Type} `{Inhabitant A} z (x: A) i,
  0 <= z ->
  0 <= i < z ->
  Znth i (zseq z x) = x.
Proof.
  move => A Hinhab z x i Hz Hi. rewrite -nth_Znth. rewrite -nth_nth nth_nseq.
  case Hiz: (Z.to_nat i < Z.to_nat z)%N => [//|]. apply (elimF ltP) in Hiz. lia. by rewrite zseq_Zlength.
Qed.

Lemma zseq_map: forall {A B : Type} z (x: A) (f: A -> B),
  map f (zseq z x) = zseq z (f x).
Proof.
  move => A B z x f. by rewrite map_nseq.
Qed.

Lemma zseq_hd: forall {A: Type} (z: Z) (x: A),
  1 <= z ->
  zseq z x = x :: zseq (z - 1) x.
Proof.
  move => A z x Hz. rewrite /zseq. have->:(Z.to_nat z) = (1 + (Z.to_nat (z - 1)))%N.
    have->:(1 + (Z.to_nat (z - 1)))%N = (1 + (Z.to_nat (z - 1)))%coq_nat by []. lia.
  by rewrite nseqD.
Qed.

(*TODO: when this was written, Zrepeat did not exist. We don't really need zseq now, should be
  replaced.*)
Lemma zseq_Zrepeat: forall {A: Type} (x: A) (z: Z),
  0 <= z ->
  Zrepeat x z = zseq z x.
Proof.
  move => A x z Hz. have Hinhab: Inhabitant A by apply x. apply Znth_eq_ext.
  - by rewrite Zlength_Zrepeat // zseq_Zlength.
  - move => i. rewrite Zlength_Zrepeat // => Hi.
    by rewrite Znth_Zrepeat // zseq_Znth.
Qed.

Lemma zseq_app: forall {A: Type} (z1 z2: Z) (x: A),
  0 <= z1 ->
  0 <= z2 ->
  zseq (z1 + z2) x = zseq z1 x ++ zseq z2 x.
Proof.
  move => A z1 z2 x Hz1 Hz2. rewrite /zseq -nseqD. f_equal.
  rewrite Z2Nat.inj_add //; lia.
Qed.

(*also move this*)
Lemma flatten_nseq: forall {A: Type} n1 n2 (x: A),
  flatten (nseq n1 (nseq n2 x)) = nseq (n1 * n2) x.
Proof.
  move => A n1 n2 x. elim : n1 => [// | n1 /= IH].
  by rewrite IH -nseqD.
Qed.

Lemma zseq_concat: forall {A: Type} z1 z2 (x: A),
  0 <= z1 ->
  0 <= z2 ->
  concat (zseq z1 (zseq z2 x)) = zseq (z1 * z2) x.
Proof.
  move => A z1 z2 x Hz1 Hz2. rewrite concat_flatten /zseq flatten_nseq. f_equal.
  by rewrite Z2Nat.inj_mul.
Qed.

Lemma Ziota_leq: forall i j,
  0 <= i <= j ->
  Ziota 0 j = Ziota 0 i ++ Ziota i (j - i).
Proof.
  move => i j Hij. rewrite /Ziota -map_cat. f_equal.
  have->: (Z.to_nat j) = ((Z.to_nat i) + (Z.to_nat (j-i)))%coq_nat by lia.
  have->:(Z.to_nat i + Z.to_nat (j - i))%coq_nat = (Z.to_nat i + Z.to_nat (j - i))%N by [].
  by rewrite iotaD.
Qed.

End ZSeq.

Section Zindex.

Lemma Z_eq_axiom: Equality.axiom (Z.eqb).
Proof.
  move => x y.
  apply Z.eqb_spec.
Qed.

Definition Z_eq_mixin := EqMixin Z_eq_axiom.
Definition Z_eqtype := EqType Z Z_eq_mixin. (*dont want canonical*)

(*Unfortunately, using Z_eqtype screws up lia, but we need this for "index" definition*)
Definition Zindex (x: Z_eqtype) (l: seq Z) := Z.of_nat (index x l).

Lemma Zindex_Znth: forall (i: Z) (l: list Z),
  NoDup l ->
  0 <= i < Zlength l ->
  Zindex (Znth i l) l = i.
Proof.
  move => i l Hi Hnodup. rewrite /Zindex - nth_Znth // -nth_nth index_uniq; try lia.
  rewrite size_length -ZtoNat_Zlength. apply /ltP. (*Why doesn't lia work?*)
  apply Z2Nat.inj_lt. apply (proj1 Hnodup). eapply Z.le_trans. apply (proj1 Hnodup).
  apply Z.lt_le_incl. apply (proj2 Hnodup). apply (proj2 Hnodup).
  by apply uniq_NoDup.
Qed.

Lemma Zindex_In: forall (x: Z) (l: list Z),
  (Zindex x l) < Zlength l <-> In x l.
Proof.
  move => x l.
  by rewrite /Zindex Zlength_correct -size_length -Nat2Z.inj_lt (rwP ltP) index_mem in_mem_In.
Qed.

Lemma Zindex_notin: forall (x: Z) (l: list Z),
  (Zindex x l) = Zlength l <-> ~(In x l).
Proof.
  move => x l.
  by rewrite /Zindex Zlength_correct -size_length Nat2Z.inj_iff (rwP eqP) index_notin -(@in_mem_In Z_eqtype) (rwP negP).
Qed.

Lemma Znth_Zindex: forall (x: Z) (l: list Z),
  In x l ->
  Znth (Zindex x l) l = x.
Proof.
  move => x l Hin. rewrite /Zindex -nth_Znth; last first.
  split; try lia. by apply Zindex_In. rewrite Nat2Z.id -nth_nth. apply (@nth_index Z_eqtype).
  by apply in_mem_In.
Qed.

End Zindex.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                          Dependent_lists_Compl.v                         *)
(****************************************************************************)

Require Export Dependent_lists.
Require Import Compare_dec.
Require Import Arith_Compl.

Set Implicit Arguments.
Unset Strict Implicit.

Section d_Lists_Compl.

  Variable A B C : Set.
  Let d_List := d_list A.

 (** Concatenation **)

  Fixpoint wcat (n m : nat) (l1 : d_List n) (l2 : d_List m) {struct l1} :
   d_List (n + m) :=
    match l1 in (d_list _ n) return (d_List (n + m)) with
    | d_nil => l2
    | d_cons _ a l1' => d_cons a (wcat l1' l2)
    end.

 (** Puts an element at the end of a list **)

  Fixpoint put_end (a : A) (n : nat) (l : d_List n) {struct l} :
   d_List (S n) :=
    match l in (d_list _ n) return (d_List (S n)) with
    | d_nil => d_cons a (d_nil A)
    | d_cons _ a' l' => d_cons a' (put_end a l')
    end.

 (** Converts a term of type (d_List n) to the same term of type (d_List m) given **)
 (** a proof that n=m **)

  Definition subst : forall n m : nat, n = m -> d_List n -> d_List m.
  simple destruct 1; trivial.
  Defined.

 (** Reverses a list **)

  Fixpoint Rev (n : nat) (l : d_List n) {struct l} :
   d_List n :=
    match l in (d_list _ n) return (d_List n) with
    | d_nil => d_nil A
    | d_cons _ a l' => put_end a (Rev l')
    end.

 (** Constructs a length-i list taking the i first elements of a length-n **)
 (** list, under the hypothesis that i<=n                                 **)

  Fixpoint construct_with_i_first (n i : nat) (l : d_List n) {struct i} :
   i <= n -> d_List i :=
    match i as x return (x <= n -> d_List x) with
    | O => fun _ : 0 <= n => d_nil A
    | S p =>
        fun h : S p <= n =>
        d_cons (d_head l (le_S_lt_O h))
          (construct_with_i_first (d_tl l) (le_Sn_le_n_pred h))
    end.

 (** Constructs a length-i list taking the i last elements of a length-n list **)

  Definition construct_with_i_last (n i : nat) (l : d_List n)
    (H : i <= n) : d_List i := Rev (construct_with_i_first (Rev l) H).

 (** Removes the ith first element(s) of a list **)

  Fixpoint strip_off_first (i n : nat) (l : d_List n) {struct l} :
   d_List (n - i) :=
    match l in (d_list _ n) return (d_List (n - i)) with
    | d_nil => d_nil A
    | d_cons p a t =>
        match i return (d_List (S p - i)) with
        | O => d_cons a t
        | S q => strip_off_first q t
        end
    end.

 (** Removes the ith last element(s) of a list **)

  Definition strip_off_last (i n : nat) (l : d_List n) :=
    Rev (strip_off_first i (Rev l)).

 (** Another way of returning the i first elements of a list **)

  Definition first_of_list (i n : nat) (l : d_List n) :=
    strip_off_last (n - i) l.

 (** Another way of returning the i last elements of a list **)

  Definition last_of_list (i n : nat) (l : d_List n) :=
    strip_off_first (n - i) l.

 (** Removes the ith element of a list **)

  Definition remove_i (i n : nat) (l : d_List n) :=
    wcat (first_of_list (pred i) l) (last_of_list (n - i) l).

 (** Another way of removing the ith element of a list **)

  Fixpoint Remove_i (i : nat) :
   0 < i -> forall n : nat, i <= n -> d_List (S n) -> d_List n :=
    match
      i return (0 < i -> forall n : nat, i <= n -> d_List (S n) -> d_List n)
    with
    | O =>
        fun (h : 0 < 0) (n : nat) (_ : 0 <= n) (l : d_List (S n)) =>
        False_rec (d_List n) (lt_irrefl 0 h)
    | S p =>
        fun (_ : 0 < S p) (n : nat) =>
        match zerop p return (S p <= n -> d_List (S n) -> d_List n) with
        | left _ => fun (_ : S p <= n) (l : d_List (S n)) => d_tl l
        | right h =>
            match n return (S p <= n -> d_List (S n) -> d_List n) with
            | O =>
                fun (h' : S p <= 0) (l : d_List 1) =>
                False_rec (d_List 0) (le_Sn_O p h')
            | S q =>
                fun (h' : S p <= S q) (l : d_List (S (S q))) =>
                d_cons (d_Head l) (Remove_i h (le_S_n p q h') (d_tl l))
            end
        end
    end.

 (** Returns the ith element of a length-n list **)

 Fixpoint Nth (i n : nat) (l : d_List n) {struct i} :
  0 < i -> i <= n -> A :=
   match i as y return (0 < y -> y <= n -> A) with
   | O => fun (h : 0 < 0) (h' : 0 <= n) => False_rec A (lt_irrefl 0 h)
   | S p =>
       fun (_ : 0 < S p) (h' : S p <= n) =>
       match zerop p with
       | left _ => d_head l (le_S_lt_O h')
       | right h'' => Nth (d_tl l) h'' (le_Sn_le_n_pred h')
       end
   end.

 (** The same as Nth with parameter order modified **)

  Definition nth (i n : nat) (H : 0 < i) (H' : i <= n)
    (l : d_List n) := Nth (i:=i) l H H'.

 (** Another way, using the Program tactic, of describing the nth function **)

  Inductive nth_spec : forall i n : nat, d_List n -> A -> Prop :=
    | nth_O :
        forall (a : A) (n : nat) (l : d_List n), nth_spec 1 (d_cons a l) a
    | nth_S :
        forall (i n : nat) (a b : A) (l : d_List n),
        nth_spec i l a -> nth_spec (S i) (d_cons b l) a.

  Fixpoint Nth_func (i n : nat) (l : d_List n) {struct l} :
   Exc A :=
    match l with
    | d_nil => error (A:=A)
    | d_cons p a l' =>
        match i with
        | O => error (A:=A)
        | S q => match q with
                 | O => value a
                 | S q' => Nth_func (S q') l'
                 end
        end
    end.

 (** Returns the length-((minus m n)+1) list elements of which are between **)
 (** the n and m positions of a length-k list                              **)

  Definition Seg' (n m k : nat) (l : d_List k) (H1 : 0 < n)
    (H2 : m <= k) (H3 : n <= m) :=
    first_of_list (S (m - n)) (last_of_list (S (k - n)) l).

 (** The same as Seg' with parameters order modified **)

  Definition seg' (n m k : nat) (H1 : 0 < n) (H2 : m <= k)
    (H3 : n <= m) (l : d_List k) := Seg' l H1 H2 H3.

 (** The same as Seg' using other functions that returns a less complicated type **)

   Definition Seg (n m k : nat) (l : d_List k) (H1 : 0 < n)
     (H2 : m <= k) (H3 : n <= m) :=
     construct_with_i_first (i:=S (m - n))
       (construct_with_i_last (i:=S (k - n)) l (le_minusSS H1 H2 H3))
       (le_le_Sminus n H2).

 (** The same as Seg with parameters order modified **)

   Definition seg (n m k : nat) (H1 : 0 < n) (H2 : m <= k)
     (H3 : n <= m) (l : d_List k) := Seg l H1 H2 H3.

 (** Applies cumulatively a function f to a list (a1.a2....an) **)
 (** Returns (f a1 (f a2 ... an))                              **)

  Fixpoint fold_with_f (n : nat) (l : d_List n) (f : A -> A -> A) {struct l}
     : 0 < n -> A :=
    match l in (d_list _ n) return (0 < n -> A) with
    | d_nil => fun h : 0 < 0 => False_rec A (lt_irrefl 0 h)
    | d_cons p a t =>
        fun _ : 0 < S p =>
        match zerop p with
        | left _ => a
        | right h => f a (fold_with_f t f h)
        end
    end.

 (** Flattens / destructures a list **)

  Fixpoint Unfold_List (n m : nat) (l : d_list (d_List n) m) {struct l} :
   d_List (m * n) :=
    match l in (d_list _ m) return (d_List (m * n)) with
    | d_nil => d_nil A
    | d_cons p a t => wcat a (Unfold_List t)
    end.

 (** Introduces a level in a list (the reverse of Unfold_List) **)

  Fixpoint Fold_List (n m : nat) {struct m} :
   d_List (m * n) -> d_list (d_List n) m :=
    match m return (d_List (m * n) -> d_list (d_List n) m) with
    | O => fun l : d_List 0 => d_nil (d_List n)
    | S p =>
        fun l : d_List (S p * n) =>
        d_cons (construct_with_i_first (i:=n) l (le_n_mult_S_n n p))
          (Fold_List (subst (minus_plus n (p * n)) (strip_off_first n l)))
    end.

End d_Lists_Compl.


From RelationalCalculus Require Import Basic_Notations Basic_Lemmas Relation_Properties Functions_Mappings Dedekind.

Module main (def : Relation).
Import def.
Module Basic_Lemmas := Basic_Lemmas.main def.
Module Relation_Properties := Relation_Properties.main def.
Module Functions_Mappings := Functions_Mappings.main def.
Module Dedekind := Dedekind.main def.
Import Basic_Lemmas Relation_Properties Functions_Mappings Dedekind.

(** %
\section{共役性の定義}
\begin{screen}
条件 $P$ を満たす関係 $\alpha :A \rel B$ と条件 $Q$ を満たす関係 $\beta :A' \rel B'$ が変換 $\alpha = \phi (\beta), \beta = \psi (\alpha)$ によって, 1 対 1 (全射的)に対応することを, 図式
$$
\frac{\alpha :A \rel B \,\, \{ P \}}{\beta :A' \rel B' \,\, \{ Q \}} \,\, \frac{\alpha = \phi (\beta)}{\beta = \psi (\alpha)}
$$
によって表す. また, Coq では以下のように表すことにする.
\end{screen}
% **)
Definition conjugate
 (A B C D : eqType) (P : Rel A B -> Prop) (Q : Rel C D -> Prop)
 (phi : Rel C D -> Rel A B) (psi : Rel A B -> Rel C D):=
 (forall alpha : Rel A B, P alpha -> Q (psi alpha) /\ phi (psi alpha) = alpha)
 /\ (forall beta : Rel C D, Q beta -> P (phi beta) /\ psi (phi beta) = beta).

(** %
\begin{screen}
さらに, 上の図式において条件 $P$ または $Q$ が不要な場合には, 以下の \verb|True_r| を代入する.
\end{screen}
% **)
Definition True_r {A B : eqType} := fun _ : Rel A B => True.

(** %
\section{共役の例}
\begin{screen}
\begin{lemma}[inv\_conjugate]
Inverse relation $(^\sharp)$ makes conjugate. That is,
$$
\frac{\alpha :A \rel B}{\beta :B \rel A} \,\, \frac{\alpha = \beta^\sharp}{\beta = \alpha^\sharp}.
$$
\end{lemma}
\end{screen}
% **)
Lemma inv_conjugate {A B : eqType}:
 conjugate A B B A True_r True_r (@inverse _ _) (@inverse _ _).
Proof.
split.
move => alpha H.
split.
by [].
apply inv_invol.
move => beta H.
split.
by [].
apply inv_invol.
Qed.

(** %
\begin{screen}
\begin{lemma}[injection\_conjugate]
Let $j :C \rightarrowtail B$ be an injection. Then,
$$
\frac{f :A \to B \,\, \{ f^\sharp \cdot f \sqsubseteq j^\sharp \cdot j \}}{h :A \to C} \,\, \frac{f=h \cdot j}{h=f \cdot j^\sharp}
$$
\end{lemma}
\end{screen}
% **)
Lemma injection_conjugate {A B C : eqType} {j : Rel C B}:
 injection_r j ->
 conjugate A B A C (fun f : Rel A B => ((f # ・ f) ⊆ (j # ・ j)) /\ function_r f)
 (fun h : Rel A C => function_r h) (fun h : Rel A C => h ・ j)
 (fun f : Rel A B => f ・ j #).
Proof.
elim.
elim => H H0 H1.
split.
move => alpha.
elim => H2.
elim => H3 H4.
assert (function_r (alpha ・ j #)).
split.
apply (@inc_trans _ _ _ _ _ H3).
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ _ j).
apply (@inc_trans _ _ _ (alpha ・ ((alpha # ・ alpha) ・ alpha #))).
rewrite comp_assoc -comp_assoc.
apply (comp_inc_compat_a_ab H3).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_a'b H2).
apply (fun H' => @inc_trans _ _ _ _ _ H' H1).
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ _ alpha).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_ab_b.
apply (@inc_trans _ _ _ _ _ H2).
apply H0.
split.
apply H5.
apply function_inc.
apply function_comp.
apply H5.
split.
apply H.
apply H0.
split.
apply H3.
apply H4.
rewrite comp_assoc.
apply comp_inc_compat_ab_a.
apply H0.
move => beta.
elim => H2 H3.
assert (function_r (beta ・ j)).
split.
apply (@inc_trans _ _ _ _ _ H2).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ j).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_b_ab H).
apply (fun H' => @inc_trans _ _ _ _ _ H' H0).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ beta).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_b H3).
split.
split.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ beta).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_b H3).
apply H4.
rewrite comp_assoc.
replace (j ・ j #) with (Id C).
apply comp_id_r.
apply inc_antisym.
apply H.
rewrite /univalent_r in H1.
rewrite inv_invol in H1.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[injection\_conjugate\_corollary1, injection\_conjugate\_corollary2]
Let $j :C \rightarrowtail B$ be an injection and $f :A \to B$ be a function. Then,
$$
f^\sharp \cdot f \sqsubseteq j^\sharp \cdot j \Leftrightarrow (\exists !h:A \to C, f=h \cdot j) \Leftrightarrow (\exists h':A \rel C, f \sqsubseteq h' \cdot j).
$$
\end{lemma}
\end{screen}
% **)
Lemma injection_conjugate_corollary1 {A B C : eqType} {f : Rel A B} {j : Rel C B}:
 injection_r j -> function_r f ->
 ((f # ・ f) ⊆ (j # ・ j) <-> exists! h : Rel A C, function_r h /\ f = h ・ j).
Proof.
move => H H0.
move : (@injection_conjugate A _ _ _ H).
elim => H1 H2.
split; move => H3.
exists (f ・ j #).
split.
move : (H1 f (conj H3 H0)).
elim => H4 H5.
split.
apply H4.
by [rewrite H5].
move => h.
elim => H4 H5.
rewrite H5 comp_assoc.
replace (j ・ j #) with (Id C).
apply comp_id_r.
rewrite /injection_r/function_r/univalent_r in H.
rewrite inv_invol in H.
apply inc_antisym.
apply H.
apply H.
elim H3 => h.
elim.
elim => H4 H5 H6.
rewrite H5 comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ h).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_ab_b.
apply H4.
Qed.

Lemma injection_conjugate_corollary2 {A B C : eqType} {f : Rel A B} {j : Rel C B}:
 injection_r j -> function_r f ->
 ((f # ・ f) ⊆ (j # ・ j) <-> exists h' : Rel A C, f ⊆ (h' ・ j)).
Proof.
move => H H0.
split; move => H1.
apply (injection_conjugate_corollary1 H H0) in H1.
elim H1 => h.
elim.
elim => H2 H3 H4.
exists h.
rewrite H3.
apply inc_refl.
elim H1 => h' H2.
replace (f # ・ f) with (f # ・ (f ∩ (h' ・ j))).
apply (@inc_trans _ _ _ ((f # ・ f) ・ (j # ・ j))).
rewrite comp_assoc cap_comm -(@comp_assoc _ _ _ _ f).
apply comp_inc_compat_ab_ab'.
apply (@inc_trans _ _ _ _ _ (dedekind2)).
apply comp_inc_compat_ab_a'b.
apply cap_r.
apply comp_inc_compat_ab_b.
apply H0.
apply f_equal.
apply inc_def1 in H2.
by [rewrite -H2].
Qed.

(** %
\begin{screen}
\begin{lemma}[surjection\_conjugate]
Let $e :A \twoheadrightarrow C$ be a surjection. Then,
$$
\frac{f :A \to B \,\, \{ e \cdot e^\sharp \sqsubseteq f \cdot f^\sharp \}}{h :C \to B} \,\, \frac{f=e \cdot h}{h=e^\sharp \cdot f}
$$
\end{lemma}
\end{screen}
% **)
Lemma surjection_conjugate {A B C : eqType} {e : Rel A C}:
 surjection_r e ->
 conjugate A B C B (fun f : Rel A B => ((e ・ e #) ⊆ (f ・ f #)) /\ function_r f)
 (fun h : Rel C B => function_r h) (fun h : Rel C B => e ・ h) (fun f : Rel A B => e # ・ f).
Proof.
elim.
elim => H H0 H1.
split.
move => alpha.
elim => H2.
elim => H3 H4.
assert (function_r (e # ・ alpha)).
split.
apply (@inc_trans _ _ _ _ _ H1).
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ alpha).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_b_ab H3).
apply (fun H' => @inc_trans _ _ _ _ _ H' H4).
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ e).
apply (@inc_trans _ _ _ (alpha # ・ ((alpha ・ alpha #) ・ alpha))).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_a'b H2).
rewrite comp_assoc -comp_assoc.
apply (comp_inc_compat_ab_a H4).
split.
apply H5.
apply Logic.eq_sym.
apply function_inc.
split.
apply H3.
apply H4.
apply function_comp.
split.
apply H.
apply H0.
apply H5.
rewrite -comp_assoc.
apply comp_inc_compat_b_ab.
apply H.
move => beta.
elim => H2 H3.
assert (function_r (e ・ beta)).
split.
apply (@inc_trans _ _ _ _ _ H).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ beta).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_b_ab H2).
apply (fun H' => @inc_trans _ _ _ _ _ H' H3).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ e).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_b H0).
split.
split.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ beta).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_b_ab H2).
apply H4.
rewrite -comp_assoc.
replace (e # ・ e) with (Id C).
apply comp_id_l.
apply inc_antisym.
rewrite /total_r in H1.
rewrite inv_invol in H1.
apply H1.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[surjection\_conjugate\_corollary]
Let $e :A \twoheadrightarrow C$ be a surjection and $f :A \to B$ be a function. Then,
$$
e \cdot e^\sharp \sqsubseteq f \cdot f^\sharp \Leftrightarrow (\exists !h:C \to B, f=e \cdot h).
$$
\end{lemma}
\end{screen}
% **)
Lemma surjection_conjugate_corollary {A B C : eqType} {f : Rel A B} {e : Rel A C}:
 surjection_r e -> function_r f ->
 ((e ・ e #) ⊆ (f ・ f #) <-> exists! h : Rel C B, function_r h /\ f = e ・ h).
Proof.
move => H H0.
move : (@surjection_conjugate _ B _ _ H).
elim => H1 H2.
split; move => H3.
exists (e # ・ f).
split.
move : (H1 f (conj H3 H0)).
elim => H4 H5.
split.
apply H4.
by [rewrite H5].
move => h.
elim => H4 H5.
rewrite H5 -comp_assoc.
replace (e # ・ e) with (Id C).
apply comp_id_l.
rewrite /surjection_r/function_r/total_r in H.
rewrite inv_invol in H.
apply inc_antisym.
apply H.
apply H.
elim H3 => h.
elim.
elim => H4 H5 H6.
rewrite H5 comp_inv comp_assoc -(@comp_assoc _ _ _ _ h).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_b_ab.
apply H4.
Qed.

(** %
\begin{screen}
\begin{lemma}[subid\_conjugate]
Subidentity $u \sqsubseteq id_A$ corresponds $\rho :I \rel A$. That is,
$$
\frac{\rho :I \rel A}{u :A \rel A \,\, \{ u \sqsubseteq id_A \}} \,\, \frac{\rho = \nabla_{IA} \cdot u}{u = id_A \sqcap \nabla_{AI} \cdot \rho}.
$$
\end{lemma}
\end{screen}
% **)
Lemma subid_conjugate {A : eqType}:
 conjugate i A A A True_r (fun u : Rel A A => u ⊆ Id A)
 (fun u : Rel A A => ∇ i A ・ u) (fun rho : Rel i A => Id A ∩ (∇ A i ・ rho)).
Proof.
split.
move => alpha H.
split.
apply cap_l.
apply inc_antisym.
apply (@inc_trans _ _ _ (∇ i A ・ (∇ A i ・ alpha))).
apply comp_inc_compat_ab_ab'.
apply cap_r.
rewrite -comp_assoc.
apply comp_inc_compat_ab_b.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
rewrite -(@inv_universal i A).
apply (fun H' => @inc_trans _ _ _ _ _ H' (dedekind1)).
rewrite comp_id_r cap_comm cap_universal.
apply inc_refl.
move => beta H.
split.
by [].
apply inc_antisym.
rewrite cap_comm -comp_assoc lemma_for_tarski2.
apply (@inc_trans _ _ _ _ _ (dedekind2)).
rewrite comp_id_l cap_comm cap_universal.
apply comp_inc_compat_ab_b.
rewrite -inv_inc_move inv_id.
apply H.
apply inc_cap.
split.
apply H.
rewrite -comp_assoc.
apply comp_inc_compat_b_ab.
rewrite lemma_for_tarski2.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[subid\_conjugate\_corollary1]
Let $u,v:A \rel A$ and $u,v \sqsubseteq id_A$. Then,
$$
\nabla_{IA} \cdot u = \nabla_{IA} \cdot v \Rightarrow u = v.
$$
\end{lemma}
\end{screen}
% **)
Lemma subid_conjugate_corollary1 {A : eqType} {u v : Rel A A}:
 u ⊆ Id A -> v ⊆ Id A -> ∇ i A ・ u = ∇ i A ・ v -> u = v.
Proof.
move => H H0 H1.
move : (@subid_conjugate A).
elim => H2 H3.
move : (H3 u H).
elim => H4 H5.
rewrite -H5.
move : (H3 v H0).
elim => H6 H7.
rewrite -H7.
apply f_equal.
apply f_equal.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[subid\_conjugate\_corollary2]
Let $\rho, {\rho}' :I \rel A$. Then,
$$
id_A \sqcap \nabla_{AI} \cdot \rho = id_A \sqcap \nabla_{AI} \cdot {\rho}' \Rightarrow \rho = {\rho'}.
$$
\end{lemma}
\end{screen}
% **)
Lemma subid_conjugate_corollary2 {A : eqType} {rho rho' : Rel i A}:
 Id A ∩ (∇ A i ・ rho) = Id A ∩ (∇ A i ・ rho') -> rho = rho'.
Proof.
move => H.
move : (@subid_conjugate A).
elim => H0 H1.
move : (H0 rho I).
elim => H2 H3.
rewrite -H3.
move : (H0 rho' I).
elim => H4 H5.
rewrite -H5.
apply f_equal.
apply H.
Qed.

End main.