Require Import VST.msl.msl_direct.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.

Require Import neg_logic.
Require Import modal_logic.

Open Local Scope logic.

Lemma sa_prop_left {A : Type}: forall (P : Prop) (Q : pred A),
  (P -> predicates_sa.derives (predicates_sa.prop True) Q) ->
       (predicates_sa.derives (predicates_sa.prop P) Q).
Proof. compute; auto. Qed.

Lemma sa_prop_right {A}: forall (P : Prop) (Q : pred A),
  P -> (predicates_sa.derives Q (predicates_sa.prop P)).
Proof. compute; auto. Qed.

Lemma sa_prop_imp_prop_left {A}: forall (P Q: Prop),
  @predicates_sa.derives A (predicates_sa.imp (predicates_sa.prop P) (predicates_sa.prop Q)) (predicates_sa.prop (P -> Q)).
Proof. compute; auto. Qed.

Lemma sa_allp_prop_left {A}: forall (B: Type) (P: B -> Prop),
  @predicates_sa.derives A (predicates_sa.allp (fun b => predicates_sa.prop (P b))) (predicates_sa.prop (forall b, P b)).
Proof. compute; auto. Qed.

Instance NDdirect A : NatDed (pred A).
apply (mkNatDed (pred A) predicates_sa.andp
                            predicates_sa.orp
                            (@predicates_sa.exp A)
                            (@predicates_sa.allp A)
                            predicates_sa.imp
                            predicates_sa.prop
                            (@predicates_sa.derives A)).
apply predicates_sa.pred_ext.
apply predicates_sa.derives_refl.
apply predicates_sa.derives_trans.
apply predicates_sa.andp_right.
apply predicates_sa.andp_left1.
apply predicates_sa.andp_left2.
apply predicates_sa.orp_left.
apply predicates_sa.orp_right1.
apply predicates_sa.orp_right2.
intros. eapply predicates_sa.exp_right. apply H.
intros. eapply predicates_sa.exp_left. apply H.
intros. eapply predicates_sa.allp_left. apply H.
intros. eapply predicates_sa.allp_right. apply H.
apply predicates_sa.imp_andp_adjoint.
(* These ones aren't in the library for some reason. *)
apply sa_prop_left.
apply sa_prop_right.
apply sa_prop_imp_prop_left.
apply sa_allp_prop_left.
Defined.

Require Import Classical.
Instance CNDdirect A : (@ClassicNatDed (pred A) (NDdirect A)).
repeat intro. destruct (classic (P a)). left; trivial. right; trivial. Qed.

Instance MLdirect (A : Type): @ModLog (A -> A -> Prop) (pred A) (NDdirect A).
  apply (mkModLog (A -> A -> Prop) (pred A) _ (fun (R : A -> A -> Prop) P a => forall a', R a a' -> P a')).
  + repeat intro. apply H. apply I.
  + repeat intro. eapply H; auto.
  + repeat intro. eapply H; auto.
Defined.

Instance MLSdirect (A : Type): @ModLogSeq (A -> A -> Prop) (A -> Prop) (NDdirect A) (MLdirect A).
  apply (mkModLogSeq _ _ _ _ (fun R1 R2 x y => exists z, R1 x z /\ R2 z y)).
  intros. apply pred_ext.
  * repeat intro.
    specialize (H a'0). apply H.
    exists a'. split; trivial.
  * repeat intro.
    destruct H0 as [z [? ?]].
    specialize (H z H0 a' H1). trivial.
Defined.

Lemma diamond_unfold: forall A R (P : pred A) a,
  (diamond R P) a <-> exists a', R a a' /\ P a'.
Proof.
  split; intro.
  + apply NNPP. intro.
    apply H. repeat intro.
    apply H0.
    exists a'. split; trivial.
  + destruct H as [a' [? ?]].
    intro.
    specialize (H1 a' H).
    destruct H1. trivial.
Qed.

Instance MLDdirect (A : Type): @ModLogDual (A -> A -> Prop) (A -> Prop) (NDdirect A) (MLdirect A).
  apply (mkModLogDual _ _ _ _ (fun R x y => R y x)).
  + intros. extensionality x y. trivial.
  + split; repeat intro.
    * apply H. intro. specialize (H2 a H1). destruct H2. trivial.
    * rewrite diamond_unfold in H0. destruct H0 as [a' [? ?]].
      specialize (H a' H1 a H0). trivial.
Defined.

(* Instantiating correspondence theory *)
(* Note: we could do these things both ways? *)
Lemma reflexive_T {A}: forall (R : A -> A -> Prop),
  (forall a, R a a) ->
  Modal_T R.
Proof.
  repeat intro.
  specialize (H a).
  specialize (H0 a H).
  trivial.
Qed.

Lemma transitive_4 {A}: forall (R : A -> A -> Prop),
  (forall a1 a2 a3, R a1 a2 -> R a2 a3 -> R a1 a3) ->
  Modal_4 R.
Proof.
  repeat intro.
  specialize (H a a' a'0 H1 H2).
  specialize (H0 a'0 H).
  trivial.
Qed.

Lemma dense_C4 {A}: forall (R : A -> A -> Prop),
  (forall a1 a2, R a1 a2 -> exists a12, R a1 a12 /\ R a12 a2) ->
  Modal_C4 R.
Proof.
  repeat intro.
  specialize (H a a' H1).
  destruct H as [a12 [? ?]].
  specialize (H0 a12 H a' H2).
  trivial.
Qed.

Lemma serial_D {A}: forall (R : A -> A -> Prop),
  (forall a1, exists a2, R a1 a2) ->
  Modal_D R.
Proof.
  repeat intro.
  specialize (H a).
  destruct H as [a' ?].
  specialize (H0 a' H).
  specialize (H1 a' H).
  destruct H1. trivial.
Qed.

Lemma functional_CD {A}: forall (R : A -> A -> Prop),
  (forall a1 a2 a3, R a1 a2 -> R a1 a3 -> a2 = a3) ->
  Modal_CD R.
Proof.
  repeat intro.
  rewrite diamond_unfold in H0.
  destruct H0 as [a'' [? ?]].
  specialize (H a a' a'' H1 H0). subst a''.
  trivial.
Qed.

Lemma symmetric_B {A}: forall (R : A -> A -> Prop),
  (forall a1 a2, R a1 a2 -> R a2 a1) ->
  Modal_B R.
Proof.
  repeat intro.
  apply H in H1.
  specialize (H2 a H1).
  destruct H2. trivial.
Qed.

Inductive finite_chains {A} (R : A -> A -> Prop) : A -> Prop :=
 | re : forall w,
   (forall w', R w w' -> finite_chains R w') -> (* if every reachable state will end *)
   finite_chains R w. (* then we will end *)

Lemma finite_chains_W {A}: forall (R : A -> A -> Prop),
  (forall w, finite_chains R w) ->
  Modal_W R.
Proof.
  repeat intro. clear H1.
  specialize (H a).
  induction H.
  apply H0.
  repeat intro.
  specialize (H1 a' H2).
  trivial.
Qed.

Lemma sa_exclude_elsewhere {A} {J : Join A} {PA: @Perm_alg A J} {SA: @Sep_alg A J} : forall (P Q : pred A),
  (predicates_sa.sepcon P Q) |-- (predicates_sa.sepcon (predicates_sa.andp P (predicates_sa.ewand Q TT)) Q).
Proof.
  intros.
  simpl.
  do 2 intro. destruct H as [h1 [h2 [? [? ?]]]].
  exists h1, h2. repeat (split; trivial).
  exists h2, a. auto.
Qed.

Instance SLdirect A {J : Join A} {PA: @Perm_alg A J} {SA: @Sep_alg A J} : @SepLog (pred A) (NDdirect A).
apply (mkSepLog (pred A) (NDdirect A) emp
                                      predicates_sa.sepcon
                                      predicates_sa.wand
                                      predicates_sa.ewand); simpl.
apply predicates_sa.sepcon_assoc.
apply predicates_sa.sepcon_comm.
intros. rewrite predicates_sa.wand_sepcon_adjoint. tauto.
apply predicates_sa.sepcon_andp_prop.
intros. apply predicates_sa.sepcon_derives; trivial.
apply predicates_sa.ewand_sepcon.
apply predicates_sa.ewand_TT_sepcon.
apply sa_exclude_elsewhere. (* not in MSL *)
apply predicates_sa.ewand_conflict.
Defined.

Instance CSdirect A {J : Join A} {PA: @Perm_alg A J} {CA: @Canc_alg A J} {SA: @Sep_alg A J} : @ClassicalSep (pred A) (NDdirect A) (SLdirect A).
constructor. intro.
apply pred_ext; repeat intro.
destruct H as [a0 [a1 [? [? ?]]]].
spec H1 a0 a (join_comm H). subst a0. trivial.
exists a, (core a). split.
apply join_comm, core_unit.
split; trivial.
apply core_identity.
Defined.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_doublereverse.
Require Import ProofCheckingEuclid.lemma_equalitysymmetric.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_midpointunique.
Require Import ProofCheckingEuclid.lemma_partnotequalwhole.
Require Import ProofCheckingEuclid.lemma_s_congruence_null_segment.
Require Import ProofCheckingEuclid.lemma_s_midpoint.
Require Import ProofCheckingEuclid.lemma_s_n_col_ncol.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_right_triangle_NC :
	forall A B C,
	RightTriangle A B C ->
	nCol A B C.
Proof.
	intros A B C.
	intros RightTriangle_ABC.

	destruct RightTriangle_ABC as (D & BetS_A_B_D & Cong_AB_DB & Cong_AC_DC & neq_B_C).

	pose proof (lemma_betweennotequal _ _ _ BetS_A_B_D) as (_ & neq_A_B & neq_A_D).
	pose proof (lemma_inequalitysymmetric _ _ neq_A_B) as neq_B_A.

	assert (Col A B D) as Col_A_B_D by (unfold Col; one_of_disjunct BetS_A_B_D).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_D) as (Col_B_A_D & _ & _ & _ & _).

	pose proof (lemma_congruenceflip _ _ _ _ Cong_AB_DB) as (_ & _ & Cong_AB_BD).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AC_DC) as (Cong_CA_CD & _ & Cong_AC_CD).
	pose proof (lemma_doublereverse _ _ _ _ Cong_AC_DC) as (Cong_CD_CA & _).

	pose proof (lemma_s_midpoint _ _ _ BetS_A_B_D Cong_AB_BD) as Midpoint_A_B_D.

	assert (~ BetS A C D) as nBetS_A_C_D.
	{
		intros BetS_A_C_D.

		pose proof (lemma_s_midpoint _ _ _ BetS_A_C_D Cong_AC_CD) as Midpoint_A_C_D.
		pose proof (lemma_midpointunique _ _ _ _ Midpoint_A_B_D Midpoint_A_C_D) as eq_B_C.

		contradict eq_B_C.
		exact neq_B_C.
	}

	assert (~ eq C A) as neq_C_A.
	{
		intros eq_C_A.

		assert (Cong C C D C) as Cong_CC_DC by (setoid_rewrite eq_C_A at 1; exact Cong_AC_DC).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_CC_DC) as Cong_DC_CC.
		pose proof (lemma_s_congruence_null_segment _ _ _ Cong_DC_CC) as eq_D_C.
		assert (eq D A) as eq_D_A by (rewrite <- eq_C_A; exact eq_D_C).
		pose proof (lemma_equalitysymmetric _ _ eq_D_A) as eq_A_D.

		contradict eq_A_D.
		exact neq_A_D.
	}
	pose proof (lemma_inequalitysymmetric _ _ neq_C_A) as neq_A_C.

	assert (~ eq C D) as neq_C_D.
	{
		intros eq_C_D.

		assert (Cong A C D D) as Cong_AC_DD by (setoid_rewrite <- eq_C_D at 2; exact Cong_AC_DC).
		pose proof (lemma_s_congruence_null_segment _ _ _ Cong_AC_DD) as eq_A_C.
		pose proof (lemma_equalitysymmetric _ _ eq_A_C) as eq_C_A.

		contradict eq_C_A.
		exact neq_C_A.
	}

	assert (~ BetS C A D) as nBetS_C_A_D.
	{
		intros BetS_C_A_D.

		pose proof (lemma_partnotequalwhole _ _ _ BetS_C_A_D) as nCong_CA_CD.

		contradict Cong_CA_CD.
		exact nCong_CA_CD.
	}

	assert (~ BetS A D C) as nBetS_A_D_C.
	{
		intros BetS_A_D_C.

		pose proof (axiom_betweennesssymmetry _ _ _ BetS_A_D_C) as BetS_C_D_A.
		pose proof (lemma_partnotequalwhole _ _ _ BetS_C_D_A) as nCong_CD_CA.

		contradict Cong_CD_CA.
		exact nCong_CD_CA.
	}

	assert (nCol A C D) as nCol_A_C_D.
	unfold nCol.
	repeat split.
	exact neq_A_C.
	exact neq_A_D.
	exact neq_C_D.
	exact nBetS_A_C_D.
	exact nBetS_A_D_C.
	exact nBetS_C_A_D.

	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_C_D) as n_Col_A_C_D.

	assert (~ Col A B C) as n_Col_A_B_C.
	{
		intros Col_A_B_C.

		pose proof (lemma_collinearorder _ _ _ Col_A_B_C) as (Col_B_A_C & _ & _ & _ & _).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_A_C Col_B_A_D neq_B_A) as Col_A_C_D.

		contradict Col_A_C_D.
		exact n_Col_A_C_D.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_A_B_C) as nCol_A_B_C.

	exact nCol_A_B_C.
Qed.

End Euclid.


Require Import Coq.Lists.List.

Section IntroPatterns.
  Variables (A : Type) (xs ys : list A).

  Example ThreeIntroPatternsCombined :
    S (length ys) = 1 -> xs ++ ys = xs.
  Proof. intros [=->%length_zero_iff_nil]. apply app_nil_r. Qed.
  (** Notes:
      [=] uses injectivity of constructors to strip of [S]s
      [intros [=H%length_zero_iff_nil].] would strip of [S]s, turn
      [length ys = 0] into [ys = nil] and move it into the context as [H]
      But [->] lets us rewrite the equation right away *)

  Theorem conditional_2 (P Q : Prop) : (P -> Q) -> ~(P /\ ~Q).
  Proof. intros p_to_q [q%p_to_q []]; exact q. Qed.
  (** Notes: %p_to_q weakens P to Q on the fly and
             [] applies the hypothesis of type (~ Q) to the goal *)

End IntroPatterns.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_2.

Coq < Goal forall j k l:Prop, (((j \/ (k /\ l)) /\ ~k)) -> j.
1 subgoal

  ============================
   forall j k l : Prop, (j \/ k /\ l) /\ ~ k -> j

Unnamed_thm < intros.
1 subgoal

  j : Prop
  k : Prop
  l : Prop
  H : (j \/ k /\ l) /\ ~ k
  ============================
   j

Unnamed_thm < elim H.
1 subgoal

  j : Prop
  k : Prop
  l : Prop
  H : (j \/ k /\ l) /\ ~ k
  ============================
   j \/ k /\ l -> ~ k -> j

Unnamed_thm < intro.
1 subgoal

  j : Prop
  k : Prop
  l : Prop
  H : (j \/ k /\ l) /\ ~ k
  H0 : j \/ k /\ l
  ============================
   ~ k -> j

Unnamed_thm < intro.
1 subgoal

  j : Prop
  k : Prop
  l : Prop
  H : (j \/ k /\ l) /\ ~ k
  H0 : j \/ k /\ l
  H1 : ~ k
  ============================
   j

Unnamed_thm < destruct H0.
2 subgoals

  j : Prop
  k : Prop
  l : Prop
  H : (j \/ k /\ l) /\ ~ k
  H0 : j
  H1 : ~ k
  ============================
   j

subgoal 2 is:
 j

Unnamed_thm < exact H0.
1 subgoal

  j : Prop
  k : Prop
  l : Prop
  H : (j \/ k /\ l) /\ ~ k
  H0 : k /\ l
  H1 : ~ k
  ============================
   j

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
destruct H0.
 exact H0.
 firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_2.
Goal forall j k l:Prop, (((j \/ (k /\ l)) /\ ~k)) -> j.
intros.
elim H.
intro.
intro.
destruct H0.
 exact H0.
 firstorder.
 Qed.


Require Import CaMain.

(* This example consists on using two FIFO channels of capacity one in order to build  *)
(* a single Reo channel which is a FIFO channel with capacity two. This is done by for-*)
(* malizing Constraint Automata of both channels with capacity one and then, by means  *)
(* of the product operation, the corresponding product automaton is built.             *)

Inductive fifoStates := q0a | p0a | p1a | q0b | p0b | p1b.
Inductive fifoPorts := A | B | C | D.

Instance fifoStatesEq : EqDec fifoStates eq :=
	{equiv_dec x y :=
		match x, y with
		| q0a,q0a => in_left
		| p0a,p0a => in_left
		| p1a,p1a => in_left
		| q0b,q0b => in_left
		| p0b,p0b => in_left
		| p1b,p1b => in_left
		| q0a,p0a => in_right
		| q0a,p1a => in_right
		| q0a,q0b => in_right
		| q0a,p0b => in_right
		| q0a,p1b => in_right
		| p0a,q0a => in_right
		| p0a,p1a => in_right
		| p0a,q0b => in_right
		| p0a,p0b => in_right
		| p0a,p1b => in_right
		| p1a,q0a => in_right
		| p1a,p0a => in_right
		| p1a,q0b => in_right
		| p1a,p0b => in_right
		| p1a,p1b => in_right
		| q0b,q0a => in_right
		| q0b,p0a => in_right
		| q0b,p1a => in_right
		| q0b,p0b => in_right
		| q0b,p1b => in_right
		| p0b,q0a => in_right
		| p0b,p0a => in_right
		| p0b,p1a => in_right
		| p0b,q0b => in_right
		| p0b,p1b => in_right
		| p1b,q0a => in_right
		| p1b,p0a => in_right
		| p1b,p1a => in_right
		| p1b,q0b => in_right
		| p1b,p0b => in_right
		end
	}.
   Proof.
   all: congruence.
   Defined.

Instance fifoPortsEq : EqDec fifoPorts eq :=
	{equiv_dec x y :=
		match x, y with
		| A,A => in_left
		| B,B => in_left
		| C,C => in_left
		| D,D => in_left
		| A,B => in_right
		| A,C => in_right
		| A,D => in_right
		| B,A => in_right
		| B,C => in_right
		| B,D => in_right
		| C,A => in_right
		| C,B => in_right
		| C,D => in_right
		| D,A => in_right
		| D,B => in_right
		| D,C => in_right
		end
	}.
  Proof.
  all:congruence.
  Defined.

  Definition dataAssignmentA n :=
    match n with
    | 0 => Some 0
    | 1 => Some 0
    | 2 => Some 1
    | S n => Some (0)
    end.

  Definition dataAssignmentB n :=
    match n with
    | 0 => Some 0
    | 1 => Some (0)
    | 2 => Some 1
    | S n => Some 1
    end.

  Definition timeStampFIFOA(n:nat) : QArith_base.Q :=
    match n with
    | 0 =>  1#1
    | 1 =>  4#1
    | 2 =>  7#1
    | 3 =>  10#1
    | 4 =>  13#1
    | 5 =>  15#1
    | S n =>  Z.of_N (N.of_nat(S n)) + 16#1
    end.

  Definition timeStampFIFOB (n:nat) : QArith_base.Q :=
    match n with
    | 0 =>  2#1
    | 1 =>  5#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S n =>  Z.of_N (N.of_nat(S n)) + 16#1
    end.

  Definition dataAssignmentC n :=
    match n with
    | 0 => Some 0
    | 1 => Some (0)
    | 2 => Some 1
    | S n => Some 0
    end.

  Definition timeStampFIFOC(n:nat) : QArith_base.Q :=
    match n with
    | 0 =>  3#1
    | 1 =>  6#1
    | 2 =>  9#1
    | 3 =>  12#1
    | 4 =>  15#1
    | 5 =>  18#1
    | S n =>  Z.of_N (N.of_nat(S n)) + 17#1
    end.

  Lemma timeStampTestFIFOAHolds : forall n,
    Qlt (timeStampFIFOA n) (timeStampFIFOA (S n)).
  Proof.
  intros. destruct n. unfold timeStampFIFOA. reflexivity.
  unfold timeStampFIFOA. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat. Defined.

  Lemma timeStampTestFIFOBHolds : forall n,
    Qlt (timeStampFIFOB n) (timeStampFIFOB (S n)).
  Proof.
  intros. destruct n. unfold timeStampFIFOB. reflexivity.
  unfold timeStampFIFOB. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qle. apply orderZofNat. Defined.

  Lemma timeStampTestFIFOCHolds : forall n,
    Qlt (timeStampFIFOC n) (timeStampFIFOC (S n)).
  Proof.
  intros. destruct n. unfold timeStampFIFOC. reflexivity.
  unfold timeStampFIFOC. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qle. apply orderZofNat. Defined.

  Definition portAF := {|
        ConstraintAutomata.id := A;
        ConstraintAutomata.dataAssignment := dataAssignmentA;
        ConstraintAutomata.timeStamp := timeStampFIFOA;
        ConstraintAutomata.tdsCond := timeStampTestFIFOAHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portBF := {|
        ConstraintAutomata.id := B;
        ConstraintAutomata.dataAssignment := dataAssignmentB;
        ConstraintAutomata.timeStamp := timeStampFIFOB;
        ConstraintAutomata.tdsCond := timeStampTestFIFOBHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portCF := {|
        ConstraintAutomata.id := C;
        ConstraintAutomata.dataAssignment := dataAssignmentC;
        ConstraintAutomata.timeStamp := timeStampFIFOC;
        ConstraintAutomata.tdsCond := timeStampTestFIFOCHolds;
        ConstraintAutomata.index := 0 |}.

  (* realports is an input theta \in TDS^names given as input for constraint automata. *)
  (* Therefore, realports is an accepting data flow for runs that lasts 6 steps        *)
  Definition realports := [portAF;portBF;portCF].

  Definition oneBoundedFIFOrel (s:fifoStates) :
    set (set fifoPorts * ConstraintAutomata.DC fifoPorts (option nat) *
          fifoStates) :=
    match s with
    | q0a => [([A], (ConstraintAutomata.dc A (Some 0)), p0a) ;
              ([A], (ConstraintAutomata.dc A (Some 1)), p1a)]
    | p0a => [([B], (ConstraintAutomata.dc B (Some 0)), q0a)]
    | p1a => [([B], (ConstraintAutomata.dc B (Some 1)), q0a)]
    | q0b | p0b | p1b => []
    end.

Check oneBoundedFIFOrel.

  Definition oneBoundedFIFOCA:= {|
    ConstraintAutomata.Q := [q0a;p0a;p1a];
    ConstraintAutomata.N := [A;B];
    ConstraintAutomata.T := oneBoundedFIFOrel;
    ConstraintAutomata.Q0 := [q0a]
  |}.

  (*Second FIFO CA *)

  Definition oneBoundedFIFOrel2 (s:fifoStates) :=
    match s with
    | q0b => [([B], (ConstraintAutomata.dc B (Some 0)), p0b) ;
              ([B], (ConstraintAutomata.dc B (Some 1)), p1b)]
    | p0b => [([C], (ConstraintAutomata.dc C (Some 0)), q0b)]
    | p1b => [([C], (ConstraintAutomata.dc C (Some 1)), q0b)]
    | q0a | p0a | p1a => []
    end.

  Definition oneBoundedFIFOCA2 := {|
    ConstraintAutomata.Q := [q0b;p0b;p1b];
    ConstraintAutomata.N := [B;C];
    ConstraintAutomata.T := oneBoundedFIFOrel2;
    ConstraintAutomata.Q0 := [q0b]
  |}.

  Definition twoBoundedFifo := ProductAutomata.buildPA oneBoundedFIFOCA oneBoundedFIFOCA2.

  (* Ex 1 *)

  (* ru6 is a lemma which asserts that the data flow denoted by the TDS denoted by realports *)
  (* is an accepting run with six steps                                                      *)
  Definition ru6 := Eval compute in ConstraintAutomata.run twoBoundedFifo realports 6.

  Lemma ru6Accept : ~ (In ([]) (ru6)).
  Proof.
  intros. unfold not. unfold ru6. simpl. intros. repeat (destruct H ; inversion H). Defined.

  (* Second example: a non-accepting run on another theta \in TDS^names as input. *)

  (* Second data flow *)

    Definition dataAssignmentA2 n :=
    match n with
    | 0 => Some 0
    | 1 => Some 0
    | 2 => Some 1
    | S n => Some (0)
    end.

  Definition dataAssignmentB2 n :=
    match n with
    | 0 => Some 0
    | 1 => Some (0)
    | 2 => Some 1
    | S n => Some 1
    end.

  Definition timeStampFIFOA2(n:nat) : QArith_base.Q :=
    match n with
    | 0 =>  1#1
    | 1 =>  3#1
    | 2 =>  7#1
    | 3 =>  10#1
    | 4 =>  13#1
    | 5 =>  15#1
    | S n =>  Z.of_N (N.of_nat(S n)) + 20#1
    end.

  Definition timeStampFIFOB2 (n:nat) : QArith_base.Q :=
    match n with
    | 0 =>  2#1
    | 1 =>  5#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S n =>  Z.of_N (N.of_nat(S n)) + 14#1
    end.

  Definition dataAssignmentC2 n :=
    match n with
    | 0 => Some 0
    | 1 => Some (0)
    | 2 => Some 1
    | S n => Some 0
    end.

  Definition timeStampFIFOC2(n:nat) : QArith_base.Q :=
    match n with
    | 0 =>  4#1
    | 1 =>  6#1
    | 2 =>  9#1
    | 3 =>  12#1
    | 4 =>  15#1
    | 5 =>  18#1
    | S n =>  Z.of_N (N.of_nat(S n)) + 15#1
    end.

  Lemma timeStampTestFIFOA2Holds : forall n,
    Qlt (timeStampFIFOA2 n) (timeStampFIFOA2 (S n)).
  Proof.
  intros. destruct n. unfold timeStampFIFOA2. reflexivity.
  unfold timeStampFIFOA2. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampTestFIFOB2Holds : forall n,
    Qlt (timeStampFIFOB2 n) (timeStampFIFOB2 (S n)).
  Proof.
  intros. destruct n. unfold timeStampFIFOB2. reflexivity.
  unfold timeStampFIFOB2. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qle. apply orderZofNat. Defined.

  Lemma timeStampTestFIFOC2Holds : forall n,
    Qlt (timeStampFIFOC2 n) (timeStampFIFOC2 (S n)).
  Proof.
  intros. destruct n. unfold timeStampFIFOC2. reflexivity.
  unfold timeStampFIFOC2. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qle. apply orderZofNat. Defined.

  Definition portA2 := {|
        ConstraintAutomata.id := A;
        ConstraintAutomata.dataAssignment := dataAssignmentA2;
        ConstraintAutomata.timeStamp := timeStampFIFOA2;
        ConstraintAutomata.tdsCond := timeStampTestFIFOA2Holds;
        ConstraintAutomata.index := 0 |}.

  Definition portB2 := {|
        ConstraintAutomata.id := B;
        ConstraintAutomata.dataAssignment := dataAssignmentB2;
        ConstraintAutomata.timeStamp := timeStampFIFOB2;
        ConstraintAutomata.tdsCond := timeStampTestFIFOB2Holds;
        ConstraintAutomata.index := 0 |}.

  Definition portC2 := {|
        ConstraintAutomata.id := C;
        ConstraintAutomata.dataAssignment := dataAssignmentC2;
        ConstraintAutomata.timeStamp := timeStampFIFOC2;
        ConstraintAutomata.tdsCond := timeStampTestFIFOC2Holds;
        ConstraintAutomata.index := 0 |}.

  Definition ru62 := Eval compute in ConstraintAutomata.run twoBoundedFifo [portA2;portB2;portC2] 8.

  (* ru62 describes a nonaccepting run *)
  Lemma ru62Accept : ~ (In ([]) (ru62)).
  Proof.
  intros. unfold not. unfold ru62. simpl. intros. repeat (destruct H ; inversion H). Defined.

  (* In this very run, there is a moment in which the buffer becomes full with two zeroes *)
  (* This is denoted by fullFifoWith0*)
  Lemma fullFifoWith0 : In [(p0a,p0b)] ru62.
  Proof. simpl; auto. Defined.


(** * Examples

A typical use for displayed categories is for constructing categories of structured objects, over a given (specific or general) category. We give a few examples here:

- category of topological space as total category
- arrow precategories
- objects with N-actions
- elements, over hSet

*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Local Open Scope cat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Limits.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.SIP.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing.

Local Open Scope mor_disp_scope.

(** * Displayed category of groups *)

Module group.

Definition grp_structure_data (X : hSet) : UU
  := (X -> X -> X) × X × (X -> X).
Definition mult {X : hSet} (G : grp_structure_data X)
           : X -> X -> X := pr1 G.
Definition e {X : hSet} (G : grp_structure_data X)
           : X := pr1 (pr2 G).
Definition inv {X : hSet} (G : grp_structure_data X)
           : X -> X := pr2 (pr2 G).

Definition grp_structure_axioms {X : hSet}
           (G : grp_structure_data X) : UU
  := (∏ x y z : X, mult G x (mult G y z) = mult G (mult G x y) z)
       ×
     (∏ x : X, mult G x (e G) = x)
       ×
     (∏ x : X, mult G (e G) x = x)
       ×
     (∏ x : X, mult G x (inv G x) = e G)
       ×
     (∏ x : X, mult G (inv G x) x = e G).

Definition grp_assoc {X : hSet} {G : grp_structure_data X}
           (GH : grp_structure_axioms G)
  : ∏ x y z : X, mult G x (mult G y z) = mult G (mult G x y) z := pr1 GH.
Definition grp_e_r {X : hSet} {G : grp_structure_data X}
           (GH : grp_structure_axioms G)
  : ∏ x : X, mult G x (e G) = x := pr1 (pr2 GH).
Definition grp_e_l {X : hSet} {G : grp_structure_data X}
           (GH : grp_structure_axioms G)
  : ∏ x : X, mult G (e G) x = x := pr1 (pr2 (pr2 GH)).
Definition grp_inv_r {X : hSet} {G : grp_structure_data X}
           (GH : grp_structure_axioms G)
  : ∏ x : X, mult G x (inv G x) = e G := pr1 (pr2 (pr2 (pr2 GH))).
Definition grp_inv_l {X : hSet} {G : grp_structure_data X}
           (GH : grp_structure_axioms G)
  : ∏ x : X, mult G (inv G x) x = e G := pr2 (pr2 (pr2 (pr2 GH))).

Definition grp_structure (X : hSet) : UU
  := ∑ G : grp_structure_data X, grp_structure_axioms G.
Coercion grp_data {X} (G : grp_structure X) : grp_structure_data X := pr1 G.
Coercion grp_axioms {X} (G : grp_structure X) : grp_structure_axioms _ := pr2 G.

Definition is_grp_hom {X Y : hSet} (f : X -> Y)
           (GX : grp_structure X) (GY : grp_structure Y) : UU
           := (∏ x x', f (mult GX x x') = mult GY (f x) (f x'))
                ×
              (f (e GX) = e GY).
Definition grp_hom_mult {X Y : hSet} {f : X -> Y}
           {GX : grp_structure X} {GY : grp_structure Y}
           (is : is_grp_hom f GX GY)
           : ∏ x x', f (mult GX x x') = mult GY (f x) (f x') := pr1 is.
Definition grp_hom_e {X Y : hSet} {f : X -> Y}
           {GX : grp_structure X} {GY : grp_structure Y}
           (is : is_grp_hom f GX GY)
           : f (e GX) = e GY := pr2 is.

Definition isaprop_is_grp_hom {X Y : hSet} (f : X -> Y)
           (GX : grp_structure X) (GY : grp_structure Y)
  : isaprop (is_grp_hom f GX GY).
Proof.
  repeat apply (isofhleveldirprod);
  repeat (apply impred; intro);
  apply setproperty.
Qed.

Definition disp_grp : disp_cat hset_category.
Proof.
  use disp_struct.
  - exact grp_structure.
  - intros X Y GX GY f. exact (is_grp_hom f GX GY).
  - intros.  apply isaprop_is_grp_hom.
  - intros. simpl.
    repeat split; intros; apply idpath.
  - intros ? ? ? ? ? ? ? ? Gf Gg  ; simpl in *;
    repeat split; intros; simpl; cbn.
    + rewrite (grp_hom_mult Gf).
      apply (grp_hom_mult Gg).
    + rewrite (grp_hom_e Gf).
      apply (grp_hom_e Gg).
Defined.

End group.

(** ** The displayed arrow category

A very fertile example: many others can be obtained from it by reindexing. *)
Section Arrow_Disp.

Context (C:category).

Definition arrow_disp_ob_mor : disp_cat_ob_mor (category_binproduct C C).
Proof.
  exists (λ xy : (C × C), (pr1 xy) --> (pr2 xy)).
  simpl; intros xx' yy' g h ff'.
    exact (pr1 ff' · h = g · pr2 ff').
Defined.

Definition arrow_id_comp : disp_cat_id_comp _ arrow_disp_ob_mor.
Proof.
  split.
  - simpl; intros.
    eapply pathscomp0. apply id_left. apply pathsinv0, id_right.
  - simpl; intros x y z f g xx yy zz ff gg.
    eapply pathscomp0. apply @pathsinv0, assoc.
    eapply pathscomp0. apply maponpaths, gg.
    eapply pathscomp0. apply assoc.
    eapply pathscomp0. apply cancel_postcomposition, ff.
    apply pathsinv0, assoc.
Qed.

Definition arrow_data : disp_cat_data _
  := (arrow_disp_ob_mor ,, arrow_id_comp).

Lemma arrow_axioms : disp_cat_axioms (category_binproduct C C) arrow_data.
Proof.
  repeat apply tpair; intros; try apply homset_property.
  apply isasetaprop, homset_property.
Qed.

Definition arrow_disp : disp_cat (category_binproduct C C)
  := (arrow_data ,, arrow_axioms).

End Arrow_Disp.

(** ** Objects with N-action

For any category C, “C-objects equipped with an N-action” (or more elementarily, with an endomorphism) form a displayed category over C
Section ZAct.

Once we have pullbacks of displayed precategories, this can be obtained as a pullback of the previous example. *)

Section NAction.

Context (C:category).

Definition NAction_disp_ob_mor : disp_cat_ob_mor C.
Proof.
  exists (λ c, c --> c).
  intros x y xx yy f. exact (f · yy = xx · f).
Defined.

Definition NAction_id_comp : disp_cat_id_comp C NAction_disp_ob_mor.
Proof.
  split.
  - simpl; intros.
    eapply pathscomp0. apply id_left. apply pathsinv0, id_right.
  - simpl; intros x y z f g xx yy zz ff gg.
    eapply pathscomp0. apply @pathsinv0, assoc.
    eapply pathscomp0. apply maponpaths, gg.
    eapply pathscomp0. apply assoc.
    eapply pathscomp0. apply cancel_postcomposition, ff.
    apply pathsinv0, assoc.
Qed.

Definition NAction_data : disp_cat_data C
  := (NAction_disp_ob_mor ,, NAction_id_comp).

Lemma NAction_axioms : disp_cat_axioms C NAction_data.
Proof.
  repeat apply tpair; intros; try apply homset_property.
  apply isasetaprop, homset_property.
Qed.

Definition NAction_disp : disp_cat C
  := (NAction_data ,, NAction_axioms).

End NAction.

(** ** Elements of sets

A presheaf on a (pre)category can be viewed as a fiberwise discrete displayed (pre)category. In fact, the universal example of this is the case corresponding to the identity functor on [SET].  So, having given the displayed category for this case, one obtains it for arbitrary presheaves by reindexing. *)

(* TODO: move? ponder? *)

Section Elements_Disp.

Definition elements_ob_mor : disp_cat_ob_mor HSET.
Proof.
  use tpair.
  - simpl. exact (λ X, X).
  - simpl. intros X Y x y f. exact (f x = y).
Defined.

Lemma elements_id_comp : disp_cat_id_comp HSET elements_ob_mor.
Proof.
  apply tpair; simpl.
  - intros X x. apply idpath.
  - intros X Y Z f g x y z e_fx_y e_gy_z. cbn.
    eapply pathscomp0. apply maponpaths, e_fx_y. apply e_gy_z.
Qed.

Definition elements_data : disp_cat_data HSET
  := (_ ,, elements_id_comp).

Lemma elements_axioms : disp_cat_axioms HSET elements_data.
Proof.
  repeat split; intros; try apply setproperty.
  apply isasetaprop; apply setproperty.
Qed.

Definition elements_universal : disp_cat HSET
  := (_ ,, elements_axioms).

Definition disp_cat_of_elements {C : category} (P : functor C HSET)
  := reindex_disp_cat P elements_universal.

Definition elements_universal_mor_eq
           {X Y : HSET}
           {f : X --> Y}
           {x : elements_universal X}
           {y : elements_universal Y}
           (ff₁ ff₂ : x -->[ f ] y)
  : ff₁ = ff₂.
Proof.
  apply Y.
Qed.

Definition is_z_iso_disp_elements_universal
           {X Y : HSET}
           {f : X --> Y}
           (Hf : is_z_isomorphism f)
           {x : elements_universal X}
           {y : elements_universal Y}
           (ff : x -->[ f ] y)
  : is_z_iso_disp (make_z_iso' _ Hf) ff.
Proof.
  simple refine (_ ,, _ ,, _).
  - pose (eqtohomot (z_iso_inv_after_z_iso (make_z_iso' f Hf)) x) as p.
    cbn in *.
    refine (_ @ p).
    apply maponpaths.
    exact (!ff).
  - apply elements_universal_mor_eq.
  - apply elements_universal_mor_eq.
Qed.

Definition is_opcartesian_disp_elements_universal
           {X Y : HSET}
           {f : X --> Y}
           {x : elements_universal X}
           {y : elements_universal Y}
           (p : x -->[ f ] y)
  : is_opcartesian p.
Proof.
  intros Z z g q.
  use iscontraprop1.
  - use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      apply elements_universal.
    }
    apply elements_universal_mor_eq.
  - simple refine (_ ,, _).
    + exact (maponpaths g (!p) @ q).
    + apply elements_universal_mor_eq.
Qed.

Definition opcleaving_elements_universal
  : opcleaving elements_universal.
Proof.
  intros X Y x f.
  simple refine (_ ,, _).
  - exact (f x).
  - refine (idpath _ ,, _) ; cbn.
    apply is_opcartesian_disp_elements_universal.
Defined.

(* TODO: compare to other definitions of this in the library! *)
Definition precat_of_elements {C : category} (P : functor C HSET)
  := total_category (disp_cat_of_elements P).

End Elements_Disp.

Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.

Section functor_algebras.

Context {C : category} (F : functor C C).

Definition functor_alg_ob : C -> UU := λ c, F c --> c.

Definition functor_alg_mor
  : ∏ (x y : C), functor_alg_ob x → functor_alg_ob y → C⟦x,y⟧ → UU.
Proof.
  intros c d a a' r. exact ( (#F r)%cat · a' = a · r).
Defined.

Definition isaprop_functor_alg_mor
  :  ∏ (x y : C) a a' r,
     isaprop (functor_alg_mor x y a a' r).
Proof.
  intros. simpl. apply homset_property.
Qed.

Definition functor_alg_id
: ∏ (x : C) (a : functor_alg_ob x), functor_alg_mor _ _ a a (identity x ).
Proof.
  intros; unfold functor_alg_mor.
  rewrite functor_id;
  rewrite id_left;
  apply pathsinv0; apply id_right .
Qed.

Definition functor_alg_comp
  : ∏ (x y z : C) a b c (f : C⟦x,y⟧) (g : C⟦y,z⟧),
                 functor_alg_mor _ _  a b f
                 → functor_alg_mor _ _  b c g
                 → functor_alg_mor _ _  a c (f · g).
Proof.
  cbn; intros ? ? ? ? ? ? ? ? X X0;
  unfold functor_alg_mor in *;
  rewrite functor_comp;
  rewrite <-assoc; rewrite X0;
  rewrite assoc; rewrite X;
  apply (!assoc _ _ _ ) .
Qed.

Definition disp_cat_functor_alg : disp_cat C
  := disp_struct _ _
                 functor_alg_mor
                 isaprop_functor_alg_mor
                 functor_alg_id
                 functor_alg_comp.

Definition total_functor_alg : category := total_category disp_cat_functor_alg.

Lemma isaset_functor_alg_ob : ∏ x : C, isaset (functor_alg_ob x).
Proof.
  intro c.
  apply homset_property.
Qed.

Lemma is_univalent_disp_functor_alg : is_univalent_disp disp_cat_functor_alg.
Proof.
  use is_univalent_disp_from_SIP_data.
  - apply isaset_functor_alg_ob.
  - unfold functor_alg_mor.
    intros x a a' H H'.
    rewrite functor_id in H'.
    rewrite id_left in H'.
    rewrite id_right in H'.
    apply H'.
Defined.

Definition iso_cleaving_functor_alg : iso_cleaving disp_cat_functor_alg.
Proof.
  intros c c' i d.
  cbn in *.
  use tpair.
  - exact (compose (compose (functor_on_z_iso F i) d) (z_iso_inv_from_z_iso i)).
  - cbn. unfold z_iso_disp. cbn.
    use tpair.
    + abstract (
          etrans; [eapply pathsinv0; apply id_right |];
          repeat rewrite <- assoc;
          do 2 apply maponpaths;
          apply pathsinv0; apply z_iso_after_z_iso_inv
        ).
    + use tpair.
      * unfold functor_alg_mor.
        cbn. repeat rewrite assoc.
        unfold functor_alg_mor. cbn.
        rewrite <- functor_comp.
        rewrite z_iso_after_z_iso_inv.
        rewrite functor_id.
        rewrite id_left. apply idpath.
      * split; apply homset_property.
Defined.

Local Notation "'π'" := (pr1_category disp_cat_functor_alg).

Definition creates_limits_functor_alg
  : creates_limits disp_cat_functor_alg.
Proof.
  intros J D x L isL.
  unfold creates_limit. cbn.
  transparent assert (FC : (cone (mapdiagram π D) (F x))).
  { use make_cone.
    - intro j.
      eapply compose.
      apply ((#F)%cat (coneOut L j )).
      cbn. exact (pr2 (dob D j)).
    - abstract (
      red; intros; cbn;
      assert (XR := pr2 (dmor D e)); cbn in XR;
      etrans; [eapply pathsinv0; apply assoc |];
      etrans; [apply maponpaths, (!XR) |];
      etrans; [apply assoc |];
      apply maponpaths_2;
      rewrite <- functor_comp;
      apply maponpaths;
      apply (coneOutCommutes L)
      ).
  }
  transparent assert (LL : (LimCone (mapdiagram π D))).
  { use make_LimCone. apply x. apply L. apply isL. }
  use tpair.
  - use tpair.
    + use tpair.
      * use (limArrow LL). apply FC.
      * abstract (
          use tpair ;
          [
            intro j; cbn;
            set (XR := limArrowCommutes LL _ FC); cbn in XR;
            apply pathsinv0; apply XR
          | cbn; intros i j e;
            apply subtypePath;
            [ intro; apply homset_property |];
            cbn; apply (coneOutCommutes L)
          ]).
    + abstract (
      intro t; cbn;
      use total2_paths_f;
      [ cbn;
        apply (limArrowUnique LL);
        induction t as [t [H1 H2]]; cbn in *;
        intro j;
        apply pathsinv0, H1 |];
      apply proofirrelevance;
      apply isofhleveltotal2;
      [ apply impred_isaprop; intro; apply homset_property |];
      intros; do 3 (apply impred_isaprop; intro);
        apply (homset_property (total_category _ ))
        ).
  - cbn.
    intros x' CC.
    set (πCC := mapcone π D CC).
    use unique_exists.
    + use tpair.
      * cbn.
        use (limArrow LL _ πCC).
      * set (XR := limArrowCommutes LL).
        cbn in XR.
        set (H1:= coneOutCommutes CC). simpl in H1.
        destruct x' as [c a]. cbn.
        unfold disp_cat_functor_alg in a. cbn in a.
        cbn in πCC.
        transparent assert (X : (cone (mapdiagram π D) (F c))).
        { use make_cone.
          - intro j.
            apply (λ f, a · f). cbn.
            apply (coneOut CC j).
          - abstract (
            intros u v e; cbn;
            rewrite <- assoc;
            apply maponpaths;
            apply (maponpaths pr1 (coneOutCommutes CC _ _ _ ))
                  ).
        }

        {
          unfold functor_alg_mor.
          intermediate_path (limArrow LL _ X).
          - apply (limArrowUnique LL).
            intro j. rewrite <- assoc.
            rewrite (limArrowCommutes LL).
            cbn.
            rewrite assoc.
            rewrite <- functor_comp.
            etrans. apply maponpaths_2. apply maponpaths.
            apply (limArrowCommutes LL). cbn.
            set (H := pr2 (coneOut CC j)).  cbn in H. apply H.
          - apply pathsinv0.
            use (limArrowUnique LL).
            intro j.
            rewrite <- assoc.
            rewrite (limArrowCommutes LL).
            cbn.
            apply idpath.
        }
    + simpl.
      intro j.
      apply subtypePath.
      { intro. apply homset_property. }
      cbn. apply (limArrowCommutes LL).
    + intros.
      apply impred_isaprop. intro t. (apply (homset_property (total_category _ ))).
    + simpl.
      intros.
      apply subtypePath.
      { intro. apply homset_property. }
      apply (limArrowUnique LL).
      intro u.
      specialize (X u).
      apply (maponpaths pr1 X).
Defined.

End functor_algebras.

Section monad_algebras.

Context {C : category} (T : Monad C).

Let T' : C ⟶ C := T.
Let FAlg : category := total_functor_alg T'.

Definition isMonadAlg (Xa : FAlg) : UU
  := η T (pr1 Xa) · pr2 Xa = identity _
     ×
     (#T')%cat (pr2 Xa) · pr2 Xa = μ T _ · pr2 Xa.

Definition disp_cat_monad_alg_over_functor_alg : disp_cat FAlg
  := disp_full_sub _ isMonadAlg.

Definition disp_cat_monad_alg : disp_cat C
  := sigma_disp_cat disp_cat_monad_alg_over_functor_alg.

End monad_algebras.

(** * Any category is a displayed category over unit *)

Require Import UniMath.CategoryTheory.categories.StandardCategories.

Section over_terminal_category.

Variable C : category.

Definition disp_over_unit_data : disp_cat_data unit_category.
Proof.
  use tpair.
  - use tpair.
    + intro. apply (ob C).
    + simpl. intros x y c c' e. apply (C ⟦c, c'⟧).
  - use tpair.
    + simpl. intros. apply identity.
    + intros ? ? ? ? ? a b c f g.
      apply (compose (C:=C) f g ).
Defined.

Definition disp_over_unit_axioms : disp_cat_axioms _ disp_over_unit_data.
Proof.
  repeat split; cbn; intros.
  - apply id_left.
  - etrans. apply id_right.
    apply pathsinv0. unfold mor_disp. cbn.
    apply (eqtohomot (transportf_const _ _)).
  - etrans. apply assoc.
    apply pathsinv0. unfold mor_disp. cbn.
    apply (eqtohomot (transportf_const _ _)).
  - apply homset_property.
Qed.

Definition disp_over_unit : disp_cat _ := _ ,, disp_over_unit_axioms.

End over_terminal_category.

Section cartesian_product_pb.

Variable C C' : category.

(* TODO: use a better name here (this one is baffling out of context) *)
Definition disp_cartesian : disp_cat C
  := reindex_disp_cat (functor_to_unit C) (disp_over_unit C').

Definition cartesian : category := total_category disp_cartesian.

End cartesian_product_pb.

Section arrow.

Variable C : category.

Definition disp_arrow_data : disp_cat_data (cartesian C C).
Proof.
  use tpair.
  - use tpair.
    + intro H.
      exact (pr1 H --> pr2 H).
    + cbn. intros xy ab f g h.
      exact (compose f (pr2 h) = compose (pr1 h) g ).
  - split; intros.
    + cbn.
      apply pathsinv0.
      etrans. apply id_left.
      cbn in xx.
      unfold mor_disp. cbn.
      etrans. eapply pathsinv0. apply id_right.
      apply maponpaths, pathsinv0.
      apply (eqtohomot (transportf_const _ _)).
    + cbn in *.
      unfold mor_disp. cbn.
      etrans. apply maponpaths, (eqtohomot (transportf_const _ _)).
      etrans. apply assoc.
      etrans. apply maponpaths_2. apply X.
      etrans. eapply pathsinv0, assoc.
      etrans. apply maponpaths. apply X0.
      apply assoc.
Defined.

Definition disp_arrow_axioms : disp_cat_axioms _ disp_arrow_data.
Proof.
  repeat split; intros;
    try apply homset_property.
  apply isasetaprop.
  apply homset_property.
Qed.

Definition disp_arrow : disp_cat (cartesian C C) := _ ,, disp_arrow_axioms.

Definition arrow : category := total_category disp_arrow.

Definition disp_domain : disp_cat C := sigma_disp_cat disp_arrow.

Definition total_domain := total_category disp_domain.

End arrow.

Section cartesian_product.

Variables C C' : category.

Definition disp_cartesian_ob_mor : disp_cat_ob_mor C.
Proof.
  use tpair.
  - exact (λ c, C').
  - cbn. intros x y x' y' f. exact (C'⟦x', y'⟧).
Defined.

Definition disp_cartesian_data : disp_cat_data C.
Proof.
  exists disp_cartesian_ob_mor.
  use tpair; cbn.
  - intros; apply identity.
  - intros ? ? ? ? ? ? ? ? f g. apply (f · g).
Defined.

Definition disp_cartesian_axioms : disp_cat_axioms _ disp_cartesian_data.
Proof.
  repeat split; intros; cbn.
  - etrans. apply id_left.
    apply pathsinv0.
    etrans. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)).
    apply idpath.
  - etrans. apply id_right.
    apply pathsinv0.
    etrans. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)).
    apply idpath.
  - etrans. apply assoc.
    apply pathsinv0.
    etrans. unfold mor_disp. cbn. apply (eqtohomot (transportf_const _ _)).
    apply idpath.
  - apply homset_property.
Qed.

Definition disp_cartesian' : disp_cat C := _ ,, disp_cartesian_axioms.

End cartesian_product.

(* *)


Require Import VST.msl.msl_direct.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.

Open Local Scope logic.

Lemma orp_derives {A} {ND : NatDed A}: forall P1 P2 Q1 Q2 : A,
  P1 |-- Q1 ->
  P2 |-- Q2 ->
  P1 || P2 |-- Q1 || Q2.
Proof.
  intros.
  apply orp_left.
  apply orp_right1. trivial.
  apply orp_right2. trivial.
Qed.

Lemma exp_derives {A} {ND : NatDed A} {B}: forall (P Q : B -> A),
  (forall b, P b |-- Q b) ->
  EX b : B, P b |-- EX b : B, Q b.
Proof.
  intros.
  apply exp_left. intro b.
  apply exp_right with b. trivial.
Qed.

Lemma FF_right {A} `{NatDed A}: forall P Q,
  P |-- FF ->
  P |-- Q.
Proof.
  intros.
  apply derives_trans with FF; auto.
  apply FF_left.
Qed.

(* NEGATIONS *)
Definition notp {A} `{NatDed A} : A -> A :=
  fun P => (P --> FF).
Notation " '!' P " := (notp P) (at level 30) : logic.

Lemma notp_derives {A} `{NatDed A}: forall P Q : A,
  P |-- Q ->
  !Q |-- !P.
Proof. intros. apply imp_derives; auto. Qed.

(* The following two lemmas are not stated in some kind of minimal form. *)
Lemma notp_left {A} `{NatDed A}: forall P Q,
  P && !P |-- Q.
Proof.
  intros.
  apply FF_right.
  apply modus_ponens.
Qed.

Lemma notp_right {A} `{NatDed A}: forall P Q,
  P && Q |-- FF ->
  P |-- !Q.
Proof.
  intros.
  unfold notp.
  rewrite <- imp_andp_adjoint. trivial.
Qed.

Lemma notp_TT {A} `{NatDed A}:
  !TT = FF.
Proof.
  apply pred_ext.
  rewrite <- (TT_andp (! TT)).
  apply modus_ponens.
  apply FF_left.
Qed.

Lemma notp_FF {A} `{NatDed A}:
  !FF = TT.
Proof.
  apply pred_ext.
  apply TT_right.
  apply notp_right.
  apply andp_left2. trivial.
Qed.

Lemma contradiction_FF {A} `{NatDed A}: forall P,
  P && !P = FF.
Proof.
  intro. apply pred_ext.
  apply modus_ponens.
  apply FF_left.
Qed.

Lemma notnot2 {A} `{NatDed A}: forall P : A,
  P |-- ! (! P).
Proof.
  intro.
  apply notp_right.
  apply notp_left.
Qed.

Lemma notnotnot {A} `{NatDed A}: forall P : A,
  ! (! (! P)) |-- !P.
Proof.
  intro.
  apply notp_right.
  eapply derives_trans.
  * apply andp_derives.
    apply derives_refl.
    apply notnot2.
  * rewrite andp_comm.
    apply notp_left.
Qed.

Lemma deMorgan_orp1 {A} `{NatDed A}: forall (P Q : A),
  !(P || Q) |-- (!P) && (!Q).
Proof.
  intros.
  apply andp_right; apply notp_derives.
  apply orp_right1; trivial.
  apply orp_right2; trivial.
Qed.

Lemma deMorgan_orp2 {A} `{NatDed A}: forall (P Q : A),
  (!P) && (!Q) |-- !(P || Q).
Proof.
  intros.
  apply notp_right.
  rewrite andp_comm.
  rewrite imp_andp_adjoint.
  apply orp_left.
  rewrite <- imp_andp_adjoint.
  rewrite <- andp_assoc.
  rewrite imp_andp_adjoint.
  apply notp_left.
  rewrite andp_comm.
  rewrite <- imp_andp_adjoint.
  rewrite <- andp_assoc.
  rewrite imp_andp_adjoint.
  apply notp_left.
Qed.

Lemma deMorgan_orp {A} `{NatDed A}: forall (P Q : A),
  !(P || Q) = (!P) && (!Q).
Proof. intros. apply pred_ext. apply deMorgan_orp1. apply deMorgan_orp2. Qed.

Lemma deMorgan_andp2 {A} `{NatDed A}: forall (P Q : A),
  (!P) || (!Q) |-- !(P && Q).
Proof.
  intros.
  apply orp_left; apply notp_derives.
  apply andp_left1; trivial.
  apply andp_left2; trivial.
Qed.

Lemma contrapositive2 {A} `{NatDed A}: forall (P Q : A),
  Q --> P |-- (!P) --> (!Q).
Proof.
  intros.
  rewrite <- imp_andp_adjoint.
  apply notp_right.
  rewrite andp_comm.
  rewrite <- andp_assoc.
  rewrite imp_andp_adjoint.
  eapply derives_trans.
  apply modus_ponens.
  rewrite <- imp_andp_adjoint.
  apply modus_ponens.
Qed.

Lemma deMorgan_exp1 {A} `{NatDed A} {B}: forall (P : B -> A),
  !(EX b : B, P b) |-- ALL b : B, !(P b).
Proof.
  intros.
  apply allp_right. intro x.
  apply notp_derives.
  apply exp_right with x. trivial.
Qed.

Lemma deMorgan_exp2 {A} `{NatDed A} {B}: forall (P : B -> A),
  ALL b : B, !(P b) |-- !(EX b : B, P b).
Proof.
  intros.
  apply notp_right.
  rewrite andp_comm.
  rewrite imp_andp_adjoint.
  apply exp_left. intro x.
  rewrite <- imp_andp_adjoint.
  rewrite andp_comm.
  rewrite imp_andp_adjoint.
  apply allp_left with x. trivial.
Qed.

Lemma deMorgan_exp {A} `{NatDed A} {B}: forall (P : B -> A),
  !(EX b : B, P b) = ALL b : B, !(P b).
Proof. intros. apply pred_ext. apply deMorgan_exp1. apply deMorgan_exp2. Qed.

Lemma deMorgan_allp2 {A} `{NatDed A} {B}: forall (P : B -> A),
  EX b : B, !(P b) |-- !(ALL b : B, P b).
Proof.
  intros.
  apply exp_left. intro x.
  apply notp_derives.
  apply allp_left with x. trivial.
Qed.

(* CLASSICAL *)
Class ClassicNatDed (A : Type) {ND : NatDed A} : Type :=
  LEM_right : forall P : A, TT |-- P || !P.

Lemma LEM_cases {A} `{ClassicNatDed A} : forall P Q R,
  P && Q |-- R ->
  (!P) && Q |-- R ->
  Q |-- R.
Proof.
  intros.
  rewrite <- (TT_andp Q).
  rewrite imp_andp_adjoint.
  eapply derives_trans. apply (LEM_right P).
  apply orp_left; rewrite <- imp_andp_adjoint; trivial.
Qed.

Lemma notnot1 {A} `{ClassicNatDed A} : forall (P : A),
  ! (!P) |-- P.
Proof.
  intro.
  apply (LEM_cases P).
  apply andp_left1. trivial.
  apply notp_left.
Qed.

Lemma notnot {A} `{ClassicNatDed A} : forall (P : A),
  ! (! P) = P.
Proof. intros. apply pred_ext. apply notnot1. apply notnot2. Qed.

Lemma PBC {A} `{ClassicNatDed A} : forall (P Q : A),
  P && (! Q) |-- FF ->
  P |-- Q.
Proof.
  intros.
  eapply derives_trans.
  apply notp_right. apply H0.
  apply notnot1.
Qed.

Lemma deMorgan_andp1 {A} `{ClassicNatDed A}: forall (P Q : A),
  ! (P && Q) |-- (! P) || (! Q).
Proof.
  intros.
  apply (LEM_cases Q).
  apply (LEM_cases P).
  rewrite <- andp_assoc. apply notp_left.
  apply orp_right1. apply andp_left1. trivial.
  apply orp_right2. apply andp_left1. trivial.
Qed.

Lemma deMorgan_andp {A} `{ClassicNatDed A}: forall (P Q : A),
  ! (P && Q) = (! P) || (! Q).
Proof. intros. apply pred_ext. apply deMorgan_andp1. apply deMorgan_andp2. Qed.

Lemma contrapositive1 {A} `{ClassicNatDed A}: forall (P Q : A),
  (!P) --> (!Q) |-- Q --> P.
Proof.
  intros.
  rewrite <- imp_andp_adjoint.
  apply (LEM_cases P).
  apply andp_left1. trivial.
  rewrite <- andp_assoc.
  rewrite imp_andp_adjoint.
  eapply derives_trans.
  apply modus_ponens.
  rewrite <- imp_andp_adjoint.
  rewrite andp_comm.
  apply notp_left.
Qed.

Lemma contrapositive {A} `{ClassicNatDed A}: forall (P Q : A),
  (!P) --> (!Q) = Q --> P.
Proof. intros. apply pred_ext. apply contrapositive1. apply contrapositive2. Qed.

Lemma deMorgan_allp1 {A} `{ClassicNatDed A} {B}: forall (P : B -> A),
  ! (ALL b : B, P b) |-- EX b : B, ! (P b).
Proof.
  intros.
  apply PBC.
  rewrite andp_comm. rewrite imp_andp_adjoint.
  pose proof (notnot (ALL b : B, P b)). unfold notp at 1 in H0. rewrite H0. clear H0.
  apply allp_right. intro x.
  apply PBC.
  rewrite andp_comm. rewrite imp_andp_adjoint.
  pose proof (notnot (EX b : B, notp (P b))). unfold notp at 1 in H0. rewrite H0. clear H0.
  apply exp_right with x. trivial.
Qed.

Lemma deMorgan_allp {A} `{ClassicNatDed A} {B}: forall (P : B -> A),
  ! (ALL b : B, P b) = EX b : B, ! (P b).
Proof. intros. apply pred_ext. apply deMorgan_allp1. apply deMorgan_allp2. Qed.


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

Require Import Arith Max Min BinInt BinNat Znat Nnat.

Local Open Scope Z_scope.

(** * zify: the Z-ification tactic *)

(* This tactic searches for nat and N and positive elements in the goal and
   translates everything into Z. It is meant as a pre-processor for
   (r)omega; for instance a positivity hypothesis is added whenever
     - a multiplication is encountered
     - an atom is encountered (that is a variable or an unknown construct)

   Recognized relations (can be handled as deeply as allowed by setoid rewrite):
     - { eq, le, lt, ge, gt } on { Z, positive, N, nat }

   Recognized operations:
     - on Z: Z.min, Z.max, Z.abs, Z.sgn are translated in term of <= < =
     - on nat: + * - S O pred min max Pos.to_nat N.to_nat Z.abs_nat
     - on positive: Zneg Zpos xI xO xH + * - Pos.succ Pos.pred Pos.min Pos.max Pos.of_succ_nat
     - on N: N0 Npos + * - N.pred N.succ N.min N.max N.of_nat Z.abs_N
*)

(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *)

Ltac zify_unop_core t thm a :=
 (* Let's introduce the specification theorem for t *)
 pose proof (thm a);
 (* Then we replace (t a) everywhere with a fresh variable *)
 let z := fresh "z" in set (z:=t a) in *; clearbody z.

Ltac zify_unop_var_or_term t thm a :=
 (* If a is a variable, no need for aliasing *)
 let za := fresh "z" in
 (rename a into za; rename za into a; zify_unop_core t thm a) ||
 (* Otherwise, a is a complex term: we alias it. *)
 (remember a as za; zify_unop_core t thm za).

Ltac zify_unop t thm a :=
 (* If a is a scalar, we can simply reduce the unop. *)
 (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *)
 let isz := isZcst a in
 match isz with
  | true =>
    let u := eval compute in (t a) in
    change (t a) with u in *
  | _ => zify_unop_var_or_term t thm a
 end.

Ltac zify_unop_nored t thm a :=
 (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *)
 let isz := isZcst a in
 match isz with
  | true => zify_unop_core t thm a
  | _ => zify_unop_var_or_term t thm a
 end.

Ltac zify_binop t thm a b:=
 (* works as zify_unop, except that we should be careful when
    dealing with b, since it can be equal to a *)
 let isza := isZcst a in
 match isza with
   | true => zify_unop (t a) (thm a) b
   | _ =>
       let za := fresh "z" in
       (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
       (remember a as za; match goal with
         | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
         | _ => zify_unop_nored (t za) (thm za) b
        end)
 end.

Ltac zify_op_1 :=
  match goal with
   | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b
   | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b
   | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b
   | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b
   | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a
   | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a
   | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a
   | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a
  end.

Ltac zify_op := repeat zify_op_1.

(** II) Conversion from nat to Z *)

Definition Z_of_nat' := Z.of_nat.

Ltac hide_Z_of_nat t :=
  let z := fresh "z" in set (z:=Z.of_nat t) in *;
  change Z.of_nat with Z_of_nat' in z;
  unfold z in *; clear z.

Ltac zify_nat_rel :=
 match goal with
  (* I: equalities *)
  | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *)
  | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H
  | |- context [ @eq nat ?a ?b ] =>       rewrite <- (Nat2Z.inj_iff a b)
  (* II: less than *)
  | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H
  | |- context [ lt ?a ?b ] =>       rewrite (Nat2Z.inj_lt a b)
  (* III: less or equal *)
  | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H
  | |- context [ le ?a ?b ] =>       rewrite (Nat2Z.inj_le a b)
  (* IV: greater than *)
  | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H
  | |- context [ gt ?a ?b ] =>       rewrite (Nat2Z.inj_gt a b)
  (* V: greater or equal *)
  | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H
  | |- context [ ge ?a ?b ] =>       rewrite (Nat2Z.inj_ge a b)
 end.

Ltac zify_nat_op :=
 match goal with
  (* misc type conversions: positive/N/Z to nat *)
  | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H
  | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a)
  | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H
  | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a)
  | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H
  | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a)

  (* plus -> Z.add *)
  | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H
  | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b)

  (* min -> Z.min *)
  | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H
  | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b)

  (* max -> Z.max *)
  | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H
  | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b)

  (* minus -> Z.max (Z.sub ... ...) 0 *)
  | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H
  | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b)

  (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *)
  | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
  | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a)

  (* mult -> Z.mul and a positivity hypothesis *)
  | H : context [ Z.of_nat (mult ?a ?b) ] |- _ =>
        pose proof (Nat2Z.is_nonneg (mult a b));
        rewrite (Nat2Z.inj_mul a b) in *
  | |- context [ Z.of_nat (mult ?a ?b) ] =>
        pose proof (Nat2Z.is_nonneg (mult a b));
        rewrite (Nat2Z.inj_mul a b) in *

  (* O -> Z0 *)
  | H : context [ Z.of_nat O ] |- _ => change (Z.of_nat O) with Z0 in H
  | |- context [ Z.of_nat O ] => change (Z.of_nat O) with Z0

  (* S -> number or Z.succ *)
  | H : context [ Z.of_nat (S ?a) ] |- _ =>
     let isnat := isnatcst a in
     match isnat with
      | true =>
        let t := eval compute in (Z.of_nat (S a)) in
        change (Z.of_nat (S a)) with t in H
      | _ => rewrite (Nat2Z.inj_succ a) in H
      | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]),
                hide [Z.of_nat (S a)] in this one hypothesis *)
        change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H
     end
  | |- context [ Z.of_nat (S ?a) ] =>
     let isnat := isnatcst a in
     match isnat with
      | true =>
        let t := eval compute in (Z.of_nat (S a)) in
        change (Z.of_nat (S a)) with t
      | _ => rewrite (Nat2Z.inj_succ a)
      | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]),
                hide [Z.of_nat (S a)] in the goal *)
        change (Z.of_nat (S a)) with (Z_of_nat' (S a))
     end

  (* atoms of type nat : we add a positivity condition (if not already there) *)
  | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a
  | _ : context [ Z.of_nat ?a ] |- _ =>
    pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a
  | |- context [ Z.of_nat ?a ] =>
    pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a
 end.

Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.

(* III) conversion from positive to Z *)

Definition Zpos' := Zpos.
Definition Zneg' := Zneg.

Ltac hide_Zpos t :=
  let z := fresh "z" in set (z:=Zpos t) in *;
  change Zpos with Zpos' in z;
  unfold z in *; clear z.

Ltac zify_positive_rel :=
 match goal with
  (* I: equalities *)
  | |- (@eq positive ?a ?b) => apply Pos2Z.inj
  | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H
  | |- context [ @eq positive ?a ?b ] =>       rewrite <- (Pos2Z.inj_iff a b)
  (* II: less than *)
  | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
  | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
  (* III: less or equal *)
  | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
  | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
  (* IV: greater than *)
  | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
  | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
  (* V: greater or equal *)
  | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
  | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
 end.

Ltac zify_positive_op :=
 match goal with
  (* Zneg -> -Zpos (except for numbers) *)
  | H : context [ Zneg ?a ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zneg a) with (Zneg' a) in H
      | _ => change (Zneg a) with (- Zpos a) in H
     end
  | |- context [ Zneg ?a ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zneg a) with (Zneg' a)
      | _ => change (Zneg a) with (- Zpos a)
     end

  (* misc type conversions: nat to positive *)
  | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
  | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)

  (* Pos.add -> Z.add *)
  | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H
  | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b)

  (* Pos.min -> Z.min *)
  | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H
  | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b)

  (* Pos.max -> Z.max *)
  | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H
  | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b)

  (* Pos.sub -> Z.max 1 (Z.sub ... ...) *)
  | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub_max a b) in H
  | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub_max a b)

  (* Pos.succ -> Z.succ *)
  | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H
  | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a)

  (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *)
  | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H
  | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a)

  (* Pos.mul -> Z.mul and a positivity hypothesis *)
  | H : context [ Zpos (?a * ?b) ] |- _ =>
        pose proof (Pos2Z.is_pos (Pos.mul a b));
        change (Zpos (a*b)) with (Zpos a * Zpos b) in *
  | |- context [ Zpos (?a * ?b) ] =>
        pose proof (Pos2Z.is_pos (Pos.mul a b));
        change (Zpos (a*b)) with (Zpos a * Zpos b) in *

  (* xO *)
  | H : context [ Zpos (xO ?a) ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
      | _ => rewrite (Pos2Z.inj_xO a) in H
     end
  | |- context [ Zpos (xO ?a) ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xO a)) with (Zpos' (xO a))
      | _ => rewrite (Pos2Z.inj_xO a)
     end
  (* xI *)
  | H : context [ Zpos (xI ?a) ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
      | _ => rewrite (Pos2Z.inj_xI a) in H
     end
  | |- context [ Zpos (xI ?a) ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xI a)) with (Zpos' (xI a))
      | _ => rewrite (Pos2Z.inj_xI a)
     end

  (* xI : nothing to do, just prevent adding a useless positivity condition *)
  | H : context [ Zpos xH ] |- _ => hide_Zpos xH
  | |- context [ Zpos xH ] => hide_Zpos xH

  (* atoms of type positive : we add a positivity condition (if not already there) *)
  | _ : 0 < Zpos ?a |- _ => hide_Zpos a
  | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a
  | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a
 end.

Ltac zify_positive :=
 repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.

(* IV) conversion from N to Z *)

Definition Z_of_N' := Z.of_N.

Ltac hide_Z_of_N t :=
  let z := fresh "z" in set (z:=Z.of_N t) in *;
  change Z.of_N with Z_of_N' in z;
  unfold z in *; clear z.

Ltac zify_N_rel :=
 match goal with
  (* I: equalities *)
  | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *)
  | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H
  | |- context [ @eq N ?a ?b ] =>       rewrite <- (N2Z.inj_iff a b)
  (* II: less than *)
  | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H
  | |- context [ (?a < ?b)%N ] =>       rewrite (N2Z.inj_lt a b)
  (* III: less or equal *)
  | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H
  | |- context [ (?a <= ?b)%N ] =>       rewrite (N2Z.inj_le a b)
  (* IV: greater than *)
  | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H
  | |- context [ (?a > ?b)%N ] =>       rewrite (N2Z.inj_gt a b)
  (* V: greater or equal *)
  | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H
  | |- context [ (?a >= ?b)%N ] =>       rewrite (N2Z.inj_ge a b)
 end.

Ltac zify_N_op :=
 match goal with
  (* misc type conversions: nat to positive *)
  | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H
  | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a)
  | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H
  | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a)
  | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H
  | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a)
  | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H
  | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0

  (* N.add -> Z.add *)
  | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H
  | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b)

  (* N.min -> Z.min *)
  | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H
  | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b)

  (* N.max -> Z.max *)
  | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H
  | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b)

  (* N.sub -> Z.max 0 (Z.sub ... ...) *)
  | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H
  | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b)

  (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *)
  | H : context [ Z.of_N (N.pred ?a) ] |- _ => rewrite (N.pred_sub a) in H
  | |- context [ Z.of_N (N.pred ?a) ] => rewrite (N.pred_sub a)

  (* N.succ -> Z.succ *)
  | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H
  | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a)

  (* N.mul -> Z.mul and a positivity hypothesis *)
  | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ =>
        pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in *
  | |- context [ Z.of_N  (N.mul ?a ?b) ] =>
        pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in *

  (* atoms of type N : we add a positivity condition (if not already there) *)
  | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a
  | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a
  | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a
 end.

Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.

(** The complete Z-ification tactic *)

Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op.


From Undecidability Require Import L.Prelim.MoreBase.

Require Import smpl.Smpl.
Require Export Lia Arith Ring.

From Coq Require Import Setoid.
From Coq Require Import CRelationClasses CMorphisms.
Import CMorphisms.ProperNotations.
From Undecidability.Shared.Libs.PSL Require FinTypes.

Record leUpToC {X} (f g : X -> nat) : Type :=
  { c__leUpToC : nat;
    correct__leUpToC : forall x, f x <= c__leUpToC * g x
  }.

Arguments c__leUpToC {_ _ _ H} : rename.

Notation "f <=c g" := (@leUpToC _ f g) (at level 70, g at next level).

Instance leUpToC_preorder X: PreOrder (@leUpToC X).
Proof.
  split.
  -exists 1. intros. lia.
  -hnf. intros ? ? ? [c Hc] [c' Hc']. exists (c*c'). intros. rewrite Hc,Hc'. nia.
Qed.

Instance leUpToC_proper_eq X: Proper (Morphisms.pointwise_relation X eq ==> Morphisms.pointwise_relation X eq ==> arrow) (@leUpToC X).
Proof.
  intros ? ? H ? ? H0 H1. cbv - [iff] in *. destruct H1. eexists. intro. rewrite <-H, <- H0. easy.
Qed.

Instance leUpToC_proper_eq_flip X: Proper (Morphisms.pointwise_relation X eq ==> Morphisms.pointwise_relation X eq ==> flip arrow) (@leUpToC X).
Proof.
  intros ? ? H ? ? H0 H1. cbv - [iff] in *. destruct H1. eexists. intro. rewrite H, H0. easy.
Qed.

Instance le_leUpToC_subrelation X: subrelation (pointwise_relation X le) leUpToC.
Proof.
  intros ? ? H. exists 1. intros. hnf in H. setoid_rewrite H. nia.
Qed.

Instance eq_leUpToC_subrelation X: subrelation (pointwise_relation X eq) leUpToC.
Proof.
  intros ? ? H. exists 1. hnf in H. setoid_rewrite H. intros;nia.
Qed.

(* A record for easily expressing the subtype of functions up to some multiplicative constant. *)
Record UpToC {X} (F : X -> nat) : Type :=
  mkUpToC
  {
    f__UpToC :> X -> nat;
    correct__UpToC :> f__UpToC <=c F
  }.

Add Printing Coercion f__UpToC.
Arguments f__UpToC : clear implicits.
Arguments f__UpToC {_} _ {_}.

Lemma UpToC_le X F (f : @UpToC X F) :
  (forall x, f x <= (c__leUpToC (H:=f))*F x).
  destruct f as [? []];cbn. easy.
Qed.

Lemma upToC_add X (F f1 f2 :X->nat) :
  f1 <=c F
  -> f2 <=c F
  -> (fun x => f1 x + f2 x) <=c F.
Proof.
  intros [c H] [c' H'].
  exists (c+c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_max X (F f1 f2 :X->nat) :
  f1 <=c F
  -> f2 <=c F
  -> (fun x => max (f1 x) (f2 x)) <=c F.
Proof.
  intros [c H] [c' H'].
  exists (c+c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_min X (F f1 f2 :X->nat) :
  f1 <=c F
  -> f2 <=c F
  -> (fun x => min (f1 x) (f2 x)) <=c F.
Proof.
  intros [c H] [c' H'].
  exists (c+c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_mul_c_l X c (f F : X -> nat):
  f <=c F -> (fun x => c * f x) <=c F.
Proof.
  intros (c'&H). exists (c'*c). intros. rewrite H. nia.
Qed.

Lemma upToC_mul_c_r X c (f F : X -> nat):
  f <=c F -> (fun x => f x * c) <=c F.
Proof.
  intros (c'&H). exists (c'*c). intros. rewrite H. nia.
Qed.

Lemma upToC_c X c (F : X -> nat):
  (fun _ => 1) <=c F ->
  (fun _ => c ) <=c F.
Proof.
  intros H'.
  assert (H:c<= 1*c) by lia.
  setoid_rewrite H. eapply upToC_mul_c_r. easy.
Qed.

Lemma upToC_S X (F f :X->nat) :
  (fun _ => 1) <=c F
  -> f <=c F
  -> (fun x => S (f x)) <=c F.
Proof.
  intros. apply upToC_add with (f1:=(fun _ => 1)). 2:easy. now apply upToC_c.
Qed.

Lemma upToC_mul X (F1 F2 f1 f2 :X->nat) :
  f1 <=c F1
  -> f2 <=c F2
  -> (fun x => f1 x * f2 x) <=c (fun x => F1 x * F2 x).
Proof.
  intros [c H] [c' H'].
  exists (c*c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_pow_r_drop X c (f F : X -> nat):
  0 < c -> f <=c F -> f <=c (fun x => F x ^ c).
Proof.
  intros ? (c'&Hc'). exists c'. intros x. decide (F x = 0) as [H'|H'].
  { rewrite Hc',H'. nia. }
  rewrite <- (Nat.pow_le_mono_r) with (b:=1). 2,3:nia. cbn. rewrite Hc'. nia.
Qed.

Lemma upToC_pow_le_compat X c c' (f f' : X -> nat):
  0 < c -> c <= c' -> f <=c f' -> (fun x => f x ^ c)<=c (fun x => f' x ^ c').
Proof.
  intros ? ? (c''&Hc'). exists (c''^c). intros x. decide (f' x = 0) as [H'|H'].
  { rewrite Hc',H'. rewrite Nat.mul_0_r. destruct c; cbn;nia. }
  { setoid_rewrite <- (Nat.pow_le_mono_r) with (b:=c). 2,3:nia.
    rewrite Hc'. rewrite Nat.pow_mul_l. nia.
  }
Qed.

Tactic Notation  "_applyIfNotConst_nat" tactic(t):=
  once (match goal with
        | |- ?R (fun x => ?c) _ =>  tryif let b := isnatcst c in unify b true then fail 1 else t
        end).

Lemma upToC_le X f (F : X -> nat):
  (forall x, f x <= F x)
  -> f <=c F.
Proof.
  intros H'. change f with (fun x => f x). setoid_rewrite H'. reflexivity.
Qed.

Lemma upToC_f__UpToC X (F G: X -> nat) (H : UpToC G):
  G <=c F
  -> H <=c F.
Proof.
  now rewrite correct__UpToC.
Qed.

Smpl Create upToC.

Smpl Add 2 assumption : upToC.
Smpl Add 5 first [simple apply upToC_add | simple apply upToC_mul_c_l | simple apply upToC_mul_c_r
                  | simple apply upToC_max | simple apply upToC_min
                  | progress (simple apply upToC_c)
                 | _applyIfNotConst_nat (simple apply upToC_S)] : upToC.
Smpl Add 4 simple eapply upToC_f__UpToC : upToC.

Ltac smpl_upToC := repeat smpl upToC.

Ltac upToC_le_solve := apply upToC_le;intros ?;nia.

Smpl Create upToC_solve.
Smpl Add upToC_le_solve : upToC_solve.

Ltac smpl_upToC_solve := solve [repeat (smpl upToC);repeat (smpl upToC_solve)].

Tactic Notation "exists_UpToC" uconstr(f) :=
  unshelve (eexists (mkUpToC (f__UpToC:=f) _));cycle 1;[unfold f__UpToC| ].

Tactic Notation "eexists_UpToC" ident(f) :=
        match goal with
          |- ?Ex (@UpToC ?X ?F) ?P =>
          evar (f : X -> nat);exists_UpToC f
        end.

Goal (fun x => S x) <=c (fun x => x + 1).
Proof.
  timeout 3 (smpl_upToC_solve). (* If this times out, most likely the upToC_S hint is applied wrongly. *)
Qed.

(* Tests *)
Goal ( { f : UpToC (fun x => x + 1) | forall x, 3 * x + 10 <= f x}).
Proof.
  eexists_UpToC f.
  - [f]:intros x. unfold f. reflexivity.
  - unfold f. smpl_upToC_solve.
Qed.

From Coq Require Strings.String.

Section bla.
  Import FinTypes.
  Lemma leUpToC_finCases X (Y:finType) Z__case (cases : forall (y:Y), Z__case y -> X) (f F : X -> nat) :
  (forall x, exists y (z : Z__case y), cases y z = x)
  -> (forall y, (fun z => f (cases y z)) <=c (fun z => F (cases y z)))
  -> f <=c F.
Proof.
  intros Hinj Hcase. exists (maxl (map (fun y => c__leUpToC (H:=Hcase y)) (elem Y))).
  intros x. specialize (Hinj x) as (y&z&<-).
  specialize @correct__leUpToC with (l:=Hcase y) as H'.
  erewrite <- maxl_leq. now apply H'.
  rewrite in_map_iff. do 2 eexists. easy. apply elem_spec.
Qed.
End bla.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal7.

Set Printing Depth 1000.
Definition lfind_eval  x:=
len x.

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Nil).


From Categories.Essentials Require Import Notations Facts_Tactics.
From Coq.Logic Require Import ChoiceFacts ClassicalFacts.

From Coq.Classes Require Import RelationClasses.

Local Axiom PropExt : ClassicalFacts.prop_extensionality.
Local Axiom ConstructiveIndefiniteDescription_Type :
  forall T : Type, ConstructiveIndefiniteDescription_on T.

Record EquiRel A :=
  { EQR_rel :> A → A → Prop;
    EQR_EQ : Equivalence EQR_rel }.

Existing Instances EQR_EQ.

Section Quotient.
  Context {A : Type} (R : EquiRel A).

  Definition quotient : Type := {P : A → Prop | ∃ x, ∀ y, P y ↔ R x y }.

  Definition represents (c : quotient) (x : A) : Prop := proj1_sig c x.

  Lemma represented_rel c x y :
    represents c x → represents c y → R x y.
  Proof.
    intros Hx Hy.
    pose proof (proj2_sig c) as [z Hz].
    transitivity z; [symmetry|]; apply Hz; trivial.
  Qed.

  Lemma related_represented c x y :
    represents c x → R x y → represents c y.
  Proof.
    intros Hx Hxy.
    pose proof (proj2_sig c) as [z Hz].
    apply Hz.
    transitivity x; [|trivial].
    apply Hz; trivial.
  Qed.

  Lemma quotient_has_representative c : ∃ x, represents c x.
  Proof.
    destruct c as [P [y Hy]].
    exists y; apply Hy; reflexivity.
  Qed.

  Lemma uniquely_represented c c' x y :
    represents c x → represents c' y → R x y → c = c'.
  Proof.
    intros Hcx Hc'y Hxy.
    apply sig_proof_irrelevance.
    extensionality z.
    apply PropExt.
    pose proof (proj2_sig c) as [u Hu].
    pose proof (proj2_sig c') as [w Hw].
    split.
    - intros Hc%Hu; apply Hw.
      etransitivity; [|apply Hc].
      etransitivity; [apply (Hw y); trivial|].
      symmetry; etransitivity; [apply (Hu x); trivial|trivial].
    - intros Hc'%Hw; apply Hu.
      etransitivity; [|apply Hc'].
      etransitivity; [apply (Hu x); trivial|].
      symmetry; etransitivity; [apply (Hw y); trivial|symmetry; trivial].
  Qed.

  Definition representative (c : quotient) : A :=
    proj1_sig
      (ConstructiveIndefiniteDescription_Type
         _ _ (quotient_has_representative c)).

  Lemma representative_represented c : represents c (representative c).
  Proof.
    exact (proj2_sig (ConstructiveIndefiniteDescription_Type
                        _ _ (quotient_has_representative c))).
  Qed.

  Definition class_of (x : A) : quotient :=
    exist _ (λ y, R x y) (ex_intro _ x (λ z, (conj (@id (R x z)) (@id (R x z))))).

  Lemma class_of_represents x : represents (class_of x) x.
  Proof. unfold represents; simpl; reflexivity. Qed.

  Lemma representative_of_class_of x : R (representative (class_of x)) x.
  Proof.
    eapply represented_rel; [apply representative_represented|].
    apply class_of_represents.
  Qed.

  Lemma class_of_inj x y : R x y → class_of x = class_of y.
  Proof.
    intros Hxy.
    apply (uniquely_represented _ _ x y);
      [apply class_of_represents|apply class_of_represents |trivial].
  Qed.

  Lemma equal_classes x y : class_of x = class_of y → R x y.
  Proof.
    intros Hxy.
    apply (represented_rel (class_of x));
      [|rewrite Hxy]; apply class_of_represents.
  Qed.

  Lemma class_of_representative c : class_of (representative c) = c.
  Proof.
    apply (uniquely_represented _ _ (representative c) (representative c));
      [| |reflexivity].
    - apply class_of_represents.
    - apply representative_represented.
  Qed.

End Quotient.

Arguments represents {_ _} _ _.
Arguments representative {_ _} _.