(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat seq div path fintype.
From mathcomp
Require Import bigop finset prime fingroup morphism perm automorphism quotient.
From mathcomp
Require Import action gproduct gfunctor pgroup cyclic center commutator.
From mathcomp
Require Import gseries nilpotent sylow abelian maximal hall.
From odd_order
Require Import BGsection1 BGsection3 BGsection4 BGsection5 BGsection6.
From odd_order
Require Import BGsection7 BGsection10.

(******************************************************************************)
(*   This file covers B & G, section 11; it has only one definition:          *)
(*    exceptional_FTmaximal p M A0 A <=>                                      *)
(*      p, M and A0 satisfy the conditions of Hypothesis 11.1 in B & G, i.e., *)
(*      M is an "exceptional" maximal subgroup in the terminology of B & G.   *)
(*      In addition, A is elementary abelian p-subgroup of M of rank 2, that  *)
(*      contains A0. The existence of A is guaranteed by Lemma 10.5, but as   *)
(*      in the only two lemmas that make use of the results in this section   *)
(*      (Lemma 12.3 and Theorem 12.5) A is known, we elected to make the      *)
(*      dependency on A explicit.                                             *)
(******************************************************************************)

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

Import GroupScope.

Section Section11.

Variable gT : minSimpleOddGroupType.
Local Notation G := (TheMinSimpleOddGroup gT).

Implicit Types p q r : nat.
Implicit Types A E H K M N P Q R S T U V W X Y : {group gT}.

Variables (p : nat) (M A0 A P : {group gT}).

(* This definition corresponsd to Hypothesis 11.1, where the condition on A   *)
(* has been made explicit.                                                    *)
Definition exceptional_FTmaximal :=
  [/\ p \in \sigma(M)^', A \in 'E_p^2(M), A0 \in 'E_p^1(A) & 'N(A0) \subset M].

Hypotheses (maxM : M \in 'M) (excM : exceptional_FTmaximal).
Hypotheses (sylP : p.-Sylow(M) P) (sAP : A \subset P).

(* Splitting the excM hypothesis. *)
Let sM'p : p \in \sigma(M)^'. Proof. by case: excM. Qed.
Let Ep2A : A \in 'E_p^2(M). Proof. by case: excM. Qed.
Let Ep1A0 : A0 \in 'E_p^1(A). Proof. by case: excM. Qed.
Let sNA0_M : 'N(A0) \subset M. Proof. by case: excM. Qed.

(* Arithmetics of p. *)
Let p_pr : prime p := pnElem_prime Ep2A.
Let p_gt1 : p > 1 := prime_gt1 p_pr.
Let p_gt0 : p > 0 := prime_gt0 p_pr.

(* Group orders. *)
Let oA : #|A| = (p ^ 2)%N := card_pnElem Ep2A.
Let oA0 : #|A0| = p := card_pnElem Ep1A0.

(* Structure of A. *)
Let abelA : p.-abelem A. Proof. by case/pnElemP: Ep2A. Qed.
Let pA : p.-group A := abelem_pgroup abelA.
Let cAA : abelian A := abelem_abelian abelA.

(* Various set inclusions. *)
Let sA0A : A0 \subset A. Proof. by case/pnElemP: Ep1A0. Qed.
Let sPM : P \subset M := pHall_sub sylP.
Let sAM : A \subset M := subset_trans sAP sPM.
Let sCA0_M : 'C(A0) \subset M := subset_trans (cent_sub A0) sNA0_M.
Let sCA_M : 'C(A) \subset M := subset_trans (centS sA0A) sCA0_M.

(* Alternative E_p^1 memberships for A0; the first is the one used to state   *)
(* Hypothesis 11.1 in B & G, the second is the form expected by Lemma 10.5.   *)
(* Note that #|A0| = p (oA0 above) would wokr just as well.                   *)
Let Ep1A0_M : A0 \in 'E_p^1(M) := subsetP (pnElemS p 1 sAM) A0 Ep1A0.
Let Ep1A0_G : A0 \in 'E_p^1(G) := subsetP (pnElemS p 1 (subsetT M)) A0 Ep1A0_M.

(* This does not depend on exceptionalM, and could move to Section 10. *)
Lemma sigma'_Sylow_contra : p \in \sigma(M)^' -> ~~ ('N(P) \subset M).
Proof. by apply: contra => sNM; apply/exists_inP; exists P. Qed.

(* First preliminary remark of Section 11; only depends on sM'p and sylP. *)
Let not_sNP_M: ~~ ('N(P) \subset M) := sigma'_Sylow_contra sM'p.

(* Second preliminary remark of Section 11; only depends on sM'p, Ep1A0_M,    *)
(* and sNA0_M.                                                                *)
Lemma p_rank_exceptional : 'r_p(M) = 2.
Proof. exact: sigma'_norm_mmax_rank2 (pgroupS sA0A pA) _. Qed.
Let rM := p_rank_exceptional.

(* Third preliminary remark of Section 11. *)
Lemma exceptional_pmaxElem : A \in 'E*_p(G).
Proof.
have [_ _ dimA]:= pnElemP Ep2A.
apply/pmaxElemP; split=> [|E EpE sAE]; first by rewrite !inE subsetT.
have [//|ltAE]: A :=: E \/ A \proper E := eqVproper sAE.
have [_ abelE] := pElemP EpE; have [pE cEE _] := and3P abelE.
suffices: logn p #|E| <= 'r_p(M) by rewrite leqNgt rM -dimA properG_ltn_log.
by rewrite logn_le_p_rank // inE (subset_trans cEE) ?(subset_trans (centS sAE)).
Qed.
Let EpmA := exceptional_pmaxElem.

(* This is B & G, Lemma 11.1. *)
Lemma exceptional_TIsigmaJ g q Q1 Q2 :
    g \notin M -> A \subset M :^ g ->
    q.-Sylow(M`_\sigma) Q1 ->  A \subset 'N(Q1) ->
    q.-Sylow(M`_\sigma :^ g) Q2 -> A \subset 'N(Q2) ->
     (*a*) Q1 :&: Q2 = 1
  /\ (*b*) (forall X, X \in 'E_p^1(A) -> 'C_Q1(X) = 1 \/ 'C_Q2(X) = 1).
Proof.
move=> notMg sAMg sylQ1 nQ1A sylQ2 nQ2A.
have [-> | ntQ1] := eqsVneq Q1 1.
  by split=> [|? _]; last left; apply: (setIidPl (sub1G _)).
have [sQ1Ms qQ1 _] := and3P sylQ1.
have{qQ1} [q_pr q_dv_Q1 _] := pgroup_pdiv qQ1 ntQ1.
have{sQ1Ms q_dv_Q1} sMq: q \in \sigma(M).
  exact: pgroupP (pgroupS sQ1Ms (pcore_pgroup _ _)) q q_pr q_dv_Q1.
have{} sylQ1: q.-Sylow(M) Q1.
  by rewrite (subHall_Sylow (Msigma_Hall maxM)).
have sQ1M := pHall_sub sylQ1.
have{sylQ2} sylQ2g': q.-Sylow(M) (Q2 :^ g^-1).
  by rewrite (subHall_Sylow (Msigma_Hall _)) // -(pHallJ2 _ _ _ g) actKV.
have sylQ2: q.-Sylow(G) Q2.
  by rewrite -(pHallJ _ _ (in_setT g^-1)) (sigma_Sylow_G maxM).
suffices not_Q1_CA_Q2: gval Q2 \notin Q1 :^: 'O_\pi(A)^'('C(A)).
  have ncA: normed_constrained A.
    have ntA: A :!=: 1 by rewrite -cardG_gt1 oA (ltn_exp2l 0).
    exact: plength_1_normed_constrained ntA EpmA (mFT_proper_plength1 _).
  have q'A: q \notin \pi(A).
    by apply: contraL sMq; move/(pnatPpi pA); move/eqnP->.
  have maxnAq Q: q.-Sylow(G) Q -> A \subset 'N(Q) -> Q \in |/|*(A; q).
    move=> sylQ; case/(max_normed_exists (pHall_pgroup sylQ)) => R maxR sQR.
    have [qR _] := mem_max_normed maxR.
    by rewrite -(group_inj (sub_pHall sylQ qR sQR (subsetT R))).
  have maxQ1 := maxnAq Q1 (sigma_Sylow_G maxM sMq sylQ1) nQ1A.
  have maxQ2 := maxnAq Q2 sylQ2 nQ2A.
  have transCAQ := normed_constrained_meet_trans ncA q'A _ _ maxQ1 maxQ2.
  split=> [|X EpX].
    apply: contraNeq not_Q1_CA_Q2 => ntQ12; apply/imsetP.
    apply: transCAQ (sAM) (mmax_proper maxM) _ _.
      by rewrite (setIidPl sQ1M).
    by apply: contraNneq ntQ12 => tiQ2M; rewrite setIC -subG1 -tiQ2M setIS.
  apply/pred2P; apply: contraR not_Q1_CA_Q2; case/norP=> ntCQ1 ntCQ2.
  have [sXA _ oX] := pnElemPcard EpX.
  apply/imsetP; apply: transCAQ (centSS _ sXA cAA) _ ntCQ1 ntCQ2 => //.
  by rewrite mFT_cent_proper // -cardG_gt1 oX prime_gt1.
apply: contra notMg; case/imsetP=> k cAk defQ2.
have{cAk} Mk := subsetP sCA_M k (subsetP (pcore_sub _ _) k cAk).
have{k Mk defQ2} sQ2M: Q2 \subset M by rewrite defQ2 conj_subG.
have [sQ2g'M qQ2g' _] := and3P sylQ2g'.
by rewrite (sigma_Sylow_trans _ sylQ2g') // actKV.
Qed.

(* This is B & G, Corollary 11.2. *)
Corollary exceptional_TI_MsigmaJ g :
  g \notin M -> A \subset M :^ g ->
    (*a*) M`_\sigma :&: M :^ g = 1
 /\ (*b*) M`_\sigma :&: 'C(A0 :^ g) = 1.
Proof.
move=> notMg sAMg; set Ms := M`_\sigma; set H := [group of Ms :&: M :^ g].
have [H1 | ntH] := eqsVneq H 1.
  by split=> //; apply/trivgP; rewrite -H1 setIS //= centJ conjSg.
pose q := pdiv #|H|.
suffices: #|H|`_q == 1%N by rewrite p_part_eq1 pi_pdiv cardG_gt1 ntH.
have nsMsM: Ms <| M := pcore_normal _ _; have [_ nMsM] := andP nsMsM.
have sHMs: H \subset Ms := subsetIl _ _.
have sHMsg: H \subset Ms :^ g.
  rewrite -sub_conjgV (sub_Hall_pcore (Msigma_Hall _)) //.
    by rewrite pgroupJ (pgroupS sHMs) ?pcore_pgroup.
  by rewrite sub_conjgV subsetIr.
have nMsA := subset_trans sAM nMsM.
have nHA: A \subset 'N(H) by rewrite normsI // normsG.
have nMsgA: A \subset 'N(Ms :^ g) by rewrite normJ (subset_trans sAMg) ?conjSg.
have coMsA: coprime #|Ms| #|A|.
  by rewrite oA coprimeXr ?(pnat_coprime (pcore_pgroup _ _)) ?pnatE.
have coHA: coprime #|H| #|A| := coprimeSg sHMs coMsA.
have coMsgA: coprime #|Ms :^ g| #|A| by rewrite cardJg.
have solA: solvable A := abelian_sol cAA.
have [Q0 sylQ0 nQ0A] := sol_coprime_Sylow_exists q solA nHA coHA.
have [sQ0H qQ0 _] := and3P sylQ0.
have supQ0 := sol_coprime_Sylow_subset _ _ solA (subset_trans sQ0H _) qQ0 nQ0A.
have [Q1 [sylQ1 nQ1A sQ01]] := supQ0 _ nMsA coMsA sHMs.
have [Q2 [sylQ2 nQ2A sQ02]] := supQ0 _ nMsgA coMsgA sHMsg.
have tiQ12: Q1 :&: Q2 = 1.
  by have [-> _] := exceptional_TIsigmaJ notMg sAMg sylQ1 nQ1A sylQ2 nQ2A.
by rewrite -(card_Hall sylQ0) -trivg_card1 -subG1 -tiQ12 subsetI sQ01.
Qed.

(* This is B & G, Theorem 11.3. *)
Theorem exceptional_sigma_nil : nilpotent M`_\sigma.
Proof.
have [g nPg notMg] := subsetPn not_sNP_M.
set Ms := M`_\sigma; set F := Ms <*> A0 :^ g.
have sA0gM: A0 :^ g \subset M.
  by rewrite (subset_trans _ sPM) // -(normP nPg) conjSg (subset_trans sA0A).
have defF: Ms ><| A0 :^ g = F.
  rewrite sdprodEY ?coprime_TIg //.
    by rewrite (subset_trans sA0gM) ?gFnorm.
  by rewrite cardJg oA0 (pnat_coprime (pcore_pgroup _ _)) ?pnatE.
have regA0g: 'C_Ms(A0 :^ g) = 1.
  case/exceptional_TI_MsigmaJ: notMg => //.
  by rewrite -sub_conjgV (subset_trans _ sPM) // sub_conjgV (normP _).
rewrite (prime_Frobenius_sol_kernel_nil defF) ?cardJg ?oA0 //.
by rewrite (solvableS _ (mmax_sol maxM)) // join_subG pcore_sub.
Qed.

(* This is B & G, Corollary 11.4. *)
Corollary exceptional_sigma_uniq H :
  H \in 'M(A) -> H`_\sigma :&: M `_\sigma != 1 -> H :=: M.
Proof.
rewrite setIC => /setIdP[maxH sAH] ntMsHs.
have [g _ defH]: exists2 g, g \in G & H :=: M :^ g.
  apply/imsetP; apply: contraR ntMsHs => /sigma_disjoint[] // _ _.
  by case/(_ exceptional_sigma_nil)=> ->.
rewrite defH conjGid //; apply: contraR ntMsHs => notMg.
have [|tiMsMg _] := exceptional_TI_MsigmaJ notMg; first by rewrite -defH.
by rewrite -subG1 -tiMsMg -defH setIS ?pcore_sub.
Qed.

(* This is B & G, Theorem 11.5. *)
Theorem exceptional_Sylow_abelian P1 : p.-Sylow(M) P1 -> abelian P1.
Proof.
have nregA Q: gval Q != 1 -> A \subset 'N(Q) -> coprime #|Q| #|A| ->
  exists2 X, X \in 'E_p^1(A) & 'C_Q(X) != 1.
- move=> ntQ nQA coQA; apply/exists_inP; apply: contraR ntQ.
  rewrite negb_exists_in -subG1; move/forall_inP=> regA.
  have ncycA: ~~ cyclic A by rewrite (abelem_cyclic abelA) oA pfactorK.
  rewrite -(coprime_abelian_gen_cent1 _ _ nQA) // gen_subG.
  apply/bigcupsP=> x /setD1P[ntx Ax].
  apply/negPn; rewrite /= -cent_cycle subG1 regA // p1ElemE // !inE.
  by rewrite cycle_subG Ax /= -orderE (abelem_order_p abelA).
suffices{P1} cPP: abelian P.
  by move=> sylP1; have [m _ ->] := Sylow_trans sylP sylP1; rewrite abelianJ.
have [g nPg notMg] := subsetPn not_sNP_M.
pose Ms := M`_\sigma; pose q := pdiv #|Ms|; have pP := pHall_pgroup sylP.
have nMsP: P \subset 'N(Ms) by rewrite (subset_trans sPM) ?gFnorm.
have coMsP: coprime #|Ms| #|P|.
  exact: pnat_coprime (pcore_pgroup _ _) (pi_pnat pP sM'p).
have [Q1 sylQ1 nQ1P]:= sol_coprime_Sylow_exists q (pgroup_sol pP) nMsP coMsP.
have ntQ1: Q1 :!=: 1.
  rewrite -cardG_gt1 (card_Hall sylQ1) p_part_gt1 pi_pdiv cardG_gt1.
  by rewrite Msigma_neq1.
have nQ1A: A \subset 'N(Q1) := subset_trans sAP nQ1P.
have coQ1A: coprime #|Q1| #|A|.
  by rewrite (coprimeSg (pHall_sub sylQ1)) // (coprimegS sAP).
have [X1 EpX1 nregX11] := nregA _ ntQ1 nQ1A coQ1A.
pose Q2 := Q1 :^ g; have sylQ2: q.-Sylow(Ms :^ g) Q2 by rewrite pHallJ2.
have{ntQ1} ntQ2: Q2 != 1 by rewrite -!cardG_gt1 cardJg in ntQ1 *.
have nQ2A: A \subset 'N(Q2) by rewrite (subset_trans sAP) ?norm_conj_norm.
have{coQ1A} coQ2A: coprime #|Q2| #|A| by rewrite cardJg.
have{nregA ntQ2 coQ2A} [X2 EpX2 nregX22] := nregA _ ntQ2 nQ2A coQ2A.
have [|_ regA]:= exceptional_TIsigmaJ notMg _ sylQ1 nQ1A sylQ2 nQ2A.
  by rewrite (subset_trans sAP) // -(normP nPg) conjSg.
have regX21: 'C_Q1(X2) = 1 by case: (regA X2) nregX22 => // ->; rewrite eqxx.
have regX12: 'C_Q2(X1) = 1 by case: (regA X1) nregX11 => // ->; rewrite eqxx.
pose X := 'Ohm_1('Z(P))%G.
have eqCQ12_X: ('C_Q1(X) == 1) = ('C_Q2(X) == 1).
  rewrite -(inj_eq (@conjsg_inj _ g)) conjs1g conjIg -/Q2 -centJ (normP _) //.
  by rewrite (subsetP (gFnorm_trans _ _) g nPg) ?gFnorms.
have{} EpX1: X1 \in 'E_p^1(A) :\ X.
  rewrite 2!inE EpX1 andbT; apply: contraNneq nregX11 => defX1.
  by rewrite defX1 eqCQ12_X -defX1 regX12.
have{eqCQ12_X} EpX2: X2 \in 'E_p^1(A) :\ X.
  rewrite 2!inE EpX2 andbT; apply: contraNneq nregX22 => defX2.
  by rewrite defX2 -eqCQ12_X -defX2 regX21.
apply: contraR nregX11 => not_cPP.
have{not_cPP} transNPA: [transitive 'N_P(A), on 'E_p^1(A) :\ X | 'JG].
  have [|_ _]:= basic_p2maxElem_structure _ pP sAP not_cPP; last by [].
  by rewrite inE (subsetP (pnElemS p 2 (subsetT M))).
have [y PnAy ->] := atransP2 transNPA EpX2 EpX1; have [Py _] := setIP PnAy.
by rewrite centJ -(normsP nQ1P y Py) -conjIg regX21 conjs1g.
Qed.

(* This is B & G, Corollary 11.6. *)
Corollary exceptional_structure (Ms := M`_\sigma) :
  [/\ (*a*) A :=: 'Ohm_1(P),
      (*b*) 'C_Ms(A) = 1
    & (*c*) exists2 A1, A1 \in 'E_p^1(A) & exists2 A2, A2 \in 'E_p^1(A) &
            [/\ A1 :!=: A2, 'C_Ms(A1) = 1 & 'C_Ms(A2) = 1]].
Proof.
pose iMNA := #|'N(A) : M|.
have defA: A :=: 'Ohm_1(P).
  apply/eqP; rewrite eqEcard -{1}(Ohm1_id abelA) OhmS //= oA -rM.
  rewrite -(p_rank_Sylow sylP) p_rank_abelian ?exceptional_Sylow_abelian //.
  by rewrite -card_pgroup // (pgroupS _ (pHall_pgroup sylP)) ?Ohm_sub.
have iMNAgt1: iMNA > 1.
  rewrite indexg_gt1 defA; apply: contra (subset_trans _) not_sNP_M.
  by rewrite char_norms ?Ohm_char.
have iMNAgt2: iMNA > 2.
  pose q := pdiv iMNA; have q_iMNA: q %| iMNA := pdiv_dvd iMNA.
  rewrite (leq_trans _ (dvdn_leq (ltnW _) q_iMNA)) // ltn_neqAle eq_sym.
  rewrite (sameP eqP (prime_oddPn _)) ?prime_gt1 ?pdiv_prime //.
  by rewrite (dvdn_odd q_iMNA) // (dvdn_odd (dvdn_indexg _ _)) ?mFT_odd.
rewrite [iMNA](cardD1 (gval M)) orbit_refl !ltnS lt0n in iMNAgt1 iMNAgt2.
have{iMNAgt1} [Mg1 /= NM_Mg1] := pred0Pn iMNAgt1.
rewrite (cardD1 Mg1) inE /= NM_Mg1 ltnS lt0n in iMNAgt2.
have{iMNAgt2} [Mg2 /= NM_Mg2] := pred0Pn iMNAgt2.
case/andP: NM_Mg1 => neM_Mg1 /rcosetsP[g1 nAg1 defMg1].
have{neM_Mg1} notMg1: g1 \notin M.
  by apply: contra neM_Mg1 => M_g1; rewrite defMg1 rcoset_id.
case/and3P: NM_Mg2 => neMg12 neM_Mg2 /rcosetsP[g2 nAg2 defMg2].
have{neM_Mg2} notMg2: g2 \notin M.
  by apply: contra neM_Mg2 => M_g2; rewrite defMg2 rcoset_id.
pose A1 := (A0 :^ g1)%G; pose A2 := (A0 :^ g2)%G.
have EpA1: A1 \in 'E_p^1(A) by rewrite -(normP nAg1) pnElemJ.
have EpA2: A2 \in 'E_p^1(A) by rewrite -(normP nAg2) pnElemJ.
have{neMg12} neqA12: A1 :!=: A2.
  rewrite -(canF_eq (conjsgKV g2)) -conjsgM (sameP eqP normP).
  rewrite (contra (subsetP sNA0_M _)) // -mem_rcoset.
  by apply: contra neMg12 => g1Mg2; rewrite defMg1 defMg2 (rcoset_eqP g1Mg2).
have{notMg1 nAg1} regA1: 'C_Ms(A1) = 1.
  by case/exceptional_TI_MsigmaJ: notMg1; rewrite // -(normP nAg1) conjSg.
have{notMg2 nAg2} regA2: 'C_Ms(A2) = 1.
  by case/exceptional_TI_MsigmaJ: notMg2; rewrite // -(normP nAg2) conjSg.
split=> //; last by exists A1 => //; exists A2 => //.
by apply/trivgP; rewrite -regA1 setIS ?centS //; case/pnElemP: EpA1.
Qed.

(* This is B & G, Theorem 11.7 (the main result on exceptional subgroups). *)
Theorem exceptional_mul_sigma_normal : M`_\sigma <*> A <| M.
Proof.
set Ms := M`_\sigma; have pP := pHall_pgroup sylP; have solM := mmax_sol maxM.
have [E hallE sPE] := Hall_superset solM sPM (pi_pnat pP sM'p).
have sAE := subset_trans sAP sPE; have [sEM s'E _] := and3P hallE.
have [_ _ dimA] := pnElemP Ep2A.
have rE: 'r(E) = 2.
  apply/eqP; rewrite eqn_leq -{2}dimA -rank_abelem ?rankS // andbT leqNgt.
  have [q q_pr ->]:= rank_witness E; apply/negP=> rqEgt2.
  have piEq: q \in \pi(E) by rewrite -p_rank_gt0 -(subnKC rqEgt2).
  case/negP: (pnatPpi s'E piEq); rewrite /= alpha_sub_sigma // !inE.
  by rewrite (leq_trans rqEgt2) ?p_rankS.
have rFEle2: 'r('F(E)) <= 2 by rewrite -rE rankS ?Fitting_sub.
have solE := solvableS sEM solM; have oddE := mFT_odd E.
pose tau : nat_pred := [pred q | q > p]; pose K := 'O_tau(E).
have hallK: tau.-Hall(E) K by rewrite rank2_ge_pcore_Hall.
pose ptau : nat_pred := [pred q | q >= p]; pose KP := K <*> P.
have nKP: P \subset 'N(K) by rewrite (subset_trans sPE) ?gFnorm.
have coKP: coprime #|K| #|P|.
  by rewrite (pnat_coprime (pcore_pgroup _ _)) ?(pi_pnat pP) //= !inE ltnn.
have hallKP: ptau.-Hall(E) KP.
  rewrite pHallE join_subG pcore_sub sPE /= norm_joinEr ?coprime_cardMg //.
  apply/eqP; rewrite -(partnC tau (part_gt0 _ _)) (card_Hall sylP).
  rewrite (card_Hall hallK) partn_part => [|q]; last exact: leqW.
  rewrite (card_Hall hallE) -!partnI; congr (_ * _)%N; apply: eq_partn => q.
  rewrite [\sigma(M)^']lock !inE -lock -leqNgt -eqn_leq eq_sym andb_idl //.
  by move/eqP <-.
have nsKP_E: KP <| E.
  by rewrite [KP](eq_Hall_pcore _ hallKP) ?pcore_normal ?rank2_ge_pcore_Hall.
have [cKA | not_cKA]:= boolP (A \subset 'C(K)).
  pose KA := K <*> A; have defKA: K \x A = KA.
    by rewrite dprodEY // coprime_TIg // (coprimegS sAP).
  have defA: 'Ohm_1(P) = A by case exceptional_structure.
  have{} defA: 'Ohm_1('O_p(KP)) = A.
    apply/eqP; rewrite -defA eqEsubset OhmS /=; last first.
      rewrite pcore_sub_Hall ?(pHall_subl _ _ sylP) ?joing_subr //.
      exact: subset_trans (pHall_sub hallKP) sEM.
    rewrite -Ohm_id defA OhmS // pcore_max // /normal join_subG.
    rewrite (subset_trans sAP) ?joing_subr // cents_norm 1?centsC //=.
    by rewrite -defA gFnorm.
  have nMsE: E \subset 'N(Ms) by rewrite (subset_trans sEM) ?gFnorm.
  have tiMsE: Ms :&: E = 1.
    by rewrite coprime_TIg ?(pnat_coprime (pcore_pgroup _ _)).
  have <-: Ms * E = M.
    apply/eqP; rewrite eqEcard mulG_subG pcore_sub sEM /= TI_cardMg //.
    by rewrite (card_Hall hallE) (card_Hall (Msigma_Hall maxM)) ?partnC.
  rewrite norm_joinEr -?quotientK ?(subset_trans sAE) //= cosetpre_normal.
  by rewrite quotient_normal // -defA !gFnormal_trans.
pose q := pdiv #|K : 'C_K(A)|.
have q_pr: prime q by rewrite pdiv_prime // indexg_gt1 subsetI subxx centsC.
have [nKA coKA] := (subset_trans sAP nKP, coprimegS sAP coKP).
have [Q sylQ nQA]: exists2 Q : {group gT}, q.-Sylow(K) Q & A \subset 'N(Q).
  by apply: sol_coprime_Sylow_exists => //; apply: (pgroup_sol pA).
have [sQK qQ q'iQK] := and3P sylQ; have [sKE tauK _]:= and3P hallK.
have{q'iQK} not_cQA: ~~ (A \subset 'C(Q)).
  apply: contraL q'iQK => cQA; rewrite p'natE // negbK.
  rewrite -(Lagrange_index (subsetIl K 'C(A))) ?dvdn_mulr ?pdiv_dvd //.
  by rewrite subsetI sQK centsC.
have ntQ: Q :!=: 1 by apply: contraNneq not_cQA => ->; apply: cents1.
have q_dv_K: q %| #|K| := dvdn_trans (pdiv_dvd _) (dvdn_indexg _ _).
have sM'q: q \in (\sigma(M))^' := pgroupP (pgroupS sKE s'E) q q_pr q_dv_K.
have{q_dv_K} tau_q: q \in tau := pgroupP tauK q q_pr q_dv_K.
have sylQ_E: q.-Sylow(E) Q := subHall_Sylow hallK tau_q sylQ.
have sylQ_M: q.-Sylow(M) Q := subHall_Sylow hallE sM'q sylQ_E.
have q'p: p != q by rewrite neq_ltn [p < q]tau_q.
suffices nregQ: 'C_Q(A) != 1.
  have ncycQ: ~~ cyclic Q.
    apply: contra not_cQA => cycQ.
    rewrite (coprime_odd_faithful_Ohm1 qQ) ?mFT_odd ?(coprimeSg sQK) //.
    rewrite centsC; apply: contraR nregQ => not_sQ1_CA.
    rewrite setIC TI_Ohm1 // setIC prime_TIg //.
    by rewrite (Ohm1_cyclic_pgroup_prime cycQ qQ ntQ).
  have {ncycQ} rQ: 'r_q(Q) = 2.
    apply/eqP; rewrite eqn_leq ltnNge -odd_pgroup_rank1_cyclic ?mFT_odd //.
    by rewrite -rE  -rank_pgroup ?rankS // (pHall_sub sylQ_E).
  have [B Eq2B]: exists B, B \in 'E_q^2(Q) by apply/p_rank_geP; rewrite rQ.
  have maxB: B \in 'E*_q(G).
    apply: subsetP (subsetP (pnElemS q 2 (pHall_sub sylQ_M)) B Eq2B).
    by rewrite sigma'_rank2_max // -(p_rank_Sylow sylQ_M).
  have CAq: q %| #|'C(A)|.
    apply: dvdn_trans (cardSg (subsetIr Q _)).
    by have [_ ? _] := pgroup_pdiv (pgroupS (subsetIl Q _) qQ) nregQ.
  have [Qstar maxQstar sQ_Qstar] := max_normed_exists qQ nQA.
  have [|Qm] := max_normed_2Elem_signaliser q'p _ maxQstar CAq.
    by rewrite inE (subsetP (pnElemS p 2 (subsetT M))).
  case=> _ sAQm [_ _ cQstarQm]; rewrite (centSS sAQm sQ_Qstar) // in not_cQA.
  apply: cQstarQm; apply/implyP=> _; apply/set0Pn; exists B.
  have{} Eq2B := subsetP (pnElemS q 2 sQ_Qstar) B Eq2B.
  rewrite inE Eq2B (subsetP (pmaxElemS q (subsetT _))) // inE maxB inE.
  by have [? _ _] := pnElemP Eq2B.
pose Q0 := 'Z(Q); have sQ0Q: Q0 \subset Q by apply: gFsub.
have nQ0A: A \subset 'N(Q0) by apply: gFnorm_trans.
have ntQ0: Q0 != 1 by apply: contraNneq ntQ => /(trivg_center_pgroup qQ)->.
apply: contraNneq (sM'q) => regQ; apply/exists_inP; exists Q => //.
suffices nsQ0M: Q0 <| M by rewrite -(mmax_normal _ nsQ0M) ?gFnorms.
have sQ0M: Q0 \subset M := subset_trans sQ0Q (pHall_sub sylQ_M).
have qQ0: q.-group Q0 := pgroupS sQ0Q qQ.
have p'Q0: p^'.-group Q0 by apply: (pi_pnat qQ0); rewrite eq_sym in q'p.
have sM'Q0: \sigma(M)^'.-group Q0 := pi_pnat qQ0 sM'q.
have cQ0Q0: abelian Q0 := center_abelian Q.
have defQ0: [~: A, Q0] = Q0.
  rewrite -{2}[Q0](coprime_abelian_cent_dprod nQ0A) //.
    by rewrite setIAC regQ setI1g dprodg1 commGC.
  by rewrite (coprimeSg (subset_trans sQ0Q sQK)).
have [_ _ [A1 EpA1 [A2 EpA2 [neqA12 regA1 regA2]]]] := exceptional_structure.
have defA: A1 \x A2 = A by apply/(p2Elem_dprodP Ep2A EpA1 EpA2).
have{} defQ0: [~: A1, Q0] * [~: A2, Q0] = Q0.
  have{defA} [[_ defA cA12 _] [sA2A _ _]] := (dprodP defA, pnElemP EpA2).
  by rewrite -commMG ?defA // normsR ?(cents_norm cA12) // (subset_trans sA2A).
have sA_NQ0: A \subset 'N_M(Q0) by rewrite subsetI sAM.
have sEpA_EpN := subsetP (pnElemS p 1 sA_NQ0).
have nsRQ0 := commG_sigma'_1Elem_cyclic maxM sQ0M sM'Q0 sM'p (sEpA_EpN _ _).
rewrite -defQ0 -!(commGC Q0).
by apply: normalM; [case/nsRQ0: EpA1 | case/nsRQ0: EpA2].
Qed.

End Section11.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import coqutil.Word.Interface.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.PushButtonSynthesis.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Translation.Parameters.SelectParameters.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.ReifiedOperation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Translation.Proofs.ValidComputable.Func.
Require Import Crypto.Util.Tactics.SpecializeBy.
Local Open Scope Z_scope.
Import ListNotations.
Import AbstractInterpretation.Compilers.

Class bedrock2_unsaturated_solinas_funcs :=
  { carry_mul : func;
    carry_square : func;
    carry : func;
    add : func;
    sub : func;
    opp : func;
    selectznz : func;
    to_bytes : func;
    from_bytes : func }.

Class bedrock2_unsaturated_solinas_specs
      {funcs : bedrock2_unsaturated_solinas_funcs }:=
  { spec_of_carry_mul : spec_of (fst carry_mul);
    spec_of_carry_square : spec_of (fst carry_square);
    spec_of_carry : spec_of (fst carry);
    spec_of_add : spec_of (fst add);
    spec_of_sub : spec_of (fst sub);
    spec_of_opp : spec_of (fst opp);
    spec_of_selectznz : spec_of (fst selectznz);
    spec_of_to_bytes : spec_of (fst to_bytes);
    spec_of_from_bytes : spec_of (fst from_bytes) }.

Class bedrock2_unsaturated_solinas_correctness
      {funcs : bedrock2_unsaturated_solinas_funcs}
      {specs : bedrock2_unsaturated_solinas_specs} :=
  { carry_mul_correct :
      forall functions,
        spec_of_carry_mul (carry_mul :: functions);
    carry_square_correct :
      forall functions,
        spec_of_carry_square (carry_square :: functions);
    carry_correct :
      forall functions,
        spec_of_carry (carry :: functions);
    add_correct :
      forall functions,
        spec_of_add (add :: functions);
    sub_correct :
      forall functions,
        spec_of_sub (sub :: functions);
    opp_correct :
      forall functions,
        spec_of_opp (opp :: functions);
    selectznz_correct :
      forall functions,
        spec_of_selectznz (selectznz :: functions);
    to_bytes_correct :
      forall functions,
        spec_of_to_bytes (to_bytes :: functions);
    from_bytes_correct :
      forall functions,
        spec_of_from_bytes (from_bytes :: functions) }.

Class bedrock2_unsaturated_solinas_scmul_func :=
  { carry_scmul_const : func }.

Class bedrock2_unsaturated_solinas_scmul_spec
      {func : bedrock2_unsaturated_solinas_scmul_func }:=
  { spec_of_carry_scmul_const : spec_of (fst carry_scmul_const) }.

Class bedrock2_unsaturated_solinas_scmul_correctness
      {func : bedrock2_unsaturated_solinas_scmul_func}
      {spec : bedrock2_unsaturated_solinas_scmul_spec} :=
  { carry_scmul_const_correct :
      forall functions,
        spec_of_carry_scmul_const (carry_scmul_const :: functions) }.

Class names_of_operations :=
  { name_of_carry_mul : string;
    name_of_carry_square : string;
    name_of_carry : string;
    name_of_add : string;
    name_of_sub : string;
    name_of_opp : string;
    name_of_selectznz : string;
    name_of_to_bytes : string;
    name_of_from_bytes : string;
    name_of_carry_scmul_const : Z -> string }.

Record unsaturated_solinas_reified_ops
       {names : names_of_operations} {n s c machine_wordsize} :=
  { params : Types.parameters;
    reified_carry_mul :
      reified_op name_of_carry_mul
                 (@Generic.UnsaturatedSolinas.carry_mul params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry_mul
                    n s c machine_wordsize);
    reified_carry_square :
      reified_op name_of_carry_square
                 (@Generic.UnsaturatedSolinas.carry_square params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry_square
                    n s c machine_wordsize);
    reified_carry :
      reified_op name_of_carry
                 (@Generic.UnsaturatedSolinas.carry params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry
                    n s c machine_wordsize);
    reified_add :
      reified_op name_of_add
                 (@Generic.UnsaturatedSolinas.add params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.add
                    n s c machine_wordsize);
    reified_sub :
      reified_op name_of_sub
                 (@Generic.UnsaturatedSolinas.sub params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.sub
                    n s c machine_wordsize);
    reified_opp :
      reified_op name_of_opp
                 (@Generic.UnsaturatedSolinas.opp params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.opp
                    n s c machine_wordsize);
    reified_selectznz :
      reified_op name_of_selectznz
                 (@Generic.UnsaturatedSolinas.selectznz params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.selectznz
                    n machine_wordsize);
    reified_to_bytes :
      reified_op name_of_to_bytes
                 (@Generic.UnsaturatedSolinas.to_bytes params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.to_bytes
                    n s c machine_wordsize);
    reified_from_bytes :
      reified_op name_of_from_bytes
                 (@Generic.UnsaturatedSolinas.from_bytes params n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.from_bytes
                    n s c machine_wordsize) }.
Arguments unsaturated_solinas_reified_ops {names} n s c machine_wordsize.

Record unsaturated_solinas_reified_scmul
       {names : names_of_operations} {n s c machine_wordsize} {x : Z} :=
  { scmul_params : Types.parameters;
    reified_carry_scmul_const :
      reified_op (name_of_carry_scmul_const x)
                 (@Generic.UnsaturatedSolinas.carry_scmul_const
                    scmul_params n s c x)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry_scmul_const
                    n s c machine_wordsize x) }.
Arguments unsaturated_solinas_reified_scmul
          {names} n s c machine_wordsize x.

(*** Helpers ***)

Definition names_from_prefix (prefix : string)
  : names_of_operations :=
  {| name_of_carry_mul := (prefix ++ "carry_mul")%string;
     name_of_carry_square := (prefix ++ "carry_square")%string;
     name_of_carry := (prefix ++ "carry")%string;
     name_of_add := (prefix ++ "add")%string;
     name_of_sub := (prefix ++ "sub")%string;
     name_of_opp := (prefix ++ "opp")%string;
     name_of_selectznz := (prefix ++ "selectznz")%string;
     name_of_to_bytes := (prefix ++ "to_bytes")%string;
     name_of_from_bytes := (prefix ++ "from_bytes")%string;
     name_of_carry_scmul_const :=
       fun x =>
         (prefix ++ "carry_scmul_const" ++ Decimal.Z.to_string x)%string
  |}.

(*** Synthesis Tactics ***)

Ltac scmul_func_from_ops ops :=
  let carry_scmul_const_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_carry_scmul_const ops))) in
  exact {| carry_scmul_const := carry_scmul_const_func_value |}.

Ltac scmul_spec_from_ops ops n s c :=
  let x := lazymatch type of ops with
           | unsaturated_solinas_reified_scmul _ _ _ _ ?x => x end in
  let p := (eval cbn [scmul_params ops] in (scmul_params ops)) in
  let carry_scmul_const_name :=
      (eval compute in (name_of_carry_scmul_const x)) in
  let carry_scmul_const_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.carry_scmul_const
                 Generic.UnsaturatedSolinas.spec_of_carry_scmul_const] in
          (@Generic.UnsaturatedSolinas.spec_of_carry_scmul_const
             p n s c x carry_scmul_const_name)) in
  exact {| spec_of_carry_scmul_const := carry_scmul_const_spec |}.

Ltac funcs_from_ops ops :=
  let carry_mul_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_carry_mul ops))) in
  let carry_square_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_carry_square ops))) in
  let carry_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_carry ops))) in
  let add_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_add ops))) in
  let sub_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_sub ops))) in
  let opp_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_opp ops))) in
  let selectznz_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_selectznz ops))) in
  let to_bytes_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_to_bytes ops))) in
  let from_bytes_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_from_bytes ops))) in
  exact {| carry_mul := carry_mul_func_value;
           carry_square := carry_square_func_value;
           carry := carry_func_value;
           add := add_func_value;
           sub := sub_func_value;
           opp := opp_func_value;
           selectznz := selectznz_func_value;
           to_bytes := to_bytes_func_value;
           from_bytes := from_bytes_func_value |}.

Ltac specs_from_ops ops n s c :=
  let p := eval cbn [params ops] in (params ops) in
  let carry_mul_name := (eval compute in name_of_carry_mul) in
  let carry_square_name := (eval compute in name_of_carry_square) in
  let carry_name := (eval compute in name_of_carry) in
  let add_name := (eval compute in name_of_add) in
  let sub_name := (eval compute in name_of_sub) in
  let opp_name := (eval compute in name_of_opp) in
  let selectznz_name := (eval compute in name_of_selectznz) in
  let to_bytes_name := (eval compute in name_of_to_bytes) in
  let from_bytes_name := (eval compute in name_of_from_bytes) in
  let carry_mul_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.carry_mul
                 Generic.UnsaturatedSolinas.spec_of_carry_mul] in
          (@Generic.UnsaturatedSolinas.spec_of_carry_mul
             p n s c carry_mul_name)) in
  let carry_square_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.carry_square
                 Generic.UnsaturatedSolinas.spec_of_carry_square] in
          (@Generic.UnsaturatedSolinas.spec_of_carry_square
             p n s c carry_square_name)) in
  let carry_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.carry
                 Generic.UnsaturatedSolinas.spec_of_carry] in
          (@Generic.UnsaturatedSolinas.spec_of_carry
             p n s c carry_name)) in
  let add_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.add
                 Generic.UnsaturatedSolinas.spec_of_add] in
          (@Generic.UnsaturatedSolinas.spec_of_add
             p n s c add_name)) in
  let sub_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.sub
                 Generic.UnsaturatedSolinas.spec_of_sub] in
          (@Generic.UnsaturatedSolinas.spec_of_sub
             p n s c sub_name)) in
  let opp_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.opp
                 Generic.UnsaturatedSolinas.spec_of_opp] in
          (@Generic.UnsaturatedSolinas.spec_of_opp
             p n s c opp_name)) in
  let selectznz_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.selectznz
                 Generic.UnsaturatedSolinas.spec_of_selectznz] in
          (@Generic.UnsaturatedSolinas.spec_of_selectznz
             p n s c selectznz_name)) in
  let to_bytes_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.to_bytes
                 Generic.UnsaturatedSolinas.spec_of_to_bytes] in
          (@Generic.UnsaturatedSolinas.spec_of_to_bytes
             p n s c to_bytes_name)) in
  let from_bytes_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.UnsaturatedSolinas.from_bytes
                 Generic.UnsaturatedSolinas.spec_of_from_bytes] in
          (@Generic.UnsaturatedSolinas.spec_of_from_bytes
             p n s c from_bytes_name)) in
  exact {| spec_of_carry_mul := carry_mul_spec;
           spec_of_carry_square := carry_square_spec;
           spec_of_carry := carry_spec;
           spec_of_add := add_spec;
           spec_of_sub := sub_spec;
           spec_of_opp := opp_spec;
           spec_of_selectznz := selectznz_spec;
           spec_of_to_bytes := to_bytes_spec;
           spec_of_from_bytes := from_bytes_spec |}.

Ltac handle_easy_preconditions :=
  lazymatch goal with
  | |- ZRange.type.option.is_tighter_than _ _ = true =>
    abstract vm_cast_no_check (eq_refl true)
  | |- Types.ok => solve [typeclasses eauto]
  | |- _ = ErrorT.Success _ => solve [apply reified_eq]
  | |- API.Wf _ => solve [apply reified_Wf]
  | |- Func.valid_func _ => solve [apply reified_valid]
  | _ => first [ apply inname_gen_varname_gen_disjoint
               | apply outname_gen_varname_gen_disjoint
               | apply outname_gen_inname_gen_disjoint
               | apply prefix_name_gen_unique ]
  | |- ?g => fail "Unrecognized goal" g
  end.

Ltac use_correctness_proofs p n s c :=
  let Hc := fresh in
  match goal with
  | |- context [Generic.UnsaturatedSolinas.carry_mul] =>
    apply (@Generic.UnsaturatedSolinas.carry_mul_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.carry_square] =>
    apply (@Generic.UnsaturatedSolinas.carry_square_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.carry] =>
    apply (@Generic.UnsaturatedSolinas.carry_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.add] =>
    apply (@Generic.UnsaturatedSolinas.add_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.sub] =>
    apply (@Generic.UnsaturatedSolinas.sub_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.opp] =>
    apply (@Generic.UnsaturatedSolinas.opp_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.selectznz] =>
    apply (@Generic.UnsaturatedSolinas.selectznz_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.to_bytes] =>
    apply (@Generic.UnsaturatedSolinas.to_bytes_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.from_bytes] =>
    apply (@Generic.UnsaturatedSolinas.from_bytes_correct
             p default_inname_gen default_outname_gen n s c)
  | |- context [Generic.UnsaturatedSolinas.carry_scmul_const] =>
    apply (@Generic.UnsaturatedSolinas.carry_scmul_const_correct
             p default_inname_gen default_outname_gen n s c)
  end.

Ltac change_with_computed_func ops :=
  lazymatch goal with
  | |- context [carry_mul] =>
    change carry_mul with (computed_bedrock_func (reified_carry_mul ops))
  | |- context [carry_square] =>
    change carry_square with (computed_bedrock_func (reified_carry_square ops))
  | |- context [carry] =>
    change carry with (computed_bedrock_func (reified_carry ops))
  | |- context [add] =>
    change add with (computed_bedrock_func (reified_add ops))
  | |- context [sub] =>
    change sub with (computed_bedrock_func (reified_sub ops))
  | |- context [opp] =>
    change opp with (computed_bedrock_func (reified_opp ops))
  | |- context [selectznz] =>
    change selectznz with (computed_bedrock_func (reified_selectznz ops))
  | |- context [to_bytes] =>
    change to_bytes with (computed_bedrock_func (reified_to_bytes ops))
  | |- context [from_bytes] =>
    change from_bytes with (computed_bedrock_func (reified_from_bytes ops))
  | |- context [carry_scmul_const] =>
    change carry_scmul_const with (computed_bedrock_func (reified_carry_scmul_const ops))
  end.

Ltac prove_correctness ops n s c machine_wordsize :=
  assert (UnsaturatedSolinas.check_args
            n s c machine_wordsize (ErrorT.Success tt) =
          ErrorT.Success tt) by abstract (native_compute; reflexivity);
  lazymatch goal with
    | |- bedrock2_unsaturated_solinas_correctness => econstructor end;
  change_with_computed_func ops; rewrite computed_bedrock_func_eq;
  let p := (eval cbn [params ops] in (params ops)) in
  use_correctness_proofs p n s c; try assumption;
  handle_easy_preconditions.

Ltac prove_correctness_scmul ops n s c machine_wordsize :=
  assert (UnsaturatedSolinas.check_args
            n s c machine_wordsize (ErrorT.Success tt) =
          ErrorT.Success tt) by abstract (native_compute; reflexivity);
  lazymatch goal with
  | |- bedrock2_unsaturated_solinas_scmul_correctness =>
    econstructor end;
  change_with_computed_func ops; rewrite computed_bedrock_func_eq;
  let p := (eval cbn [scmul_params ops] in (scmul_params ops)) in
  use_correctness_proofs p n s c; try assumption;
  handle_easy_preconditions.

Ltac make_names_of_operations prefix :=
  match goal with
  | |- names_of_operations =>
    let n := eval vm_compute in (names_from_prefix prefix) in
        exact n
  end.

Ltac make_reified_ops :=
  lazymatch goal with
    |- unsaturated_solinas_reified_ops ?n ?s ?c ?machine_wordsize =>
    let p := parameters_from_wordsize machine_wordsize in
    eapply Build_unsaturated_solinas_reified_ops with (params:=p)
  end; prove_reified_op.

Ltac make_reified_scmul :=
  lazymatch goal with
    |- unsaturated_solinas_reified_scmul ?n ?s ?c ?machine_wordsize ?x =>
    let p := parameters_from_wordsize machine_wordsize in
    eapply Build_unsaturated_solinas_reified_scmul with (scmul_params:=p)
  end;
  prove_reified_op.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D M Dprime : Universe, ((wd_ D A /\ (wd_ A B /\ (wd_ D B /\ (wd_ C A /\ (wd_ C B /\ (wd_ C M /\ (wd_ D M /\ (wd_ M A /\ (wd_ M Dprime /\ (col_ M A B /\ (col_ M C D /\ col_ M Dprime D))))))))))) -> col_ M C Dprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Rupicola.Lib.Api.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Local Open Scope Z_scope.

Section Compile.
  Context {semantics : Semantics.parameters}
          {semantics_ok : Semantics.parameters_ok semantics}.
  Context {field_parameters : FieldParameters}
          {field_representaton : FieldRepresentation}
          {field_representation_ok : FieldRepresentation_ok}.
  Existing Instances spec_of_mul spec_of_add spec_of_sub spec_of_square
           spec_of_scmula24 spec_of_inv spec_of_felem_copy
           spec_of_felem_small_literal.

  (* "Hidden" alias protects a Placeholder (e.g. the pointer reserved for the
     final output value) from having intermediate values stored in it *)
  Definition Hidden := Placeholder.

  Local Ltac prove_field_compilation :=
    repeat straightline';
    handle_call;
    lazymatch goal with
    | |- sep _ _ _ => ecancel_assumption
    | _ => idtac
    end; eauto;
    sepsimpl; repeat straightline'; subst; eauto.

  Lemma compile_mul :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x y : felem) x_ptr x_var y_ptr y_var out_ptr out_var
      (X Y : F M_pos) k k_impl,
      spec_of_mul functions ->
      bounded_by loose_bounds x ->
      bounded_by loose_bounds y ->
      feval x = X ->
      feval y = Y ->
      (FElem x_ptr x * FElem y_ptr y * Rin)%sep mem ->
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals y_var = Some y_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := (X * Y)%F in
      (let head := v in
       forall out m,
         feval out = head ->
         bounded_by tight_bounds out ->
         sep (FElem out_ptr out) Rout m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] mul [expr.var out_var; expr.var x_var;
                                   expr.var y_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof. prove_field_compilation. Qed.

  Lemma compile_add :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x y : felem) x_ptr x_var y_ptr y_var out_ptr out_var
      (X Y : F M_pos) k k_impl,
      spec_of_add functions ->
      bounded_by tight_bounds x ->
      bounded_by tight_bounds y ->
      feval x = X ->
      feval y = Y ->
      (FElem x_ptr x * FElem y_ptr y * Rin)%sep mem ->
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals y_var = Some y_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := (X + Y)%F in
      (let head := v in
       forall out m,
         feval out = head ->
         bounded_by loose_bounds out ->
         sep (FElem out_ptr out) Rout m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] add [expr.var out_var; expr.var x_var;
                                   expr.var y_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof. prove_field_compilation. Qed.

  Lemma compile_sub :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x y : felem) x_ptr x_var y_ptr y_var out_ptr out_var
      (X Y : F M_pos) k k_impl,
      spec_of_sub functions ->
      bounded_by tight_bounds x ->
      bounded_by tight_bounds y ->
      feval x = X ->
      feval y = Y ->
      (FElem x_ptr x * FElem y_ptr y * Rin)%sep mem ->
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals y_var = Some y_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := (X - Y)%F in
      (let head := v in
       forall out m,
         feval out = head ->
         bounded_by loose_bounds out ->
         sep (FElem out_ptr out) Rout m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] sub [expr.var out_var; expr.var x_var;
                                   expr.var y_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof. prove_field_compilation. Qed.

  Lemma compile_square :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x : felem) x_ptr x_var out_ptr out_var (X : F M_pos) k k_impl,
      spec_of_square functions ->
      bounded_by loose_bounds x ->
      feval x = X ->
      (FElem x_ptr x * Rin)%sep mem ->
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := (X ^ 2)%F in
      (let head := v in
       forall out m,
         feval out = head ->
         bounded_by tight_bounds out ->
         sep (FElem out_ptr out) Rout m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] square [expr.var out_var; expr.var x_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    intros. subst_lets_in_goal.
    rewrite F.pow_2_r in *.
    prove_field_compilation.
  Qed.

  Lemma compile_scmula24 :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x : felem) x_ptr x_var out_ptr out_var (X : F M_pos) k k_impl,
      spec_of_scmula24 functions ->
      bounded_by loose_bounds x ->
      feval x = X ->
      (FElem x_ptr x * Rin)%sep mem ->
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := (a24 * X)%F in
      (let head := v in
       forall out m,
         feval out = head ->
         bounded_by tight_bounds out ->
         sep (FElem out_ptr out) Rout m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] scmula24 [expr.var out_var; expr.var x_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof. prove_field_compilation. Qed.

  Lemma compile_inv :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x : felem) x_ptr x_var out_ptr out_var (X : F M_pos) k k_impl,
      spec_of_inv functions ->
      bounded_by tight_bounds x ->
      feval x = X ->
      (FElem x_ptr x * Rin)%sep mem ->
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := F.inv X in
      (let head := v in
       forall out m,
         feval out = head ->
         bounded_by loose_bounds out ->
         sep (FElem out_ptr out) Rout m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] inv [expr.var out_var; expr.var x_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof. prove_field_compilation. Qed.

  Lemma compile_felem_copy :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R R' functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x : felem) x_ptr x_var out_ptr out_var
      (X : F M_pos) k k_impl,
      spec_of_felem_copy functions ->
      feval x = X ->
      (FElem x_ptr x * Placeholder out_ptr * R')%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals out_var = Some out_ptr ->
      let v := X in
      (let head := v in
       forall m,
         (FElem x_ptr x * FElem out_ptr x * R')%sep m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] felem_copy [expr.var out_var; expr.var x_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof. prove_field_compilation. Qed.

  Lemma compile_felem_small_literal :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R R' functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (wx : word) (x : Z) out_ptr out_var k k_impl,
      spec_of_felem_small_literal functions ->
      (Placeholder out_ptr * R')%sep mem ->
      map.get locals out_var = Some out_ptr ->
      word.unsigned wx = x ->
      let v := F.of_Z M_pos x in
      (let head := v in
       forall X m,
         (FElem out_ptr X * R')%sep m ->
         feval X = head ->
         bounded_by tight_bounds X ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [] felem_small_literal
                         [expr.var out_var; expr.literal x])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    prove_field_compilation.
    match goal with H : _ |- _ =>
                    rewrite word.of_Z_unsigned in H end.
    use_hyp_with_matching_cmd; eauto; [ ].
    subst_lets_in_goal.
    match goal with H : F.to_Z _ = _ |- _ => rewrite <-H end.
    rewrite F.of_Z_to_Z. eauto.
  Qed.

  (* noop indicating that the last argument should store output *)
  Definition overwrite1 {A B} := @id (A -> B).
  (* noop indicating that the 2nd-to-last argument should store output *)
  Definition overwrite2 {A B C} := @id (A -> B -> C).

  Lemma compile_compose_l :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
           tr retvars R Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
           {A1 A2 : Type} (* second arg is N for F.pow, so allow that *)
           (op1 : F M_pos -> A1 -> F M_pos)
           (op2 : F M_pos -> A2 -> F M_pos)
           x y z out_ptr out_var k k_impl,
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals out_var = Some out_ptr ->
      let v := ((op2 (op1 x y) z)) in
      (let head := v in
       (find k_impl
        implementing
             (pred (dlet (op1 x y)
                         (fun xy => dlet ((overwrite2 op2) xy z) k)))
        and-returning retvars
        and-locals-post locals_ok
        with-locals locals and-memory mem and-trace tr and-rest R
        and-functions functions)) ->
      (let head := v in
       find k_impl
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    cbv [Placeholder overwrite1 overwrite2] in *.
    repeat straightline'. auto.
  Qed.

  Lemma compile_compose_r :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rout functions T (pred: T -> list word -> Semantics.mem -> Prop)
           {A1 : Type} (* second arg is N for F.pow, so allow that *)
           (op1 : F M_pos -> A1 -> F M_pos)
           (op2 : F M_pos -> F M_pos -> F M_pos)
           x y z out_ptr out_var k k_impl,
      (Placeholder out_ptr * Rout)%sep mem ->
      map.get locals out_var = Some out_ptr ->
      let v := (op2 z (op1 x y)) in
      (let head := v in
       (find k_impl
        implementing
             (pred (dlet (op1 x y)
                         (fun xy => dlet ((overwrite1 op2) z xy) k)))
        and-returning retvars
        and-locals-post locals_ok
        with-locals locals and-memory mem and-trace tr and-rest R
        and-functions functions)) ->
      (let head := v in
       find k_impl
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    cbv [Placeholder overwrite1 overwrite2] in *.
    repeat straightline'. auto.
  Qed.

  Lemma compile_overwrite1 :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin functions T (pred: T -> list word -> Semantics.mem -> Prop)
      (x : F M_pos) (op : F M_pos -> F M_pos -> F M_pos)
      (y : felem) y_ptr y_var (Y : F M_pos) k k_impl,
      (FElem y_ptr y * Rin)%sep mem ->
      feval y = Y ->
      map.get locals y_var = Some y_ptr ->
      let v := (overwrite1 op) x Y in
      let v' := op x Y in
      (let __ := 0 in (* placeholder *)
       forall m,
         sep (FElem y_ptr y) Rin m ->
         sep (Placeholder y_ptr) Rin m ->
         (find k_impl
          implementing (pred (dlet v' k))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find k_impl
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    repeat straightline'. auto.
    match goal with H : _ |- _ => apply H end.
    { ecancel_assumption. }
    { seprewrite FElem_from_bytes.
      sepsimpl; eexists; ecancel_assumption. }
  Qed.

  Lemma compile_overwrite2 :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
      tr retvars R Rin functions T (pred: T -> list word -> Semantics.mem -> Prop)
      {A} (y : A)
      (op : F M_pos -> A -> F M_pos)
      (x : felem) x_ptr x_var (X : F M_pos) k k_impl,
      feval x = X ->
      (FElem x_ptr x * Rin)%sep mem ->
      map.get locals x_var = Some x_ptr ->
      let v := (overwrite2 op) X y in
      let v' := op X y in
      (let __ := 0 in (* placeholder *)
       forall m,
         sep (FElem x_ptr x) Rin m ->
         sep (Placeholder x_ptr) Rin m ->
         (find k_impl
          implementing (pred (dlet v' k))
          and-returning retvars
          and-locals-post locals_ok
          with-locals locals and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find k_impl
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    repeat straightline'. auto.
    match goal with H : _ |- _ => apply H end.
    { ecancel_assumption. }
    { seprewrite FElem_from_bytes.
      sepsimpl; eexists; ecancel_assumption. }
  Qed.
End Compile.

Ltac field_compile_step :=
  first [ simple eapply compile_scmula24 (* must precede compile_mul *)
        | simple eapply compile_mul
        | simple eapply compile_add
        | simple eapply compile_sub
        | simple eapply compile_square
        | simple eapply compile_inv ];
  lazymatch goal with
  | |- feval _ = _ => try eassumption; try reflexivity
  | |- _ => idtac
  end.

Ltac compile_compose_step :=
  first [ simple eapply compile_compose_l
        | simple eapply compile_compose_r
        | simple eapply compile_overwrite1
        | simple eapply compile_overwrite2 ];
  [ solve [repeat compile_step] .. | intros ].

(* Change an FElem into a Placeholder to indicate that it is overwritable *)
Ltac free p :=
  match goal with
  | H : sep ?P ?Q ?m |- context [?m] =>
    let x :=
        match type of H with
        | context [FElem p ?x] => x
        end in
    let F :=
        match (eval pattern (FElem p x) in (sep P Q m)) with
        | ?F _ => F end in
    let H' := fresh in
    assert (F (Placeholder p)) as H'
        by (seprewrite FElem_from_bytes; sepsimpl; eexists;
            ecancel_assumption);
    cbv beta in H'; clear H
  end.

(* Protect a pointer (e.g. the pointer reserved for final output) by "hiding"
   the fact that it is available under the "Hidden" alias *)
Ltac hide p :=
  change (Placeholder p) with (Hidden p) in *.
Ltac unhide p :=
  change (Hidden p) with (Placeholder p) in *.


Require Export CatSem.CAT.rmonad_gen_type_po.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.

(* contains a "smaller" version of the eq fibre transport
    morphism of modules
*)

Section gen_pb_fib_and_eq.

Variables obC obD obC' obD': Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable morC' : obC' -> obC' -> Type.
Variable morD' : obD' -> obD' -> Type.
(*Variable C : Cat morC.
Variable D : Cat morD.*)
Variable C' : Cat_struct morC'.
Variable D' : Cat_struct morD'.

(*Variable F : Functor C D.*)
Variable F' : Functor C' D'.

(*Variable P : RMonad F.*)
Variable Q : RMonad F'.

(** for a monad hom we need two functors *)

(*Variable G1 : Functor C C'.
Variable G2 : Functor D D'.
*)
(*Variable N : NT (CompF G1 F') (CompF F G2).*)

(*Variable h : gen_RMonad_Hom P Q N.*)

Variable T : Type.

Variables u t : T.

Variable M : RMOD Q (IPO T).

Hypothesis H : u = t.

Definition bla c:
(FIB_RMOD Q u) M c -> ((FIB_RMOD Q t) M) c.
simpl.
intros c s.
rewrite <- H.
exact s.
Defined.
(*
Obligation Tactic := idtac.
*)
Program Instance eq_rect_small_po_s c:
 PO_mor_struct
 (a:=(FIB_RMOD Q u) M c) (b:=(FIB_RMOD Q t) M c)
 (fun (s:M c u) =>
eq_rect u (fun t : T => (M c) t)  s t H).
Next Obligation.
Proof.
  subst.
  simpl.
  auto.
Qed.

Definition eq_rect_small_po c:=Build_PO_mor (eq_rect_small_po_s c).

Program Instance FIB_RMOD_small_eq_s : RModule_Hom_struct
 (M:=FIB_RMOD _ u M) (N:=FIB_RMOD _ t M)
 eq_rect_small_po.
Next Obligation.
Proof.
  subst.
  simpl.
  auto.
Qed.

Definition Fib_eq_RMod :
    FIB_RMOD _ u M ---> FIB_RMOD _ t M :=
 Build_RModule_Hom FIB_RMOD_small_eq_s.

End gen_pb_fib_and_eq.