(** Well-founded order on products of [nat] *)

From Coq Require Import Relation_Operators Lexicographic_Product Lia.
From Coq Require Export Wf_nat.

Set Implicit Arguments.

(** * Well founded order on pairs of [nat] *)

Definition lt_nat_nat := slexprod _ _ lt lt.
Definition wf_nat_nat := wf_slexprod _ _ _ _ lt_wf lt_wf.

Ltac lt_nat_nat_solve :=
  match goal with
  | |- lt_nat_nat _ _ => try (left; cbn; lia);
                         try (right; cbn; lia);
                         fail
  | |- slexprod _ _ lt lt _ _ => try (left; cbn; lia);
                                 try (right; cbn; lia);
                                 fail
  end.

(** * Well founded order on triples of [nat] *)

Definition lt_nat_nat_nat := slexprod _ _ lt lt_nat_nat.
Definition wf_nat_nat_nat := wf_slexprod _ _ _ _ lt_wf wf_nat_nat.

Ltac lt_nat_nat_nat_solve :=
  match goal with
  | |- lt_nat_nat_nat _ _ =>
    try (left; cbn; lia);
    try (right; left; cbn; lia);
    try (right; right; cbn; lia);
    fail
  | |- slexprod _ _ lt lt_nat_nat _ _ =>
    try (left; cbn; lia);
    try (right; left; cbn; lia);
    try (right; right; cbn; lia);
    fail
  | |- slexprod _ _ lt (slexprod _ _ lt lt) _ _ =>
    try (left; cbn; lia);
    try (right; left; cbn; lia);
    try (right; right; cbn; lia);
    fail
  end.


From Hammer Require Import Hammer.

Section PredExt_RelChoice_imp_EM.

Definition PredicateExtensionality :=
forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.

Require Import ClassicalFacts.

Variable pred_extensionality : PredicateExtensionality.

Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
Proof. hammer_hook "Diaconescu" "Diaconescu.prop_ext".
intros A B H.
change ((fun _ => A) true = (fun _ => B) true).
rewrite
pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
reflexivity.
intros _; exact H.
Qed.

Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
Proof. hammer_hook "Diaconescu" "Diaconescu.proof_irrel".
apply (ext_prop_dep_proof_irrel_cic prop_ext).
Qed.

Require Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Lemma guarded_rel_choice : GuardedRelationalChoice.
Proof. hammer_hook "Diaconescu" "Diaconescu.guarded_rel_choice".
apply
(rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
Qed.

Require Import Bool.

Lemma AC_bool_subset_to_bool :
exists R : (bool -> Prop) -> bool -> Prop,
(forall P:bool -> Prop,
(exists b : bool, P b) ->
exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
Proof. hammer_hook "Diaconescu" "Diaconescu.AC_bool_subset_to_bool".
destruct (guarded_rel_choice _ _
(fun Q:bool -> Prop =>  exists y : _, Q y)
(fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
exact (fun _ H => H).
exists R; intros P HP.
destruct (HR P HP) as (y,(Hy,Huni)).
exists y; firstorder.
Qed.

Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
Proof. hammer_hook "Diaconescu" "Diaconescu.pred_ext_and_rel_choice_imp_EM".
intro P.

destruct AC_bool_subset_to_bool as [R H].

set (class_of_true := fun b => b = true \/ P).
set (class_of_false := fun b => b = false \/ P).

destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
exists true; left; reflexivity.
destruct H0.

destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
exists false; left; reflexivity.
destruct H1.

right.
intro HP.
assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
intro b; split.
unfold class_of_false; right; assumption.
unfold class_of_true; right; assumption.
assert (Heq : class_of_true = class_of_false).
apply pred_extensionality with (1 := Hequiv).
apply diff_true_false.
rewrite <- H0.
rewrite <- H1.
rewrite <- H0''. reflexivity.
rewrite Heq.
assumption.

left; assumption.
left; assumption.

Qed.

End PredExt_RelChoice_imp_EM.

Section ProofIrrel_RelChoice_imp_EqEM.

Variable rel_choice : RelationalChoice.

Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.

Variable A :Type.
Variables a1 a2 : A.

Definition A' := @sigT A (fun x => x=a1 \/ x=a2).

Definition a1':A'.
exists a1 ; auto.
Defined.

Definition a2':A'.
exists a2 ; auto.
Defined.

Lemma projT1_injective : a1=a2 -> a1'=a2'.
Proof. hammer_hook "Diaconescu" "Diaconescu.projT1_injective".
intro Heq ; unfold a1', a2', A'.
rewrite Heq.
replace (or_introl (a2=a2) (eq_refl a2))
with (or_intror (a2=a2) (eq_refl a2)).
reflexivity.
apply proof_irrelevance.
Qed.

Lemma decide : forall x:A', exists y:bool ,
(projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
Proof. hammer_hook "Diaconescu" "Diaconescu.decide".
intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
Qed.

Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
Proof. hammer_hook "Diaconescu" "Diaconescu.proof_irrel_rel_choice_imp_eq_dec".
destruct
(rel_choice A' bool
(fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
as (R,(HRsub,HR)).
apply decide.
destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
left; symmetry; assumption.
right; intro H.
subst b1; subst b2.
rewrite (projT1_injective H) in Ha1'b1.
assert (false = true) by auto using Huni2.
discriminate.
left; assumption.
Qed.

Declare Implicit Tactic auto.

Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
Proof. hammer_hook "Diaconescu" "Diaconescu.proof_irrel_rel_choice_imp_eq_dec'".
assert (decide: forall x:A, x=a1 \/ x=a2 ->
exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
intros a [Ha1|Ha2]; [exists true | exists false]; auto.
assert (guarded_rel_choice :=
rel_choice_and_proof_irrel_imp_guarded_rel_choice
rel_choice
proof_irrelevance).
destruct
(guarded_rel_choice A bool
(fun x => x=a1 \/ x=a2)
(fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
as (R,(HRsub,HR)).
apply decide.
destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
left; symmetry; assumption.
right; intro H.
subst b1; subst b2; subst a1.
assert (false = true) by auto using Huni2, Ha1b1.
discriminate.
left; assumption.
Qed.

End ProofIrrel_RelChoice_imp_EqEM.

Local Notation inhabited A := A (only parsing).

Section ExtensionalEpsilon_imp_EM.

Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.

Hypothesis epsilon_spec :
forall (A:Type) (i:inhabited A) (P:A->Prop),
(exists x, P x) -> P (epsilon A i P).

Hypothesis epsilon_extensionality :
forall (A:Type) (i:inhabited A) (P Q:A->Prop),
(forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.

Local Notation eps := (epsilon bool true) (only parsing).

Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
Proof. hammer_hook "Diaconescu" "Diaconescu.extensional_epsilon_imp_EM".
intro P.
pose (B := fun y => y=false \/ P).
pose (C := fun y => y=true  \/ P).
assert (B (eps B)) as [Hfalse|HP]
by (apply epsilon_spec; exists false; left; reflexivity).
assert (C (eps C)) as [Htrue|HP]
by (apply epsilon_spec; exists true; left; reflexivity).
right; intro HP.
assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
rewrite epsilon_extensionality with (1:=H) in Hfalse.
rewrite Htrue in Hfalse.
discriminate.
auto.
auto.
Qed.

End ExtensionalEpsilon_imp_EM.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e452m3_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__8__2.
Require Export lemma__8__7.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__collinearright.
Require Export lemma__congruenceflip.
Require Export lemma__doublereverse.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__ray4.
Require Export lemma__sameside2.
Require Export lemma__samesidereflexive.
Require Export lemma__samesidesymmetric.
Require Export logic.
Require Export proposition__10.
Require Export proposition__12.
Definition lemma__notperp : forall A B C P, (euclidean__axioms.BetS A C B) -> ((euclidean__axioms.nCol A B P) -> (exists X, (euclidean__axioms.nCol A B X) /\ ((euclidean__defs.OS X P A B) /\ (~(euclidean__defs.Per A C X))))).
Proof.
intro A.
intro B.
intro C.
intro P.
intro H.
intro H0.
assert (* Cut *) (euclidean__axioms.neq C B) as H1.
- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq A C) /\ (euclidean__axioms.neq A B))) as H1.
-- apply (@lemma__betweennotequal.lemma__betweennotequal A C B H).
-- destruct H1 as [H2 H3].
destruct H3 as [H4 H5].
exact H2.
- assert (* Cut *) (euclidean__axioms.neq B C) as H2.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C B H1).
-- assert (* Cut *) (~(C = P)) as H3.
--- intro H3.
assert (* Cut *) (euclidean__axioms.nCol A B C) as H4.
---- apply (@eq__ind__r euclidean__axioms.Point P (fun C0 => (euclidean__axioms.BetS A C0 B) -> ((euclidean__axioms.neq C0 B) -> ((euclidean__axioms.neq B C0) -> (euclidean__axioms.nCol A B C0))))) with (x := C).
-----intro H4.
intro H5.
intro H6.
exact H0.

----- exact H3.
----- exact H.
----- exact H1.
----- exact H2.
---- assert (* Cut *) (euclidean__axioms.Col A C B) as H5.
----- right.
right.
right.
right.
left.
exact H.
----- assert (* Cut *) (euclidean__axioms.Col A B C) as H6.
------ assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H6.
------- apply (@lemma__collinearorder.lemma__collinearorder A C B H5).
------- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H13.
------ apply (@euclidean__tactics.Col__nCol__False A B C H4 H6).
--- assert (* Cut *) (exists Q, (euclidean__axioms.BetS B C Q) /\ (euclidean__axioms.Cong C Q C P)) as H4.
---- apply (@lemma__extension.lemma__extension B C C P H2 H3).
---- destruct H4 as [Q H5].
destruct H5 as [H6 H7].
assert (* Cut *) (~(P = Q)) as H8.
----- intro H8.
assert (* Cut *) (euclidean__axioms.Col B C Q) as H9.
------ right.
right.
right.
right.
left.
exact H6.
------ assert (* Cut *) (euclidean__axioms.Col B C P) as H10.
------- apply (@eq__ind__r euclidean__axioms.Point Q (fun P0 => (euclidean__axioms.nCol A B P0) -> ((~(C = P0)) -> ((euclidean__axioms.Cong C Q C P0) -> (euclidean__axioms.Col B C P0))))) with (x := P).
--------intro H10.
intro H11.
intro H12.
exact H9.

-------- exact H8.
-------- exact H0.
-------- exact H3.
-------- exact H7.
------- assert (* Cut *) (euclidean__axioms.Col A C B) as H11.
-------- right.
right.
right.
right.
left.
exact H.
-------- assert (* Cut *) (euclidean__axioms.Col C B A) as H12.
--------- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H12.
---------- apply (@lemma__collinearorder.lemma__collinearorder A C B H11).
---------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H15.
--------- assert (* Cut *) (euclidean__axioms.Col C B P) as H13.
---------- assert (* Cut *) ((euclidean__axioms.Col C B P) /\ ((euclidean__axioms.Col C P B) /\ ((euclidean__axioms.Col P B C) /\ ((euclidean__axioms.Col B P C) /\ (euclidean__axioms.Col P C B))))) as H13.
----------- apply (@lemma__collinearorder.lemma__collinearorder B C P H10).
----------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H14.
---------- assert (* Cut *) (euclidean__axioms.Col B A P) as H14.
----------- apply (@euclidean__tactics.not__nCol__Col B A P).
------------intro H14.
apply (@euclidean__tactics.Col__nCol__False B A P H14).
-------------apply (@lemma__collinear4.lemma__collinear4 C B A P H12 H13 H1).

----------- assert (* Cut *) (euclidean__axioms.Col A B P) as H15.
------------ assert (* Cut *) ((euclidean__axioms.Col A B P) /\ ((euclidean__axioms.Col A P B) /\ ((euclidean__axioms.Col P B A) /\ ((euclidean__axioms.Col B P A) /\ (euclidean__axioms.Col P A B))))) as H15.
------------- apply (@lemma__collinearorder.lemma__collinearorder B A P H14).
------------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H16.
------------ apply (@euclidean__tactics.Col__nCol__False A B P H0 H15).
----- assert (* Cut *) (exists M, (euclidean__axioms.BetS P M Q) /\ (euclidean__axioms.Cong M P M Q)) as H9.
------ apply (@proposition__10.proposition__10 P Q H8).
------ destruct H9 as [M H10].
destruct H10 as [H11 H12].
assert (* Cut *) (euclidean__axioms.Col A C B) as H13.
------- right.
right.
right.
right.
left.
exact H.
------- assert (* Cut *) (euclidean__axioms.Col C B A) as H14.
-------- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H14.
--------- apply (@lemma__collinearorder.lemma__collinearorder A C B H13).
--------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H17.
-------- assert (* Cut *) (euclidean__axioms.neq C B) as H15.
--------- assert (* Cut *) ((euclidean__axioms.neq M Q) /\ ((euclidean__axioms.neq P M) /\ (euclidean__axioms.neq P Q))) as H15.
---------- apply (@lemma__betweennotequal.lemma__betweennotequal P M Q H11).
---------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H1.
--------- assert (* Cut *) (euclidean__axioms.Col C B Q) as H16.
---------- right.
right.
right.
left.
exact H6.
---------- assert (* Cut *) (euclidean__axioms.Col B A Q) as H17.
----------- apply (@euclidean__tactics.not__nCol__Col B A Q).
------------intro H17.
apply (@euclidean__tactics.Col__nCol__False B A Q H17).
-------------apply (@lemma__collinear4.lemma__collinear4 C B A Q H14 H16 H15).

----------- assert (* Cut *) (euclidean__axioms.Col A B Q) as H18.
------------ assert (* Cut *) ((euclidean__axioms.Col A B Q) /\ ((euclidean__axioms.Col A Q B) /\ ((euclidean__axioms.Col Q B A) /\ ((euclidean__axioms.Col B Q A) /\ (euclidean__axioms.Col Q A B))))) as H18.
------------- apply (@lemma__collinearorder.lemma__collinearorder B A Q H17).
------------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H19.
------------ assert (* Cut *) (euclidean__axioms.neq A B) as H19.
------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq A C) /\ (euclidean__axioms.neq A B))) as H19.
-------------- apply (@lemma__betweennotequal.lemma__betweennotequal A C B H).
-------------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H23.
------------- assert (* Cut *) (euclidean__defs.OS P P A B) as H20.
-------------- apply (@lemma__samesidereflexive.lemma__samesidereflexive A B P H0).
-------------- assert (* Cut *) (euclidean__axioms.neq Q P) as H21.
--------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric P Q H8).
--------------- assert (* Cut *) (euclidean__axioms.BetS Q M P) as H22.
---------------- apply (@euclidean__axioms.axiom__betweennesssymmetry P M Q H11).
---------------- assert (* Cut *) (euclidean__defs.Out Q P M) as H23.
----------------- apply (@lemma__ray4.lemma__ray4 Q P M).
------------------left.
exact H22.

------------------ exact H21.
----------------- assert (* Cut *) (euclidean__axioms.Col A Q B) as H24.
------------------ assert (* Cut *) ((euclidean__axioms.Col B A Q) /\ ((euclidean__axioms.Col B Q A) /\ ((euclidean__axioms.Col Q A B) /\ ((euclidean__axioms.Col A Q B) /\ (euclidean__axioms.Col Q B A))))) as H24.
------------------- apply (@lemma__collinearorder.lemma__collinearorder A B Q H18).
------------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H31.
------------------ assert (* Cut *) (euclidean__defs.OS P M A B) as H25.
------------------- apply (@lemma__sameside2.lemma__sameside2 A Q B P P M H20 H24 H23).
------------------- assert (* Cut *) (euclidean__defs.OS M P A B) as H26.
-------------------- assert (* Cut *) ((euclidean__defs.OS M P A B) /\ ((euclidean__defs.OS P M B A) /\ (euclidean__defs.OS M P B A))) as H26.
--------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric A B P M H25).
--------------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H27.
-------------------- assert (* Cut *) (~(euclidean__axioms.Col A B M)) as H27.
--------------------- intro H27.
assert (* Cut *) (euclidean__axioms.Col B M Q) as H28.
---------------------- apply (@euclidean__tactics.not__nCol__Col B M Q).
-----------------------intro H28.
apply (@euclidean__tactics.Col__nCol__False B M Q H28).
------------------------apply (@lemma__collinear4.lemma__collinear4 A B M Q H27 H18 H19).

---------------------- assert (* Cut *) (euclidean__axioms.Col P M Q) as H29.
----------------------- right.
right.
right.
right.
left.
exact H11.
----------------------- assert (* Cut *) (euclidean__axioms.Col M Q P) as H30.
------------------------ assert (* Cut *) ((euclidean__axioms.Col M P Q) /\ ((euclidean__axioms.Col M Q P) /\ ((euclidean__axioms.Col Q P M) /\ ((euclidean__axioms.Col P Q M) /\ (euclidean__axioms.Col Q M P))))) as H30.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder P M Q H29).
------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H33.
------------------------ assert (* Cut *) (euclidean__axioms.Col M Q B) as H31.
------------------------- assert (* Cut *) ((euclidean__axioms.Col M B Q) /\ ((euclidean__axioms.Col M Q B) /\ ((euclidean__axioms.Col Q B M) /\ ((euclidean__axioms.Col B Q M) /\ (euclidean__axioms.Col Q M B))))) as H31.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder B M Q H28).
-------------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
exact H34.
------------------------- assert (* Cut *) (euclidean__axioms.neq M Q) as H32.
-------------------------- assert (* Cut *) ((euclidean__axioms.neq M Q) /\ ((euclidean__axioms.neq P M) /\ (euclidean__axioms.neq P Q))) as H32.
--------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal P M Q H11).
--------------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H33.
-------------------------- assert (* Cut *) (euclidean__axioms.Col Q P B) as H33.
--------------------------- apply (@euclidean__tactics.not__nCol__Col Q P B).
----------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False Q P B H33).
-----------------------------apply (@lemma__collinear4.lemma__collinear4 M Q P B H30 H31 H32).

--------------------------- assert (* Cut *) (euclidean__axioms.Col Q B P) as H34.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col P Q B) /\ ((euclidean__axioms.Col P B Q) /\ ((euclidean__axioms.Col B Q P) /\ ((euclidean__axioms.Col Q B P) /\ (euclidean__axioms.Col B P Q))))) as H34.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder Q P B H33).
----------------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H41.
---------------------------- assert (* Cut *) (euclidean__axioms.Col Q B A) as H35.
----------------------------- assert (* Cut *) ((euclidean__axioms.Col Q A B) /\ ((euclidean__axioms.Col Q B A) /\ ((euclidean__axioms.Col B A Q) /\ ((euclidean__axioms.Col A B Q) /\ (euclidean__axioms.Col B Q A))))) as H35.
------------------------------ apply (@lemma__collinearorder.lemma__collinearorder A Q B H24).
------------------------------ destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H38.
----------------------------- assert (* Cut *) (euclidean__axioms.neq B Q) as H36.
------------------------------ assert (* Cut *) ((euclidean__axioms.neq C Q) /\ ((euclidean__axioms.neq B C) /\ (euclidean__axioms.neq B Q))) as H36.
------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B C Q H6).
------------------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H40.
------------------------------ assert (* Cut *) (euclidean__axioms.neq Q B) as H37.
------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B Q H36).
------------------------------- assert (* Cut *) (euclidean__axioms.Col B P A) as H38.
-------------------------------- apply (@euclidean__tactics.not__nCol__Col B P A).
---------------------------------intro H38.
apply (@euclidean__tactics.Col__nCol__False B P A H38).
----------------------------------apply (@lemma__collinear4.lemma__collinear4 Q B P A H34 H35 H37).

-------------------------------- assert (* Cut *) (euclidean__axioms.Col A B P) as H39.
--------------------------------- assert (* Cut *) ((euclidean__axioms.Col P B A) /\ ((euclidean__axioms.Col P A B) /\ ((euclidean__axioms.Col A B P) /\ ((euclidean__axioms.Col B A P) /\ (euclidean__axioms.Col A P B))))) as H39.
---------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B P A H38).
---------------------------------- destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H44.
--------------------------------- apply (@euclidean__tactics.Col__nCol__False A B P H0 H39).
--------------------- assert (* Cut *) (exists R, euclidean__defs.Perp__at M R A B R) as H28.
---------------------- apply (@proposition__12.proposition__12 A B M).
-----------------------apply (@euclidean__tactics.nCol__notCol A B M H27).

---------------------- destruct H28 as [R H29].
assert (exists E, (euclidean__axioms.Col M R R) /\ ((euclidean__axioms.Col A B R) /\ ((euclidean__axioms.Col A B E) /\ (euclidean__defs.Per E R M)))) as H30 by exact H29.
destruct H30 as [E H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
assert (* Cut *) (euclidean__defs.Per M R E) as H38.
----------------------- apply (@lemma__8__2.lemma__8__2 E R M H37).
----------------------- assert (* Cut *) (~(M = R)) as H39.
------------------------ intro H39.
assert (* Cut *) (euclidean__axioms.Col A B M) as H40.
------------------------- apply (@eq__ind__r euclidean__axioms.Point R (fun M0 => (euclidean__axioms.BetS P M0 Q) -> ((euclidean__axioms.Cong M0 P M0 Q) -> ((euclidean__axioms.BetS Q M0 P) -> ((euclidean__defs.Out Q P M0) -> ((euclidean__defs.OS P M0 A B) -> ((euclidean__defs.OS M0 P A B) -> ((~(euclidean__axioms.Col A B M0)) -> ((euclidean__defs.Perp__at M0 R A B R) -> ((euclidean__axioms.Col M0 R R) -> ((euclidean__defs.Per E R M0) -> ((euclidean__defs.Per M0 R E) -> (euclidean__axioms.Col A B M0))))))))))))) with (x := M).
--------------------------intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
exact H34.

-------------------------- exact H39.
-------------------------- exact H11.
-------------------------- exact H12.
-------------------------- exact H22.
-------------------------- exact H23.
-------------------------- exact H25.
-------------------------- exact H26.
-------------------------- exact H27.
-------------------------- exact H29.
-------------------------- exact H32.
-------------------------- exact H37.
-------------------------- exact H38.
------------------------- apply (@H27 H40).
------------------------ assert (* Cut *) (euclidean__axioms.neq A C) as H40.
------------------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq A C) /\ (euclidean__axioms.neq A B))) as H40.
-------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A C B H).
-------------------------- destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H43.
------------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H41.
-------------------------- assert (* Cut *) ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C A B) /\ (euclidean__axioms.Col A B C))))) as H41.
--------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B A H14).
--------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H49.
-------------------------- assert (* Cut *) (~(euclidean__defs.Per A C M)) as H42.
--------------------------- intro H42.
assert (* Cut *) (~(euclidean__axioms.neq R C)) as H43.
---------------------------- intro H43.
assert (* Cut *) (euclidean__axioms.Col B A C) as H44.
----------------------------- assert (* Cut *) ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A C B) /\ (euclidean__axioms.Col C B A))))) as H44.
------------------------------ apply (@lemma__collinearorder.lemma__collinearorder A B C H41).
------------------------------ destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
exact H45.
----------------------------- assert (* Cut *) (euclidean__axioms.Col B A R) as H45.
------------------------------ assert (* Cut *) ((euclidean__axioms.Col B A R) /\ ((euclidean__axioms.Col B R A) /\ ((euclidean__axioms.Col R A B) /\ ((euclidean__axioms.Col A R B) /\ (euclidean__axioms.Col R B A))))) as H45.
------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B R H34).
------------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H46.
------------------------------ assert (* Cut *) (euclidean__axioms.neq B A) as H46.
------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H19).
------------------------------- assert (* Cut *) (euclidean__axioms.Col A C R) as H47.
-------------------------------- apply (@euclidean__tactics.not__nCol__Col A C R).
---------------------------------intro H47.
apply (@euclidean__tactics.Col__nCol__False A C R H47).
----------------------------------apply (@lemma__collinear4.lemma__collinear4 B A C R H44 H45 H46).

-------------------------------- assert (* Cut *) (euclidean__defs.Per R C M) as H48.
--------------------------------- apply (@lemma__collinearright.lemma__collinearright A C R M H42 H47 H43).
--------------------------------- assert (* Cut *) (~(euclidean__defs.Per M R C)) as H49.
---------------------------------- apply (@lemma__8__7.lemma__8__7 M C R H48).
---------------------------------- assert (euclidean__defs.Per E R M) as H50 by exact H37.
assert (* Cut *) (euclidean__axioms.Col B C R) as H51.
----------------------------------- apply (@euclidean__tactics.not__nCol__Col B C R).
------------------------------------intro H51.
apply (@euclidean__tactics.Col__nCol__False B C R H51).
-------------------------------------apply (@lemma__collinear4.lemma__collinear4 A B C R H41 H34 H19).

----------------------------------- assert (* Cut *) (euclidean__axioms.Col B C E) as H52.
------------------------------------ apply (@euclidean__tactics.not__nCol__Col B C E).
-------------------------------------intro H52.
apply (@euclidean__tactics.Col__nCol__False B C E H52).
--------------------------------------apply (@lemma__collinear4.lemma__collinear4 A B C E H41 H36 H19).

------------------------------------ assert (* Cut *) (euclidean__axioms.neq C B) as H53.
------------------------------------- assert (* Cut *) ((euclidean__axioms.neq M P) /\ ((euclidean__axioms.neq Q M) /\ (euclidean__axioms.neq Q P))) as H53.
-------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal Q M P H22).
-------------------------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H15.
------------------------------------- assert (euclidean__axioms.neq B C) as H54 by exact H2.
assert (* Cut *) (euclidean__axioms.Col C R E) as H55.
-------------------------------------- apply (@euclidean__tactics.not__nCol__Col C R E).
---------------------------------------intro H55.
apply (@euclidean__tactics.Col__nCol__False C R E H55).
----------------------------------------apply (@lemma__collinear4.lemma__collinear4 B C R E H51 H52 H54).

-------------------------------------- assert (* Cut *) (euclidean__axioms.Col E R C) as H56.
--------------------------------------- assert (* Cut *) ((euclidean__axioms.Col R C E) /\ ((euclidean__axioms.Col R E C) /\ ((euclidean__axioms.Col E C R) /\ ((euclidean__axioms.Col C E R) /\ (euclidean__axioms.Col E R C))))) as H56.
---------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C R E H55).
---------------------------------------- destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
exact H64.
--------------------------------------- assert (* Cut *) (euclidean__axioms.neq C R) as H57.
---------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric R C H43).
---------------------------------------- assert (* Cut *) (euclidean__defs.Per C R M) as H58.
----------------------------------------- apply (@lemma__collinearright.lemma__collinearright E R C M H50 H56 H57).
----------------------------------------- assert (* Cut *) (euclidean__defs.Per M R C) as H59.
------------------------------------------ apply (@lemma__8__2.lemma__8__2 C R M H58).
------------------------------------------ apply (@H27).
-------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B M).
--------------------------------------------intro H60.
apply (@H49 H59).

---------------------------- assert (* Cut *) (~(M = C)) as H44.
----------------------------- intro H44.
assert (* Cut *) (euclidean__axioms.Col A B M) as H45.
------------------------------ apply (@eq__ind__r euclidean__axioms.Point C (fun M0 => (euclidean__axioms.BetS P M0 Q) -> ((euclidean__axioms.Cong M0 P M0 Q) -> ((euclidean__axioms.BetS Q M0 P) -> ((euclidean__defs.Out Q P M0) -> ((euclidean__defs.OS P M0 A B) -> ((euclidean__defs.OS M0 P A B) -> ((~(euclidean__axioms.Col A B M0)) -> ((euclidean__defs.Perp__at M0 R A B R) -> ((euclidean__axioms.Col M0 R R) -> ((euclidean__defs.Per E R M0) -> ((euclidean__defs.Per M0 R E) -> ((~(M0 = R)) -> ((euclidean__defs.Per A C M0) -> (euclidean__axioms.Col A B M0))))))))))))))) with (x := M).
-------------------------------intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
intro H57.
exact H41.

------------------------------- exact H44.
------------------------------- exact H11.
------------------------------- exact H12.
------------------------------- exact H22.
------------------------------- exact H23.
------------------------------- exact H25.
------------------------------- exact H26.
------------------------------- exact H27.
------------------------------- exact H29.
------------------------------- exact H32.
------------------------------- exact H37.
------------------------------- exact H38.
------------------------------- exact H39.
------------------------------- exact H42.
------------------------------ apply (@H27 H45).
----------------------------- assert (* Cut *) (euclidean__axioms.Cong Q C P C) as H45.
------------------------------ assert (* Cut *) ((euclidean__axioms.Cong Q C P C) /\ ((euclidean__axioms.Cong Q C C P) /\ (euclidean__axioms.Cong C Q P C))) as H45.
------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip C Q C P H7).
------------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
------------------------------ assert (euclidean__axioms.BetS Q M P) as H46 by exact H22.
assert (* Cut *) (euclidean__axioms.Cong Q M P M) as H47.
------------------------------- assert (* Cut *) ((euclidean__axioms.Cong Q M P M) /\ (euclidean__axioms.Cong P M Q M)) as H47.
-------------------------------- apply (@lemma__doublereverse.lemma__doublereverse M P M Q H12).
-------------------------------- destruct H47 as [H48 H49].
exact H48.
------------------------------- assert (* Cut *) (euclidean__defs.Per Q M C) as H48.
-------------------------------- exists P.
split.
--------------------------------- exact H46.
--------------------------------- split.
---------------------------------- exact H47.
---------------------------------- split.
----------------------------------- exact H45.
----------------------------------- exact H44.
-------------------------------- assert (* Cut *) (euclidean__axioms.neq C Q) as H49.
--------------------------------- assert (* Cut *) ((euclidean__axioms.neq C Q) /\ ((euclidean__axioms.neq B C) /\ (euclidean__axioms.neq B Q))) as H49.
---------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B C Q H6).
---------------------------------- destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H50.
--------------------------------- assert (* Cut *) (euclidean__axioms.neq Q C) as H50.
---------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C Q H49).
---------------------------------- assert (euclidean__defs.Per E R M) as H51 by exact H37.
assert (* Cut *) (euclidean__axioms.neq Q R) as H52.
----------------------------------- assert (* Cut *) (R = C) as H52.
------------------------------------ apply (@euclidean__tactics.NNPP (R = C) H43).
------------------------------------ intro H53.
assert (* Cut *) (C = Q) as Heq.
------------------------------------- apply (@logic.eq__trans Point C R Q).
--------------------------------------apply (@logic.eq__sym Point R C H52).

--------------------------------------apply (@logic.eq__sym Point Q R H53).

------------------------------------- assert False.
--------------------------------------apply (@H49 Heq).
-------------------------------------- contradiction.
----------------------------------- assert (* Cut *) (euclidean__axioms.Col B C Q) as H53.
------------------------------------ right.
right.
right.
right.
left.
exact H6.
------------------------------------ assert (* Cut *) (euclidean__axioms.Col C B Q) as H54.
------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C B Q) /\ ((euclidean__axioms.Col C Q B) /\ ((euclidean__axioms.Col Q B C) /\ ((euclidean__axioms.Col B Q C) /\ (euclidean__axioms.Col Q C B))))) as H54.
-------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C Q H53).
-------------------------------------- destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
exact H55.
------------------------------------- assert (* Cut *) (euclidean__axioms.Col Q B C) as H55.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.Col B C Q) /\ ((euclidean__axioms.Col B Q C) /\ ((euclidean__axioms.Col Q C B) /\ ((euclidean__axioms.Col C Q B) /\ (euclidean__axioms.Col Q B C))))) as H55.
--------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B Q H54).
--------------------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H63.
-------------------------------------- assert (* Cut *) (euclidean__axioms.Col B E R) as H56.
--------------------------------------- apply (@euclidean__tactics.not__nCol__Col B E R).
----------------------------------------intro H56.
apply (@euclidean__tactics.Col__nCol__False B E R H56).
-----------------------------------------apply (@lemma__collinear4.lemma__collinear4 A B E R H36 H34 H19).

--------------------------------------- assert (* Cut *) (euclidean__axioms.Col B E Q) as H57.
---------------------------------------- apply (@euclidean__tactics.not__nCol__Col B E Q).
-----------------------------------------intro H57.
apply (@euclidean__tactics.Col__nCol__False B E Q H57).
------------------------------------------apply (@lemma__collinear4.lemma__collinear4 A B E Q H36 H18 H19).

---------------------------------------- assert (* Cut *) (~(euclidean__axioms.neq B E)) as H58.
----------------------------------------- intro H58.
assert (* Cut *) (euclidean__axioms.Col E R Q) as H59.
------------------------------------------ apply (@euclidean__tactics.not__nCol__Col E R Q).
-------------------------------------------intro H59.
apply (@euclidean__tactics.Col__nCol__False E R Q H59).
--------------------------------------------apply (@lemma__collinear4.lemma__collinear4 B E R Q H56 H57 H58).

------------------------------------------ assert (* Cut *) (euclidean__defs.Per Q R M) as H60.
------------------------------------------- apply (@lemma__collinearright.lemma__collinearright E R Q M H51 H59 H52).
------------------------------------------- assert (* Cut *) (euclidean__defs.Per Q C M) as H61.
-------------------------------------------- apply (@eq__ind euclidean__axioms.Point R (fun X => euclidean__defs.Per Q X M)) with (y := C).
--------------------------------------------- exact H60.
---------------------------------------------apply (@euclidean__tactics.NNPP (R = C) H43).

-------------------------------------------- assert (* Cut *) (euclidean__defs.Per M C Q) as H62.
--------------------------------------------- apply (@lemma__8__2.lemma__8__2 Q C M H61).
--------------------------------------------- assert (* Cut *) (~(euclidean__defs.Per Q M C)) as H63.
---------------------------------------------- apply (@lemma__8__7.lemma__8__7 Q C M H62).
---------------------------------------------- apply (@H27).
-----------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B M).
------------------------------------------------intro H64.
apply (@H63 H48).

----------------------------------------- assert (* Cut *) (euclidean__axioms.Col A E R) as H59.
------------------------------------------ apply (@eq__ind__r euclidean__axioms.Point C (fun X => euclidean__axioms.Col A E X)) with (x := R).
-------------------------------------------apply (@eq__ind euclidean__axioms.Point B (fun X => euclidean__axioms.Col A X C)) with (y := E).
-------------------------------------------- exact H41.
--------------------------------------------apply (@euclidean__tactics.NNPP (B = E) H58).

-------------------------------------------apply (@euclidean__tactics.NNPP (R = C) H43).

------------------------------------------ assert (* Cut *) (euclidean__axioms.Col A B Q) as H60.
------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col E A R) /\ ((euclidean__axioms.Col E R A) /\ ((euclidean__axioms.Col R A E) /\ ((euclidean__axioms.Col A R E) /\ (euclidean__axioms.Col R E A))))) as H60.
-------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A E R H59).
-------------------------------------------- destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
exact H18.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A E Q) as H61.
-------------------------------------------- apply (@eq__ind euclidean__axioms.Point B (fun X => euclidean__axioms.Col A X Q)) with (y := E).
--------------------------------------------- exact H60.
---------------------------------------------apply (@euclidean__tactics.NNPP (B = E) H58).

-------------------------------------------- assert (* Cut *) (euclidean__axioms.neq A E) as H62.
--------------------------------------------- assert (* Cut *) (B = E) as H62.
---------------------------------------------- apply (@euclidean__tactics.NNPP (B = E) H58).
---------------------------------------------- assert (* Cut *) (R = C) as H63.
----------------------------------------------- apply (@euclidean__tactics.NNPP (R = C) H43).
----------------------------------------------- intro H64.
assert (* Cut *) (A = B) as Heq.
------------------------------------------------ apply (@logic.eq__trans Point A E B H64).
-------------------------------------------------apply (@logic.eq__sym Point B E H62).

------------------------------------------------ assert False.
-------------------------------------------------apply (@H19 Heq).
------------------------------------------------- contradiction.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E R Q) as H63.
---------------------------------------------- apply (@euclidean__tactics.not__nCol__Col E R Q).
-----------------------------------------------intro H63.
apply (@euclidean__tactics.Col__nCol__False E R Q H63).
------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 A E R Q H59 H61 H62).

---------------------------------------------- assert (* Cut *) (euclidean__defs.Per Q R M) as H64.
----------------------------------------------- apply (@lemma__collinearright.lemma__collinearright E R Q M H51 H63 H52).
----------------------------------------------- assert (* Cut *) (euclidean__defs.Per Q C M) as H65.
------------------------------------------------ apply (@eq__ind euclidean__axioms.Point R (fun X => euclidean__defs.Per Q X M)) with (y := C).
------------------------------------------------- exact H64.
-------------------------------------------------apply (@euclidean__tactics.NNPP (R = C) H43).

------------------------------------------------ assert (* Cut *) (euclidean__defs.Per M C Q) as H66.
------------------------------------------------- apply (@lemma__8__2.lemma__8__2 Q C M H65).
------------------------------------------------- assert (* Cut *) (~(euclidean__defs.Per Q M C)) as H67.
-------------------------------------------------- apply (@lemma__8__7.lemma__8__7 Q C M H66).
-------------------------------------------------- apply (@H27).
---------------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B M).
----------------------------------------------------intro H68.
apply (@H67 H48).

--------------------------- exists M.
split.
---------------------------- apply (@euclidean__tactics.nCol__notCol A B M H27).
---------------------------- split.
----------------------------- exact H26.
----------------------------- exact H42.
Qed.


(** * Enriched categories *)

(** ** Contents

 - Definition
 - Enriched functors
  - Composition of enriched functors
 *)

Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Core.Isos.

Local Open Scope cat.
Local Open Scope moncat.

Import MonoidalNotations.

Notation "C ⊠ D" := (category_binproduct C D) (at level 38).
Notation "( c , d )" := (make_catbinprod c d).
Notation "( f #, g )" := (catbinprodmor f g).

Section aux.

Lemma bifunctor_on_morphisms_comm {A B C : category} (F : A ⊠ B ⟶ C) {a a' : A} {b b' : B} (f : a --> a') (g : b --> b') : #F (f #, identity _) · #F (identity _ #, g) = #F (identity _ #, g) · #F (f #, identity _).
Proof.
  rewrite <- !functor_comp.
  change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w).
  rewrite !id_left, !id_right.
  reflexivity.
Qed.

Lemma bifunctor_comp_left {A B C : category} (F : A ⊠ B ⟶ C) {a a' a'' : A} {b : B} (f : a --> a') (g : a' --> a'') : #F (f · g #, identity b) = #F (f #, identity _) · #F (g #, identity _).
Proof.
  rewrite <- (functor_comp F).
  change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w).
  rewrite id_left.
  reflexivity.
Qed.

Lemma bifunctor_comp_right {A B C : category} (F : A ⊠ B ⟶ C) {a : A} {b b' b'' : B} (f : b --> b') (g : b' --> b'') : #F (identity a #, f · g) = #F (identity _ #, f) · #F (identity _ #, g).
Proof.
  rewrite <- (functor_comp F).
  change ((?x #, ?y) · (?z #, ?w)) with (x · z #, y · w).
  rewrite id_left.
  reflexivity.
Qed.

End aux.

Section A.

(** For the whole file, fix a monoidal category. *)
Context {Mon_V : monoidal_cat}.

Let I        := I_{Mon_V}.

(** ** Definition *)

(** This definition is based on that on the nLab *)
Section Def.

  Definition enriched_precat_data : UU :=
    ∑ C : UU,                                     (* Type of objects *)
    ∑ mor : C -> C -> ob Mon_V,                     (* Object of morphisms *)
    dirprod
      (∏ x : C, I --> mor x x)                      (* Identities *)
      (∏ x y z : C, mor y z ⊗ mor x y --> mor x z). (* Composition morphism *)

  (** Accessors *)
  Definition enriched_cat_ob    (d : enriched_precat_data) : UU := pr1 d.
  Definition enriched_cat_mor   {d : enriched_precat_data} :
    enriched_cat_ob d -> enriched_cat_ob d -> ob Mon_V := pr1 (pr2 d).
  Definition enriched_cat_identity    {d : enriched_precat_data} :
    ∏ x : enriched_cat_ob d, I --> enriched_cat_mor x x := pr1 (pr2 (pr2 d)).
  Definition enriched_cat_comp {d : enriched_precat_data} (x y z : enriched_cat_ob d) :
    enriched_cat_mor y z ⊗ enriched_cat_mor x y --> enriched_cat_mor x z :=
    pr2 (pr2 (pr2 d)) x y z.

  Coercion enriched_cat_ob : enriched_precat_data >-> UU.

  (** Constructor. Use like so: [use make_enriched_cat_data] *)
  Definition make_enriched_precat_data (C : UU) (mor : ∏ x y : C, ob Mon_V)
             (ids : ∏ x : C, I --> mor x x)
             (assoc : ∏ x y z : C, mor y z ⊗ mor x y --> mor x z) :
    enriched_precat_data.
  Proof.
    unfold enriched_precat_data.
    use tpair; [|use tpair; [|use make_dirprod]].
    - exact C.
    - exact mor.
    - exact ids.
    - exact assoc.
  Defined.

  Section Axioms.
    Context (e : enriched_precat_data).

    (** Associativity axiom for enriched categories:
<<
          (C(c, d) ⊗ C(b, c)) ⊗ C(a, b) --------> C(c, d) ⊗ (C(b, c) ⊗ C(a, b))
                        |                                        |
                ∘ ⊗ identity  |                                identity ⊗ ∘  |
                        V                                        V
                C(b, d) ⊗ C(a, b) -----> C(a, d) <------ C(c, d) ⊗ C(a, c)
>>
    *)

    Definition enriched_assoc_ax : UU :=
      ∏ a b c d : enriched_cat_ob e,
      (enriched_cat_comp b c d #⊗ (identity _))
        · enriched_cat_comp a _ _ =
      mon_lassociator _ _ _
        · ((identity _ #⊗ enriched_cat_comp _ _ _)
          · enriched_cat_comp _ _ _).

    Lemma isaprop_enriched_assoc_ax :
      has_homsets Mon_V -> isaprop (enriched_assoc_ax).
    Proof.
      intro hsV; do 4 (apply impred; intro); apply hsV.
    Defined.

    (** Identity axiom(s) for enriched categories:
<<
          I ⊗ C(a, b) ---> C(b, b) ⊗ C(a, b)
                      \         |
                       \        V
                           C(a, b)
>>
        (And the symmetrized version.)
    *)
    Definition enriched_id_ax : UU :=
      ∏ a b : enriched_cat_ob e,
        dirprod
          (enriched_cat_identity b #⊗ (identity _) · enriched_cat_comp a b b = mon_lunitor _)
          ((identity _ #⊗ enriched_cat_identity a) · enriched_cat_comp a a b = mon_runitor _).

  End Axioms.

  Definition enriched_precat : UU :=
    ∑ d : enriched_precat_data, (enriched_id_ax d) × (enriched_assoc_ax d).

  Definition enriched_precat_to_enriched_precat_data :
    enriched_precat -> enriched_precat_data := pr1.
  Coercion enriched_precat_to_enriched_precat_data :
    enriched_precat >-> enriched_precat_data.

  Definition make_enriched_precat (d : enriched_precat_data) (idax : enriched_id_ax d)
             (assocax : enriched_assoc_ax d) : enriched_precat :=
    tpair _ d (make_dirprod idax assocax).

  (** Accessors *)
  Definition enriched_id_left {A : enriched_precat} (a b : A) : enriched_cat_identity b #⊗ (identity _) · enriched_cat_comp a b b = mon_lunitor _ := pr1 (pr1 (pr2 A) _ _).

  Definition enriched_id_right {A : enriched_precat} (a b : A) : (identity _ #⊗ enriched_cat_identity a) · enriched_cat_comp a a b = mon_runitor _ := pr2 (pr1 (pr2 A) _ _).

  Definition enriched_assoc {A : enriched_precat} (a b c d : A) : (enriched_cat_comp b c d #⊗ (identity _)) · enriched_cat_comp a _ _ = mon_lassociator _ _ _ · ((identity _ #⊗ enriched_cat_comp _ _ _) · enriched_cat_comp _ _ _) := pr2 (pr2 A) a b c d.

End Def.

(** *** Enriched functors *)

Section Functors.
  Context {D E : enriched_precat}.

  Definition enriched_functor_data : UU :=
    ∑ F : enriched_cat_ob D -> enriched_cat_ob E,
      ∏ x y : enriched_cat_ob D,
        Mon_V⟦enriched_cat_mor x y, enriched_cat_mor (F x) (F y)⟧.

  Definition make_enriched_functor_data
    (F : enriched_cat_ob D -> enriched_cat_ob E)
    (mor : ∏ x y : enriched_cat_ob D,
       Mon_V⟦enriched_cat_mor x y, enriched_cat_mor (F x) (F y)⟧)
    : enriched_functor_data :=
    tpair _ F mor.

  (** Accessors *)
  Definition enriched_functor_on_objects (F : enriched_functor_data) :
    enriched_cat_ob D -> enriched_cat_ob E := pr1 F.
  Coercion enriched_functor_on_objects : enriched_functor_data >-> Funclass.
  Definition enriched_functor_on_morphisms (F : enriched_functor_data) :
    ∏ x y : enriched_cat_ob D,
      Mon_V⟦enriched_cat_mor x y, enriched_cat_mor (F x) (F y)⟧ := pr2 F.

  Section Axioms.
    Context (F : enriched_functor_data).

    Definition enriched_functor_unit_ax : UU :=
      ∏ a : enriched_cat_ob D,
      enriched_cat_identity a · enriched_functor_on_morphisms F a a
      =
      enriched_cat_identity (F a).

    Definition enriched_functor_comp_ax : UU :=
      ∏ a b c : enriched_cat_ob D,
      enriched_cat_comp a b c · enriched_functor_on_morphisms F a c
      =
      (enriched_functor_on_morphisms F b c) #⊗  (enriched_functor_on_morphisms F a b)
      · enriched_cat_comp _ _ _.
  End Axioms.

  Definition enriched_functor : UU :=
    ∑ d : enriched_functor_data,
      enriched_functor_unit_ax d × enriched_functor_comp_ax d.

  (** Constructor *)

  Definition make_enriched_functor (d : enriched_functor_data)
    (uax : enriched_functor_unit_ax d) (cax : enriched_functor_comp_ax d) :
    enriched_functor :=
    tpair _ d (make_dirprod uax cax).

  (** Coercion to *_data *)

  Definition enriched_functor_to_enriched_functor_data (F : enriched_functor) :
    enriched_functor_data := pr1 F.
  Coercion enriched_functor_to_enriched_functor_data :
    enriched_functor >-> enriched_functor_data.

  (** Accessors for axioms*)

  Definition enriched_functor_on_identity (F : enriched_functor) :
    enriched_functor_unit_ax F := (pr1 (pr2 F)).

  Definition enriched_functor_on_comp (F : enriched_functor) :
    enriched_functor_comp_ax F := (pr2 (pr2 F)).
End Functors.

Arguments enriched_functor_data _ _ : clear implicits.
Arguments enriched_functor _ _ : clear implicits.

Definition enriched_functor_identity (A : enriched_precat) : enriched_functor A A.
Proof.
  use make_enriched_functor.
  - use make_enriched_functor_data.
    + intro a.
      exact a.
    + intros x y.
      exact (identity _).
  - intro a.
    apply id_right.
  - abstract
      (intros a b c;
       simpl ;
       rewrite tensor_id_id ;
       rewrite id_left, id_right;
       reflexivity).
Defined.

(** *** Composition of enriched functors *)

Definition enriched_functor_comp_data
           {P Q R : enriched_precat}
           (F : enriched_functor_data P Q) (G : enriched_functor_data Q R) :
  enriched_functor_data P R.
Proof.
  use make_enriched_functor_data.
  - exact (λ x, G (F x)).
  - intros x y; cbn.
    refine (_ · (enriched_functor_on_morphisms G (F x) (F y))).
    apply (enriched_functor_on_morphisms F).
Defined.

Definition enriched_functor_comp
           {P Q R : enriched_precat}
           (F : enriched_functor P Q) (G : enriched_functor Q R) :
  enriched_functor P R.
Proof.
  use make_enriched_functor.
  - apply (enriched_functor_comp_data F G).
  - (** Unit axioms *)
    intros a.
    unfold enriched_functor_comp_data; cbn.
    refine (assoc _ _ _ @ _).
    refine (maponpaths (fun f => f · _) (pr1 (pr2 F) a) @ _).
    apply enriched_functor_on_identity.
  - (** Composition axioms *)
    intros a b c; cbn.
    refine (assoc _ _ _ @ _).
    refine (maponpaths (fun f => f · _) (enriched_functor_on_comp F _ _ _) @ _).
    rewrite tensor_comp_mor.
    (* Get rid of the common prefix *)
    refine (_ @ assoc _ _ _).
    refine (!assoc _ _ _ @ _).
    apply (maponpaths (fun f => _ · f)).

    apply enriched_functor_on_comp.
Defined.

(*
  TODO
  Definition enriched_functor_data_eq {A B : enriched_precat Mon_V} {F G : enriched_functor_data _ A B} : (∏ a : A, F a = G a) -> (∏ (a a' : A), enriched_functor_on_morphisms F a a' = enriched_functor_on_morphisms G a a') -> F = G.
*)

Definition enriched_functor_eq {A B : enriched_precat} {F G : enriched_functor A B} : (enriched_functor_to_enriched_functor_data F = enriched_functor_to_enriched_functor_data G) -> F = G.
Proof.
  intro H.
  use total2_paths_b.
  - assumption.
  - apply proofirrelevance.
    apply isapropdirprod.
    + apply impred_isaprop.
      intro.
      apply homset_property.
    + repeat (apply impred_isaprop;intro).
      apply homset_property.
Defined.

Section UnderlyingMorphisms.

Definition underlying_morphism {A : enriched_precat} (x y : A) := I --> enriched_cat_mor x y.

Definition precompose_underlying_morphism {A : enriched_precat} {x y : A} (z : A) (f : underlying_morphism x y) : enriched_cat_mor y z --> enriched_cat_mor x z := (mon_rinvunitor _ · (identity _ #⊗ f) · enriched_cat_comp _ _ _).

Definition postcompose_underlying_morphism {A : enriched_precat} (x : A) {y z : A} (f : underlying_morphism y z) : enriched_cat_mor x y --> enriched_cat_mor x z := (mon_linvunitor _ · (f #⊗ identity _) · enriched_cat_comp _ _ _).

Definition precompose_identity {A : enriched_precat} {x y : A} : precompose_underlying_morphism y (enriched_cat_identity x) = identity _.
Proof.
  unfold precompose_underlying_morphism.
  rewrite assoc'.
  apply (transportb (λ f, _ · f = _) (enriched_id_right _ _)).
  apply mon_rinvunitor_runitor.
Qed.

Definition postcompose_identity {A : enriched_precat} {x y : A} : postcompose_underlying_morphism x (enriched_cat_identity y) = identity _.
Proof.
  unfold postcompose_underlying_morphism.
  rewrite assoc'.
  apply (transportb (λ h, _ · h = _) (enriched_id_left _ _)).
  apply mon_linvunitor_lunitor.
Qed.

Lemma precompose_underlying_morphism_enriched_cat_comp {A : enriched_precat} {w x y z : A} (f : underlying_morphism w x) : ((identity _ #⊗ precompose_underlying_morphism y f) · enriched_cat_comp w y z = enriched_cat_comp x y z · precompose_underlying_morphism z f)%cat.
Proof.
  unfold precompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_rinvunitor.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_split'.
    rewrite tensor_split.
    apply idpath.
  }
  refine (!_).
  rewrite assoc.
  rewrite (assoc' _ _ (enriched_cat_comp w x z)).
  rewrite (@enriched_assoc A).
  rewrite !assoc.
  rewrite !tensor_comp_id_l.
  do 2 apply cancel_postcomposition.
  rewrite assoc'.
  rewrite <- tensor_id_id.
  apply pathsinv0.
  etrans.
  {
    apply cancel_precomposition.
    apply tensor_lassociator.
  }
  rewrite assoc.
  apply cancel_postcomposition.
  rewrite <- mon_rinvunitor_triangle.
  rewrite !assoc'.
  refine (_ @ id_right _).
  apply maponpaths.
  apply mon_rassociator_lassociator.
Qed.

Lemma enriched_cat_comp_underlying_morphism_middle {A : enriched_precat} {w x y z : A} (f : underlying_morphism x y) : ((identity _ #⊗ postcompose_underlying_morphism w f) · enriched_cat_comp w y z = (precompose_underlying_morphism z f #⊗ identity _) · enriched_cat_comp w x z).
Proof.
  unfold precompose_underlying_morphism, postcompose_underlying_morphism.
  rewrite !tensor_comp_id_r, !tensor_comp_id_l.
  apply pathsinv0.
  rewrite assoc'.
  rewrite (@enriched_assoc A).
  rewrite !assoc.
  do 2 apply cancel_postcomposition.
  rewrite assoc'.
  etrans.
  {
    apply cancel_precomposition.
    apply tensor_lassociator.
  }
  rewrite assoc.
  apply cancel_postcomposition.
  rewrite mon_inv_triangle.
  apply idpath.
Qed.

Lemma postcompose_underlying_morphism_enriched_cat_comp {A : enriched_precat} {w x y z : A} (f : underlying_morphism y z) : ((postcompose_underlying_morphism x f #⊗ identity _) · enriched_cat_comp w x z = enriched_cat_comp w x y · postcompose_underlying_morphism w f).
Proof.
  unfold postcompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_linvunitor.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_split.
    rewrite tensor_split'.
    apply idpath.
  }
  refine (!_).
  rewrite assoc.
  rewrite !tensor_comp_id_r.
  rewrite assoc'.
  rewrite (@enriched_assoc A).
  rewrite !assoc.
  do 2 apply cancel_postcomposition.
  rewrite assoc'.
  etrans.
  {
    apply cancel_precomposition.
    apply tensor_lassociator.
  }
  rewrite assoc.
  rewrite tensor_id_id.
  apply cancel_postcomposition.
  apply mon_linvunitor_triangle.
Qed.

Definition postcompose_underlying_morphism_composite {A : enriched_precat} (w : A) {x y z : A} (f : underlying_morphism x y) (g : underlying_morphism y z) : postcompose_underlying_morphism w (f · postcompose_underlying_morphism _ g) = postcompose_underlying_morphism _ f · postcompose_underlying_morphism _ g.
Proof.
  unfold postcompose_underlying_morphism.
  rewrite !tensor_comp_id_r.
  rewrite !assoc'.
  do 2 apply cancel_precomposition.
  rewrite enriched_assoc.
  rewrite !assoc.
  apply cancel_postcomposition.
  rewrite !assoc'.
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite tensor_lassociator.
    apply idpath.
  }
  simpl.
  rewrite assoc.
  rewrite tensor_id_id.
  rewrite assoc.
  rewrite mon_linvunitor_triangle.
  rewrite !assoc'.
  rewrite <- tensor_split'.
  rewrite tensor_split.
  rewrite !assoc.
  apply cancel_postcomposition.
  apply pathsinv0.
  apply tensor_linvunitor.
Qed.

Definition precompose_underlying_morphism_composite {A : enriched_precat} (w : A) {x y z : A} (f : underlying_morphism x y) (g : underlying_morphism y z) : precompose_underlying_morphism w (f · postcompose_underlying_morphism _ g) = precompose_underlying_morphism _ g · precompose_underlying_morphism _ f.
Proof.
  unfold postcompose_underlying_morphism, precompose_underlying_morphism.
  rewrite !tensor_comp_id_l.
  rewrite !assoc.
  rewrite (assoc' _ (enriched_cat_comp y z w)).
  rewrite tensor_rinvunitor.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    do 3 apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_split'.
    rewrite tensor_split.
    apply idpath.
  }
  refine (!_).
  rewrite assoc.
  rewrite (assoc' _ _ (enriched_cat_comp x y w)).
  rewrite enriched_assoc.
  rewrite !assoc.
  do 2 apply cancel_postcomposition.
  rewrite <- tensor_id_id.
  rewrite !assoc'.
  apply cancel_precomposition.
  do 2 rewrite assoc.
  rewrite tensor_lassociator.
  rewrite assoc.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- mon_rinvunitor_triangle.
    rewrite !assoc'.
    apply maponpaths.
    rewrite !assoc.
    etrans.
    {
      refine (maponpaths (λ z, z · _) _).
      apply mon_rassociator_lassociator.
    }
    apply id_left.
  }
  rewrite <- !tensor_comp_mor.
  apply maponpaths.
  rewrite !assoc.
  rewrite tensor_linvunitor.
  rewrite tensor_rinvunitor.
  rewrite mon_rinvunitor_I_mon_linvunitor_I.
  rewrite !assoc'.
  apply maponpaths.
  rewrite <- tensor_split, <- tensor_split'.
  apply idpath.
Qed.

Definition underlying_morphism_compose_swap {A : enriched_precat} {x y z : A} (f : underlying_morphism x y) (g : underlying_morphism y z) : f · postcompose_underlying_morphism _ g = g · precompose_underlying_morphism _ f.
Proof.
  unfold postcompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_linvunitor.
  rewrite !assoc'.
  etrans.
  {
    apply maponpaths.
    rewrite assoc.
    rewrite <- tensor_comp_mor.
    rewrite id_left, id_right.
    apply idpath.
  }
  unfold precompose_underlying_morphism.
  rewrite !assoc.
  refine (maponpaths (λ z, z · _) _).
  rewrite tensor_rinvunitor.
  rewrite !assoc'.
  rewrite <- tensor_split'.
  refine (maponpaths (λ z, z · _) _).
  apply mon_linvunitor_I_mon_rinvunitor_I.
Qed.

Definition pre_post_compose_commute {A : enriched_precat} {w x y z : A} (f : underlying_morphism w x) (g : underlying_morphism y z) : precompose_underlying_morphism _ f · postcompose_underlying_morphism _ g = postcompose_underlying_morphism _ g · precompose_underlying_morphism _ f.
Proof.
  unfold postcompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_linvunitor.
  rewrite !assoc'.
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_split.
    rewrite tensor_split'.
    apply idpath.
  }
  rewrite !assoc'.
  do 2 apply cancel_precomposition.
  unfold precompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_comp_id_l.
  rewrite tensor_rinvunitor.
  refine (!_).
  rewrite !assoc'.
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_split'.
    rewrite tensor_split.
    apply idpath.
  }
  rewrite !assoc'.
  rewrite (enriched_assoc w).
  rewrite !assoc.
  do 2 apply cancel_postcomposition.
  rewrite assoc'.
  rewrite <- tensor_id_id.
  rewrite tensor_lassociator.
  rewrite !assoc.
  rewrite <- mon_rinvunitor_triangle.
  etrans.
  {
    refine (maponpaths (λ z, z · _) _).
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply mon_rassociator_lassociator.
    }
    apply id_right.
  }
  rewrite tensor_comp_id_l.
  apply idpath.
Qed.

Definition enriched_functor_on_postcompose {A B : enriched_precat} (F : enriched_functor A B) {y z : A} (f : underlying_morphism y z) (x : A) : postcompose_underlying_morphism x f · enriched_functor_on_morphisms F _ _ = enriched_functor_on_morphisms F _ _ · postcompose_underlying_morphism _ (f · enriched_functor_on_morphisms F _ _).
Proof.
  unfold postcompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_linvunitor.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_comp_mor.
    rewrite id_left, id_right.
    apply idpath.
  }
  apply cancel_precomposition.
  rewrite enriched_functor_on_comp.
  rewrite !assoc.
  apply cancel_postcomposition.
  rewrite <- tensor_comp_mor.
  rewrite id_left.
  apply idpath.
Qed.

Definition enriched_functor_on_precompose {A B : enriched_precat} (F : enriched_functor A B) {x y : A} (f : underlying_morphism x y) (z : A) : precompose_underlying_morphism z f · enriched_functor_on_morphisms F _ _ = enriched_functor_on_morphisms F _ _ · precompose_underlying_morphism _ (f · enriched_functor_on_morphisms F _ _).
Proof.
  unfold precompose_underlying_morphism.
  rewrite !assoc.
  rewrite tensor_rinvunitor.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite <- tensor_comp_mor.
    rewrite id_left, id_right.
    apply idpath.
  }
  apply cancel_precomposition.
  rewrite enriched_functor_on_comp.
  rewrite !assoc.
  apply cancel_postcomposition.
  rewrite <- tensor_comp_mor.
  rewrite id_left.
  apply idpath.
Qed.

End UnderlyingMorphisms.

Section NatTrans.

Definition enriched_nat_trans_data {A B : enriched_precat} (F G : enriched_functor A B) := ∏ a : A, underlying_morphism (F a) (G a).

Definition enriched_nat_trans_law {A B : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans_data F G) := ∏ (x y : A), enriched_functor_on_morphisms F x y · postcompose_underlying_morphism _ (a y) = enriched_functor_on_morphisms G x y · precompose_underlying_morphism _ (a x).

Definition enriched_nat_trans {A B : enriched_precat} (F G : enriched_functor A B) := ∑ a : enriched_nat_trans_data F G, enriched_nat_trans_law a.

Definition enriched_nat_trans_data_from_enriched_nat_trans {A B : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans F G) : ∏ a : A, I --> enriched_cat_mor (F a) (G a) := pr1 a.
Coercion enriched_nat_trans_data_from_enriched_nat_trans : enriched_nat_trans >-> Funclass.

Definition enriched_nat_trans_ax {A B : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans F G) :enriched_nat_trans_law a := pr2 a.

Definition make_enriched_nat_trans {A B : enriched_precat} {F G : enriched_functor A B} a l : enriched_nat_trans F G := (a,, l).

Definition enriched_nat_trans_eq {A B : enriched_precat} {F G : enriched_functor A B} {a a' : enriched_nat_trans F G} : (∏ x : A, a x = a' x) -> a = a'.
Proof.
  intro H.
  use total2_paths_b.
  - apply funextsec.
    assumption.
  - apply proofirrelevance.
    repeat (apply impred_isaprop; intro).
    apply homset_property.
Defined.

Definition enriched_nat_trans_identity {A B : enriched_precat} (F : enriched_functor A B) : enriched_nat_trans F F.
Proof.
  use make_enriched_nat_trans.
  - intro x.
    apply enriched_cat_identity.
  - abstract (intros x y;
    rewrite precompose_identity, postcompose_identity;
    reflexivity).
Defined.

Definition enriched_nat_trans_comp {A B : enriched_precat} {F G H : enriched_functor A B} (a : enriched_nat_trans F G) (b : enriched_nat_trans G H) : enriched_nat_trans F H.
Proof.
  use make_enriched_nat_trans.
  - intro x.
    exact (a x · postcompose_underlying_morphism _ (b x)).
  - abstract (intros x y;
    rewrite postcompose_underlying_morphism_composite;
    rewrite assoc;
    rewrite enriched_nat_trans_ax;
    rewrite assoc';
    rewrite pre_post_compose_commute;
    rewrite assoc;
    rewrite enriched_nat_trans_ax;
    rewrite precompose_underlying_morphism_composite;
    apply assoc').
Defined.

End NatTrans.

Section EnrichedFunctorCategory.

Lemma isaset_enriched_nat_trans {A B : enriched_precat} (F G : enriched_functor A B) : isaset (enriched_nat_trans F G).
Proof.
  apply isaset_total2.
  - apply impred_isaset.
    intro.
    apply homset_property.
  - intro.
    apply isasetaprop.
    repeat (apply impred_isaprop; intro).
    apply homset_property.
Qed.

Lemma enriched_nat_trans_assoc {A B : enriched_precat} {F G H K : enriched_functor A B} (f : enriched_nat_trans F G) (g : enriched_nat_trans G H) (h : enriched_nat_trans H K) : enriched_nat_trans_comp f (enriched_nat_trans_comp g h) = enriched_nat_trans_comp (enriched_nat_trans_comp f g) h.
Proof.
  apply enriched_nat_trans_eq.
  intro x.
  cbn.
  rewrite postcompose_underlying_morphism_composite.
  apply assoc.
Qed.

Definition enriched_functor_precategory_data (A B : enriched_precat) : precategory_data.
Proof.
  use make_precategory_data.
  - use make_precategory_ob_mor.
    + exact (enriched_functor A B).
    + intros F G.
      exact (enriched_nat_trans F G).
  - intros c.
    apply enriched_nat_trans_identity.
  - intros a b c f g.
    exact (enriched_nat_trans_comp f g).
Defined.

Definition enriched_functor_category (A B : enriched_precat) : category.
Proof.
  use make_category.
  - use make_precategory.
    + exact (enriched_functor_precategory_data A B).
    + repeat split;simpl.
      * abstract (intros;
        apply enriched_nat_trans_eq;
        intro;
        cbn;
        rewrite underlying_morphism_compose_swap;
        rewrite precompose_identity;
        apply id_right).
      * abstract (intros;
        apply enriched_nat_trans_eq;
        intro;
        cbn;
        rewrite postcompose_identity;
        apply id_right).
      * abstract (intros;
        apply enriched_nat_trans_assoc).
      * abstract (intros;
        apply pathsinv0;
        apply enriched_nat_trans_assoc).
  - intros a b.
    apply isaset_enriched_nat_trans.
Defined.

End EnrichedFunctorCategory.

Section Whisker.

Definition pre_whisker {A B C : enriched_precat} (F : enriched_functor A B) {G H : enriched_functor B C} (a : enriched_nat_trans G H) : enriched_nat_trans (enriched_functor_comp F G) (enriched_functor_comp F H).
Proof.
  use make_enriched_nat_trans.
  - intro x.
    exact (a (F x)).
  - abstract (intros x y;
    simpl;
    rewrite !assoc';
    apply cancel_precomposition;
    apply enriched_nat_trans_ax).
Defined.

Definition post_whisker {A B C : enriched_precat} {F G : enriched_functor A B} (a : enriched_nat_trans F G) (H : enriched_functor B C) : enriched_nat_trans (enriched_functor_comp F H) (enriched_functor_comp G H).
Proof.
  use make_enriched_nat_trans.
  - intro x.
    exact (a x · enriched_functor_on_morphisms H _ _).
  - abstract (intros x y;
    simpl;
    rewrite !assoc';
    rewrite <- enriched_functor_on_precompose, <- enriched_functor_on_postcompose;
    rewrite !assoc;
    apply cancel_postcomposition;
    apply enriched_nat_trans_ax).
Defined.

End Whisker.

Section Unit.

Definition unit_enriched_precat_data : enriched_precat_data.
Proof.
  use make_enriched_precat_data.
  - exact unit.
  - intros.
    exact (I_{Mon_V}).
  - intros.
    exact (identity _).
  - intros.
    exact (mon_lunitor _).
Defined.

Definition unit_enriched_precat : enriched_precat.
Proof.
  use make_enriched_precat.
  - exact unit_enriched_precat_data.
  - split; cbn.
    + abstract
        (rewrite tensor_id_id ;
         apply id_left).
    + abstract
        (rewrite tensor_id_id ;
         rewrite id_left ;
         apply mon_lunitor_I_mon_runitor_I).
  - abstract
      (intros a b c d ;
       cbn ;
       rewrite !assoc ;
       apply cancel_postcomposition ;
       rewrite mon_lunitor_I_mon_runitor_I ;
       rewrite mon_triangle ;
       rewrite mon_runitor_I_mon_lunitor_I ;
       apply idpath).
Defined.

Definition element_functor_data {A : enriched_precat} (a : A) : enriched_functor_data unit_enriched_precat A.
Proof.
  use make_enriched_functor_data.
  - intro.
    exact a.
  - intros x y.
    induction x, y.
    apply enriched_cat_identity.
Defined.

Definition element_functor_unit_ax {A : enriched_precat} (a : A) : enriched_functor_unit_ax (element_functor_data a).
Proof.
  intro t.
  induction t.
  simpl.
  apply id_left.
Qed.

Definition element_functor_comp_ax {A : enriched_precat} (a : A) : enriched_functor_comp_ax (element_functor_data a).
Proof.
  intros t t' t''.
  induction t, t', t''.
  cbn.
  rewrite tensor_split.
  rewrite !assoc'.
  rewrite enriched_id_left.
  rewrite tensor_lunitor.
  apply idpath.
Qed.

Definition element_functor {A : enriched_precat} (a : A) : enriched_functor unit_enriched_precat A.
Proof.
  use make_enriched_functor.
  - exact (element_functor_data a).
  - exact (element_functor_unit_ax a).
  - exact (element_functor_comp_ax a).
Defined.

End Unit.

End A.

Arguments enriched_precat_data _ : clear implicits.
Arguments enriched_precat _ : clear implicits.
Arguments enriched_functor_data {_} _ _.
Arguments enriched_functor {_} _ _.
Arguments unit_enriched_precat _ : clear implicits.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.SepLocals.
Require Import Rupicola.Lib.ControlFlow.CondSwap.
Require Import Rupicola.Lib.ControlFlow.DownTo.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Interface.Compilation.
Require Import Crypto.Bedrock.Group.Point.
Require Import Crypto.Bedrock.Group.ScalarMult.LadderStep.
Require Import Crypto.Bedrock.ScalarField.Interface.Compilation.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Bedrock.Specs.ScalarField.
Require Import Crypto.Util.NumTheoryUtil.
Local Open Scope Z_scope.

Section __.
  Context {semantics : Semantics.parameters}
          {semantics_ok : Semantics.parameters_ok semantics}.
  Context {field_parameters : FieldParameters}
          {scalar_field_parameters : ScalarFieldParameters}.
  Context {scalar_field_parameters_ok : ScalarFieldParameters_ok}.
  Context {field_representaton : FieldRepresentation}
          {scalar_representation : ScalarRepresentation}.
  Context {field_representation_ok : FieldRepresentation_ok}.
  Existing Instances spec_of_mul spec_of_square spec_of_add
           spec_of_sub spec_of_scmula24 spec_of_inv spec_of_felem_copy
           spec_of_felem_small_literal spec_of_sctestbit
           spec_of_ladderstep.
  Hint Resolve @relax_bounds : core.

  Section Gallina.
    Local Open Scope F_scope.

    Definition montladder_gallina
               (scalarbits : Z) (testbit:nat ->bool) (u:F M_pos)
      : F M_pos :=
      let/d P1 := (1, 0) in
      let/d P2 := (u, 1) in
      let/d swap := false in
      let/d count := scalarbits in
      let/d ''(P1, P2, swap) :=
         downto
           (P1, P2, swap) (* initial state *)
           (Z.to_nat count)
           (fun state i =>
              let '(P1, P2, swap) := state in
              let/d s_i := testbit i in
              let/d swap := xorb swap s_i in
              let/d ''(P1, P2) := cswap swap P1 P2 in
              let/d ''(P1, P2) := ladderstep_gallina u P1 P2 in
              let/d swap := s_i in
              (P1, P2, swap)
           ) in
      let/d ''(P1, P2) := cswap swap P1 P2 in
      let '(x, z) := P1 in
      let/d r := F.inv z in
      let/d r := (x * r) in
      r.
  End Gallina.

  Section MontLadder.
    Context (scalarbits_small : word.wrap scalarbits = scalarbits).

    Definition MontLadderResult
               (K : scalar)
               (pOUT pK pU pX1 pZ1 pX2 pZ2 pA pAA pB pBB pE pC pD pDA pCB: Semantics.word)
               (result : F M_pos)
      : list word -> Semantics.mem -> Prop :=
      fun _ =>
      (liftexists OUT : felem,
         (emp (result = feval OUT /\ bounded_by tight_bounds OUT)
          * (FElem pOUT OUT * Scalar pK K * Placeholder pU
             * Placeholder pX1 * Placeholder pZ1
             * Placeholder pX2 * Placeholder pZ2
             * Placeholder pA * Placeholder pAA
             * Placeholder pB * Placeholder pBB
             * Placeholder pE * Placeholder pC * Placeholder pD
             * Placeholder pDA * Placeholder pCB))%sep).

    Instance spec_of_montladder : spec_of "montladder" :=
      forall! (K : scalar) (U : felem) (* input *)
            (pOUT pK pU pX1 pZ1 pX2 pZ2
                  pA pAA pB pBB pE pC pD pDA pCB : Semantics.word),
        (fun R m =>
           bounded_by tight_bounds U
           /\ (Placeholder pOUT * Scalar pK K * FElem pU U
               * Placeholder pX1 * Placeholder pZ1
               * Placeholder pX2 * Placeholder pZ2
               * Placeholder pA * Placeholder pAA
               * Placeholder pB * Placeholder pBB
               * Placeholder pE * Placeholder pC
               * Placeholder pD * Placeholder pDA
               * Placeholder pCB * R)%sep m)
          ===>
          "montladder" @
          [pOUT; pK; pU; pX1; pZ1; pX2; pZ2; pA; pAA; pB; pBB; pE; pC; pD; pDA; pCB]
          ===>
          (MontLadderResult
             K pOUT pK pU pX1 pZ1 pX2 pZ2 pA pAA pB pBB pE pC pD pDA pCB
             (montladder_gallina
                scalarbits
                (fun i => Z.testbit (F.to_Z (sceval K)) (Z.of_nat i))
                (feval U))).

    Ltac apply_compile_cswap_nocopy :=
      simple eapply compile_cswap_nocopy with
        (Data :=
           fun p (X : F _) =>
             (Lift1Prop.ex1
                (fun x =>
                   (emp (feval x = X) * FElem p x)%sep)))
        (tmp:="tmp");
      [ lazymatch goal with
        | |- sep _ _ _ =>
          repeat lazymatch goal with
                 | |- Lift1Prop.ex1 _ _ => eexists
                 | |- feval _ = _ => eassumption
                 | _ => progress sepsimpl
                 end; ecancel_assumption
        | _ => idtac
        end .. | ];
      [ repeat compile_step .. | ];
      [ try congruence .. | ].

    Ltac compile_custom ::=
      gen_sym_inc;
      let name := gen_sym_fetch "v" in
      cleanup;
      first [ simple eapply compile_downto
            | simple eapply compile_sctestbit with (var:=name)
            | simple eapply compile_point_assign
            | simple eapply compile_felem_small_literal
            | simple eapply compile_felem_copy
            | simple eapply compile_cswap_pair
            | apply_compile_cswap_nocopy ].

    Definition downto_inv
               swap_var X1_var Z1_var X2_var Z2_var K_var
               K K_ptr X1_ptr Z1_ptr X2_ptr Z2_ptr Rl
               A_ptr AA_ptr B_ptr BB_ptr E_ptr C_ptr D_ptr DA_ptr CB_ptr
               (locals : Semantics.locals)
               (_ : nat)
               (gst : bool)
               (st : point * point * bool)
               (_ : list word)
      : Semantics.mem -> Prop :=
      let P1 := fst (fst st) in
      let P2 := snd (fst st) in
      let swap := snd st in
      let x1 := fst P1 in
      let z1 := snd P1 in
      let x2 := fst P2 in
      let z2 := snd P2 in
      let swapped := gst in
      liftexists X1_ptr' Z1_ptr' X2_ptr' Z2_ptr'
                 X1 Z1 X2 Z2,
        (emp (bounded_by tight_bounds X1
              /\ bounded_by tight_bounds Z1
              /\ bounded_by tight_bounds X2
              /\ bounded_by tight_bounds Z2
              /\ feval X1 = x1
              /\ feval Z1 = z1
              /\ feval X2 = x2
              /\ feval Z2 = z2
              /\ (if swapped
                  then (X1_ptr' = X2_ptr
                        /\ Z1_ptr' = Z2_ptr
                        /\ X2_ptr' = X1_ptr
                        /\ Z2_ptr' = Z1_ptr)
                  else (X1_ptr' = X1_ptr
                        /\ Z1_ptr' = Z1_ptr
                        /\ X2_ptr' = X2_ptr
                        /\ Z2_ptr' = Z2_ptr))
              /\ (Var swap_var (word.of_Z (Z.b2z swap)) * Var K_var K_ptr
                  * Var X1_var X1_ptr' * Var Z1_var Z1_ptr'
                  * Var X2_var X2_ptr' * Var Z2_var Z2_ptr'
                  * Rl)%sep locals)
         * (Scalar K_ptr K * FElem X1_ptr' X1 * FElem Z1_ptr' Z1
            * FElem X2_ptr' X2 * FElem Z2_ptr' Z2
            * Placeholder A_ptr * Placeholder AA_ptr
            * Placeholder B_ptr * Placeholder BB_ptr
            * Placeholder E_ptr * Placeholder C_ptr
            * Placeholder D_ptr * Placeholder DA_ptr
            * Placeholder CB_ptr))%sep.

    Definition downto_ghost_step
               (K : scalar) (st : point * point * bool)
               (gst : bool) (i : nat) :=
      let swap := snd st in
      let swap := xorb swap (Z.testbit (F.to_Z (sceval K)) (Z.of_nat i)) in
      xorb gst swap.

    Ltac setup_downto_inv_init :=
      lift_eexists; sepsimpl;
      (* first fill in any map.get goals where we know the variable names *)
      lazymatch goal with
      | |- map.get _ ?x = Some _ =>
        tryif is_evar x then idtac
        else (autorewrite with mapsimpl; reflexivity)
      | _ => idtac
      end;
      lazymatch goal with
      | |- (_ * _)%sep _ => ecancel_assumption
      | _ => idtac
      end.

    Ltac solve_downto_inv_subgoals :=
      lazymatch goal with
      | |- map.get _ _ = _ => subst_lets_in_goal; solve_map_get_goal
      | |- bounded_by _ _ => solve [ auto ]
      | |- feval _ = _ =>
        subst_lets_in_goal; first [ reflexivity | assumption ]
      | |- ?x = ?x => reflexivity
      | |- ?x => fail "unrecognized side condition" x
      end.

    Lemma feval_fst_cswap s a b A B :
      feval a = A -> feval b = B ->
      feval (fst (cswap s a b)) = fst (cswap s A B).
    Proof. destruct s; cbn; auto. Qed.

    Lemma feval_snd_cswap s a b A B :
      feval a = A -> feval b = B ->
      feval (snd (cswap s a b)) = snd (cswap s A B).
    Proof. destruct s; cbn; auto. Qed.

    (* Adding word.unsigned_of_Z_1 and word.unsigned_of_Z_0 as hints to
       compiler doesn't work, presumably because of the typeclass
       preconditions. This is a hacky workaround. *)
    (* TODO: figure out a cleaner way to do this *)
    Lemma unsigned_of_Z_1 : word.unsigned (word.of_Z 1) = 1.
    Proof. exact word.unsigned_of_Z_1. Qed.
    Lemma unsigned_of_Z_0 : word.unsigned (word.of_Z 0) = 0.
    Proof. exact word.unsigned_of_Z_0. Qed.
    Hint Resolve unsigned_of_Z_0 unsigned_of_Z_1 : compiler.

    Ltac safe_compile_step :=
      compile_step;
      (* first pass fills in some evars *)
      [ repeat compile_step .. | idtac ];
      (* second pass must solve *)
      [ first [ solve [repeat compile_step]
              | solve [straightline_map_solver_locals] ] .. | idtac ].

    Ltac solve_field_subgoals_with_cswap :=
      lazymatch goal with
      | |- map.get _ _ = Some _ =>
        solve [subst_lets_in_goal; solve_map_get_goal]
      | |- feval _ = _ =>
        solve [eauto using feval_fst_cswap, feval_snd_cswap]
      | |- bounded_by _ (fst (cswap _ _ _)) =>
        apply cswap_cases_fst; solve [auto]
      | |- bounded_by _ (snd (cswap _ _ _)) =>
        apply cswap_cases_snd; solve [auto]
      | _ => idtac
      end; solve [eauto].

    (* create a new evar to take on the second swap clause *)
    Ltac rewrite_cswap_iff1_with_evar_frame :=
      match goal with
        |- (?P * ?R)%sep _ =>
        match P with context [cswap] => idtac end;
        is_evar R;
        let R1 := fresh "R" in
        let R2 := fresh "R" in
        evar (R1 : Semantics.mem -> Prop);
        evar (R2 : Semantics.mem -> Prop);
        unify R (sep R1 R2);
        seprewrite (cswap_iff1 FElem)
      end.

    Ltac safe_field_compile_step :=
      field_compile_step;
      lazymatch goal with
      | |- sep _ ?R _ =>
        tryif is_evar R
        then (repeat rewrite_cswap_iff1_with_evar_frame)
        else (repeat seprewrite (cswap_iff1 FElem));
        ecancel_assumption
      | _ => idtac
      end;
      lazymatch goal with
      | |- context [WeakestPrecondition.cmd] => idtac
      | _ => solve_field_subgoals_with_cswap
      end.

    Derive montladder_body SuchThat
           (let args := ["OUT"; "K"; "U"; "X1"; "Z1"; "X2"; "Z2";
                           "A"; "AA"; "B"; "BB"; "E"; "C"; "D"; "DA"; "CB"] in
            let montladder := ("montladder", (args, [], montladder_body)) in
            program_logic_goal_for
              montladder
              (ltac:(
                 let callees :=
                     constr:([felem_small_literal; felem_copy;
                                "ladderstep";
                                sctestbit; inv; mul]) in
                 let x := program_logic_goal_for_function
                                montladder callees in
                     exact x)))
           As montladder_body_correct.
    Proof.
      cbv [program_logic_goal_for spec_of_montladder].
      pose proof scalarbits_pos.
      setup. cbv [F.one F.zero]. (* expose F.of_Z *)

      (* prevent things from getting stored in pOUT *)
      hide pOUT.

      repeat safe_compile_step.

      let i_var := gen_sym_fetch "v" in (* last used variable name *)
      let locals := lazymatch goal with
                    | |- WeakestPrecondition.cmd _ _ _ _ ?l _ => l end in
      remember locals as L;
      evar (l : map.rep (map:=Semantics.locals));
        let Hl := fresh in
        assert (map.remove L i_var = l) as Hl by
              (subst L; push_map_remove; subst_lets_in_goal; reflexivity);
          subst l;
          match type of Hl with
          | _ = ?l =>
            sep_from_literal_locals l;
              match goal with H : sep _ _ l |- _ =>
                              rewrite <-Hl in H; clear Hl
              end
          end.

      let tmp_var := constr:("tmp") in
      let x1_var := constr:("X1") in
      let z1_var := constr:("Z1") in
      let x2_var := constr:("X2") in
      let z2_var := constr:("Z2") in
      let counter_var := gen_sym_fetch "v" in
      let locals := lazymatch goal with
                    | |- WeakestPrecondition.cmd _ _ _ _ ?l _ => l end in
        simple eapply compile_downto with
            (wcount := word.of_Z scalarbits)
            (ginit := false)
            (i_var := counter_var)
            (ghost_step := downto_ghost_step K)
            (Inv :=
               downto_inv
                 _ x1_var z1_var x2_var z2_var _
                 _ pK pX1 pZ1 pX2 pZ2
                 _ pA pAA pB pBB pE pC pD pDA pCB);
          [ .. | subst L | subst L ].
      { cbv [downto_inv].
        setup_downto_inv_init.
        all:solve_downto_inv_subgoals. }
      { subst. autorewrite with mapsimpl.
        reflexivity. }
      { rewrite word.unsigned_of_Z, Z2Nat.id by lia;
          solve [eauto using scalarbits_small]. }
      { subst_lets_in_goal. lia. }
      { (* loop body *)
        intros. clear_old_seps.
        match goal with gst' := downto_ghost_step _ _ _ _ |- _ =>
                                subst gst' end.
        destruct_products.
        cbv [downto_inv] in * |-. sepsimpl_hyps.
        eexists; intros.

        (* convert locals back to literal map using the separation-logic
           condition; an alternative would be to have all lemmas play nice with
           locals in separation logic *)
        match goal with H : sep _ _ (map.remove _ ?i_var)
                        |- context [map.get _ ?i_var = Some ?wi] =>
                        eapply Var_put_remove with (v:=wi) in H;
                          eapply sep_assoc in H
        end.
        literal_locals_from_sep.

        repeat safe_compile_step.

        simple eapply compile_ladderstep.
        (* first, resolve evars *)
        all:lazymatch goal with
            | |- feval _ = _ =>
              solve [eauto using feval_fst_cswap, feval_snd_cswap]
            | _ => idtac
            end.
        (* *after* evar resolution *)
        all:lazymatch goal with
            | |- sep _ _ _ =>
              repeat seprewrite (cswap_iff1 FElem);
                ecancel_assumption
            | |- context [WeakestPrecondition.cmd] => idtac
            | _ => solve_field_subgoals_with_cswap
            end.

        repeat safe_compile_step.

        (* TODO: use nlet to do this rename automatically *)
        let locals := lazymatch goal with
                      | |- WeakestPrecondition.cmd _ _ _ _ ?l _ => l end in
        let b := lazymatch goal with x := xorb ?b _ |- _ => b end in
        let swap_var := lazymatch locals with
                          context [map.put _ ?x (word.of_Z (Z.b2z b))] => x end in
        eapply compile_rename_bool with (var := swap_var);
          [ solve [repeat compile_step] .. | ].
        intro.

        (* unset loop-local variables *)
        repeat remove_unused_var.

        compile_done.
        { (* prove locals postcondition *)
          autorewrite with mapsimpl.
          ssplit; [ | reflexivity ].
          subst_lets_in_goal. reflexivity. }
        { (* prove loop invariant held *)
          cbv [downto_inv downto_ghost_step].
          cbv [LadderStepResult] in *.
          cleanup; sepsimpl_hyps.
          repeat match goal with
                 | H : ?x = (_, _) |- context [fst ?x] =>
                   rewrite H; progress cbn [fst snd]
                 end.
          clear_old_seps.
          lift_eexists. sepsimpl.
          (* first, resolve evars *)
          all:lazymatch goal with
              | |- @sep _ _ Semantics.mem _ _ _ =>
                repeat seprewrite FElem_from_bytes;
                repeat (sepsimpl; lift_eexists);
                ecancel_assumption
              | |- @sep _ _ Semantics.locals _ _ ?locals =>
                subst_lets_in_goal; push_map_remove;
                  let locals := match goal with |- ?P ?l => l end in
                  sep_from_literal_locals locals;
                    ecancel_assumption
              | _ => idtac
              end.
          (* now solve other subgoals *)
          all:subst_lets_in_goal; eauto.
          match goal with
          | H : if ?gst then _ else _ |-
            if xorb ?gst ?x then _ else _ =>
            destr gst; cleanup; subst;
              cbn [xorb]; destr x
          end.
          all:cbn [cswap fst snd]; ssplit; reflexivity. } }
      { (* loop done; rest of function *)
        intros. destruct_products.
        cbv [downto_inv downto_inv] in *.
        sepsimpl_hyps.

        (* convert locals back to literal map using the separation-logic
           condition; an alternative would be to have all lemmas play nice with
           locals in separation logic *)
        match goal with H : sep _ _ (map.remove _ ?i_var),
                            Hget : map.get _ ?i_var = Some ?wi |- _ =>
                        eapply Var_put_remove with (v:=wi) in H;
                          eapply sep_assoc in H;
                          rewrite map.put_noop in H by assumption
        end.
        literal_locals_from_sep.

        repeat safe_compile_step. (cbv match zeta beta).

        subst_lets_in_goal. erewrite <-!feval_fst_cswap by eauto.
        safe_field_compile_step. safe_compile_step.

        (* the output of this last operation needs to be stored in the pointer
           for the output, so we guide the automation to the right pointer *)
        clear_old_seps.
        repeat lazymatch goal with
               | H : sep _ _ _ |- _ =>
                 seprewrite_in FElem_from_bytes H
               end.
        sepsimpl.
        unhide pOUT.

        safe_field_compile_step.
        repeat safe_compile_step.
        compile_done. cbv [MontLadderResult].
        (* destruct the hypothesis identifying the new pointers as some swapping
           of the original ones *)
        destruct_one_match_hyp_of_type bool.
        all:cleanup; subst.
        all:lift_eexists.
        all:sepsimpl; [ solve [eauto] .. | ].
        all:repeat seprewrite FElem_from_bytes.
        all:repeat (sepsimpl; lift_eexists).
        all:ecancel_assumption. }
    Qed.
  End MontLadder.
End __.

Local Coercion expr.var : string >-> Syntax.expr.
Local Unset Printing Coercions.
Redirect "Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder.montladder_body" Print montladder_body.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m2e32m977_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import VCF.BoubakiWitt.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import Equivalence.
Require Import Morphisms.
Require Import Classical.
Require Import List.
Require Import Psatz.

Module Rel.

Definition id {A: Type}: A -> A -> Prop := fun a b => a = b.

Definition concat {A B C: Type} (r1: A -> B -> Prop) (r2: B -> C -> Prop): A -> C -> Prop :=
  fun a c => exists b, r1 a b /\ r2 b c.

Definition filter1 {A B: Type} (f: A -> Prop): A -> B -> Prop :=
  fun a b => f a.

Definition filter2 {A B: Type} (f: B -> Prop): A -> B -> Prop :=
  fun a b => f b.

Definition test {A} (X: A -> Prop): A -> A -> Prop :=
  fun st1 st2 => st1 = st2 /\ X st1.

Definition dia {A B: Type} (X: A -> B -> Prop) (Y: B -> Prop): A -> Prop :=
  fun a => exists b, X a b /\ Y b.

End Rel.

Lemma Rel_test_congr A:
  Proper (Sets.equiv ==> Sets.equiv) (@Rel.test A).
Proof.
  unfold Proper, respectful, Rel.test; unfold_SETS_tac no_extra_simplify.
  intros X Y ?.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Rel_concat_congr {A B C}:
  Proper (Sets.equiv ==> Sets.equiv ==> Sets.equiv) (@Rel.concat A B C).
Proof.
  unfold Proper, respectful, Rel.concat; unfold_SETS_tac no_extra_simplify.
  intros X1 X2 ? Y1 Y2 ?.
  intros a c.
  unfold iff.
  split.
  + intros [b [? ?]].
    exists b.
    rewrite <- H, <- H0.
    tauto.
  + intros [b [? ?]].
    exists b.
    rewrite H, H0.
    tauto.
Qed.

Lemma Rel_dia_congr A B:
  Proper (Sets.equiv ==> Sets.equiv ==> Sets.equiv) (@Rel.dia A B).
Proof.
  unfold Proper, respectful, Rel.dia; unfold_SETS_tac no_extra_simplify.
  intros.
  apply Morphisms_Prop.ex_iff_morphism; intros ?.
  rewrite H, H0.
  tauto.
Qed.

Lemma Rel_concat_mono {A B C}:
  Proper (Sets.included ==> Sets.included ==> Sets.included) (@Rel.concat A B C).
Proof.
  unfold Proper, respectful, Rel.concat; unfold_SETS_tac no_extra_simplify.
  intros X1 X2 ? Y1 Y2 ?.
  intros a c [b [? ?]].
  exists b.
  auto.
Qed.

Lemma Rel_dia_mono A B:
  Proper (Sets.included ==> Sets.included ==> Sets.included) (@Rel.dia A B).
Proof.
  unfold Proper, respectful, Rel.dia; unfold_SETS_tac no_extra_simplify.
  intros.
  destruct H1 as [b [? ?]]; exists b.
  auto.
Qed.

Lemma Rel_concat_id: forall A B (r: A -> B -> Prop),
  Sets.equiv (Rel.concat r Rel.id) r.
Proof.
  intros.
  unfold Rel.concat, Rel.id; unfold_SETS_tac no_extra_simplify.
  intros.
  split; intros.
  + destruct H as [? [? ?]].
    subst.
    auto.
  + exists a0; auto.
Qed.

Lemma Rel_dia_empty: forall A B (r: A -> B -> Prop),
  Sets.equiv (Rel.dia r Sets.empty) Sets.empty.
Proof.
  intros.
  unfold Rel.dia; unfold_SETS_tac no_extra_simplify.
  intros.
  split; intros.
  + destruct H as [? [? ?]].
    tauto.
  + tauto.
Qed.

Existing Instances Rel_test_congr
                   Rel_concat_congr
                   Rel_dia_congr
                   Rel_concat_mono
                   Rel_dia_mono.

Lemma fold_right_concat_iff: forall A rs r (x z: A),
  fold_right Rel.concat r rs x z ->
  exists y, fold_right Rel.concat Rel.id rs x y /\ r y z.
Proof.
  intros.
  revert x z H; induction rs; intros; simpl in H |- *.
  + exists x; split; auto.
    unfold Rel.id; auto.
  + destruct H as [a' [? ?]].
    apply IHrs in H0.
    destruct H0 as [y [? ?]].
    exists y; split.
    - exists a'; auto.
    - auto.
Qed.

Ltac BinRel_solve_mono :=
  idtac;
  match goal with
  | |- Sets.included (Rel.concat _ _) (Rel.concat _ _) =>
         refine (Rel_concat_mono _ _ _ _ _ _); solve_mono BinRel_solve_mono
  | |- _ => idtac
  end.