(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype finset.
Require Import prime fingroup morphism automorphism quotient gproduct gfunctor.
Require Import cyclic center commutator pgroup nilpotent sylow abelian hall.
Require Import maximal.
Require Import BGsection1 BGappendixAB.

(******************************************************************************)
(*   This file covers most of B & G section 6.                                *)
(* Theorem 6.4 is not proved, since it is not needed for the revised proof of *)
(* the odd order theorem.                                                     *)
(******************************************************************************)

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

Import GroupScope.

Section Six.

Implicit Type gT : finGroupType.
Implicit Type p : nat.

Section OneType.

Variable gT : finGroupType.
Implicit Types G H K S U : {group gT}.

(* This is B & G, Theorem A.4(b) and 6.1, or Gorenstein 6.5.2, the main Hall- *)
(* Higman style p-stability result used in the proof of the Odd Order Theorem *)
Theorem odd_p_abelian_constrained p G :
  odd #|G| -> solvable G -> p.-abelian_constrained G.
Proof.
move/odd_p_stable=> stabG /solvable_p_constrained constrG.
exact: p_stable_abelian_constrained.
Qed.

(* Auxiliary results from AppendixAB, necessary to exploit the results below. *)
Definition center_Puig_char := BGappendixAB.center_Puig_char.
Definition trivg_center_Puig_pgroup := BGappendixAB.trivg_center_Puig_pgroup.

(* The two parts of B & G, Theorem 6.2 are established in BGappendixAB. *)
Theorem Puig_factorisation p G S :
  odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) * 'N_G('Z('L(S))) = G.
Proof. exact: BGappendixAB.Puig_factorization. Qed.

(* This is the main statement of B & G, Theorem 6.2. It is not used in the    *)
(* actual proof.                                                              *)
Theorem Puig_center_p'core_normal p G S :
  odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) * 'Z('L(S)) <| G.
Proof.
move=> oddG solG sylS; rewrite -{2}(Puig_factorisation _ _ sylS) //.
have sZL_G: 'Z('L(S)) \subset G by rewrite !gFsub_trans ?(pHall_sub sylS).
rewrite -!quotientK ?(subset_trans sZL_G) ?subIset ?gFnorm //=.
by rewrite cosetpre_normal quotient_normal // normalSG.
Qed.

(* This is the second part (special case) of B & G, Theorem 6.2.              *)
Theorem Puig_center_normal p G S :
  odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) = 1 -> 'Z('L(S)) <| G.
Proof. exact: BGappendixAB.Puig_center_normal. Qed.

(* This is B & G, Lemma 6.3(a). *)
Lemma coprime_der1_sdprod K H G :
    K ><| H = G -> coprime #|K| #|H| -> solvable K -> K \subset G^`(1) ->
  [~: K, H] = K /\ 'C_K(H) \subset K^`(1).
Proof.
case/sdprodP=> _ defG nKH tiKH coKH solK sKG'.
set K' := K^`(1); have [sK'K nK'K] := andP (der_normal 1 K : K' <| K).
have nK'H: H \subset 'N(K') := gFnorm_trans _ nKH.
set R := [~: K, H]; have sRK: R \subset K by rewrite commg_subl.
have [nRK nRH] := joing_subP (commg_norm K H : K <*> H \subset 'N(R)).
have sKbK'H': K / R \subset (K / R)^`(1) * (H / R)^`(1).
  have defGb: (K / R) \* (H / R) = G / R.
    by rewrite -defG quotientMl ?cprodE // centsC quotient_cents2r.
  have [_ -> _ /=] := cprodP (der_cprod 1 defGb).
  by rewrite -quotient_der ?quotientS // -defG mul_subG.
have tiKbHb': K / R :&: (H / R)^`(1) = 1.
  by rewrite coprime_TIg // (coprimegS (der_sub 1 _)) ?coprime_morph.
have{sKbK'H' tiKbHb'} derKb: (K / R)^`(1) = K / R.
  by rewrite -{2}(setIidPr sKbK'H') -group_modl ?der_sub // setIC tiKbHb' mulg1.
have{derKb} Kb1: K / R = 1.
  rewrite (contraNeq (sol_der1_proper _ (subxx (K / R)))) ?quotient_sol //.
  by rewrite derKb properxx.
have{Kb1 sRK} defKH: [~: K, H] = K.
  by apply/eqP; rewrite eqEsubset sRK -quotient_sub1 ?Kb1 //=.
split=> //; rewrite -quotient_sub1 ?subIset ?nK'K //= -/K'.
have cKaKa: abelian (K / K') := der_abelian 0 K.
rewrite coprime_quotient_cent ?quotient_norms ?coprime_morph //= -/K' -defKH.
by rewrite quotientR // coprime_abel_cent_TI ?quotient_norms ?coprime_morph.
Qed.

(* This is B & G, Lemma 6.3(b). It is apparently not used later. *)
Lemma prime_nil_der1_factor G :
    nilpotent G^`(1) -> prime #|G / G^`(1)| ->
  Hall G G^`(1) /\ (forall H, G^`(1) ><| H = G -> G^`(1) = [~: G, H]).
Proof.
move=> nilG' /=; set G' := G^`(1); set p := #|G / G'| => p_pr.
have nsG'G: G' <| G := der_normal 1 G; have [sG'G nG'G] := andP nsG'G.
have nsG'p'G: 'O_p^'(G') <| G := gFnormal_trans _ nsG'G.
have nG'p'G := normal_norm nsG'p'G; have solG' := nilpotent_sol nilG'.
have{nilG'} pGb: p.-group (G / 'O_p^'(G')).
  rewrite /pgroup card_quotient -?(Lagrange_index sG'G (pcore_sub _ _)) //=.
  rewrite pnat_mul // -card_quotient // pnat_id //= -pnatNK.
  by case/and3P: (nilpotent_pcore_Hall p^' nilG').
have{pGb} cycGb: cyclic (G / 'O_p^'(G')).
  apply: (cyclic_nilpotent_quo_der1_cyclic (pgroup_nil pGb)).
  rewrite -quotient_der // (isog_cyclic (third_isog _ _ _)) ?pcore_sub //.
  by apply: prime_cyclic.
have defG': G' = 'O_p^'(G').
  by apply/eqP; rewrite eqEsubset pcore_sub der1_min ?cyclic_abelian.
have hallG': Hall G G'.
  rewrite /Hall sG'G -?card_quotient // defG' //= -/p.
  by rewrite (p'nat_coprime (pcore_pgroup _ _)) ?pnat_id.
split=> // H defG; have [_ mulG'H nG'H tiG'H] := sdprodP defG.
rewrite -mulG'H commMG ?commg_normr // -derg1 (derG1P _) ?mulg1 //.
  by case/coprime_der1_sdprod: (defG); rewrite ?(coprime_sdprod_Hall_l defG).
rewrite (isog_abelian (quotient_isog nG'H tiG'H)) /= -/G'.
by rewrite -quotientMidl mulG'H der_abelian.
Qed.

Section PprodSubCoprime.

Variables K U H G : {group gT}.
Hypotheses (defG : K * U = G) (nsKG : K <| G).
Hypotheses (sHU : H \subset U) (coKH : coprime #|K| #|H|).
Let nKG : G \subset 'N(K). Proof. by case/andP: nsKG. Qed.
Let sKG : K \subset G. Proof. by case/mulG_sub: defG. Qed.
Let sUG : U \subset G. Proof. by case/mulG_sub: defG. Qed.
Let nKU : U \subset 'N(K). Proof. exact: subset_trans sUG nKG. Qed.
Let nKH : H \subset 'N(K). Proof. exact: subset_trans sHU nKU. Qed.

(* This is B & G, Lemma 6.5(a); note that we do not assume solvability. *)
Lemma pprod_focal_coprime : H :&: G^`(1) = H :&: U^`(1).
Proof.
set G' :=  G^`(1); set U' := U^`(1).
have [sU'U nU'U] := andP (der_normal 1 U : U' <| U).
have{nU'U} nU_U': U :&: _ \subset 'N(U') by move=> A; rewrite subIset ?nU'U.
suffices sHG'U': H :&: G' \subset U'.
  by rewrite -(setIidPl sHG'U') -setIA (setIidPr (dergS 1 sUG)).
rewrite -(setIidPr sHU) -setIA -quotient_sub1 // setICA setIC.
rewrite quotientGI ?subsetI ?sU'U ?dergS ?coprime_TIg //= -/G' -/U'.
have sUG'_UKb: (U :&: G') / U' \subset (U :&: K) / U'.
  rewrite quotientSK // -normC ?group_modr ?setIS //.
  by rewrite -quotientSK ?comm_subG ?quotient_der // -defG quotientMidl.
rewrite (coprimeSg sUG'_UKb) // -(card_isog (second_isog _)) //=.
rewrite setIA (setIidPl sU'U) coprime_morphl ?coprime_morphr //.
exact: coprimeSg (subsetIr U K) coKH.
Qed.

Hypothesis solG : solvable G.

(* This is B & G, Lemma 6.5(c). *)
Lemma pprod_trans_coprime g :
    g \in G -> H :^ g \subset U ->
  exists2 c, c \in 'C_K(H) & exists2 u, u \in U & g = c * u.
Proof.
rewrite -{1}defG => /mulsgP[k u Kk Uu defg] sHgU.
have [sK_KH sH_KH] := joing_sub (erefl (K <*> H)).
have hallH: \pi(H).-Hall(K <*> H :&: U) H.
  rewrite (pHall_subl _ (subsetIl _ _)) ?subsetI ?sH_KH //.
  rewrite /pHall sH_KH pgroup_pi /= joingC norm_joinEl // indexMg -indexgI.
  by rewrite -coprime_pi' ?cardG_gt0 //= coprime_sym coprime_TIg ?indexg1.
have{sHgU} hallHk: \pi(H).-Hall(K <*> H :&: U) (H :^ k).
  rewrite pHallE cardJg (card_Hall hallH) eqxx andbT subsetI andbC.
  rewrite -(conjSg _ _ u) (conjGid Uu) -conjsgM -defg sHgU.
  by rewrite sub_conjg conjGid // groupV (subsetP sK_KH).
have{hallH hallHk} [w KUw defHk]: exists2 w, w \in K :&: U & H :^ k = H :^ w.
  have sKHU_G: K <*> H :&: U \subset G by rewrite setIC subIset ?sUG.
  have [hw KHUhw ->] := Hall_trans (solvableS sKHU_G solG) hallHk hallH.
  have: hw \in H * (K :&: U) by rewrite group_modl // -norm_joinEl // joingC.
  by case/mulsgP=> h w Hh KUw ->; exists w; rewrite // conjsgM (conjGid Hh).
have{KUw} [Kw Uw] := setIP KUw.
exists (k * w^-1); last by exists (w * u); rewrite ?groupM // -mulgA mulKg.
by rewrite -coprime_norm_cent // !inE groupM ?groupV //= conjsgM defHk conjsgK.
Qed.

(* This is B & G, Lemma 6.5(b). *)
Lemma pprod_norm_coprime_prod : 'C_K(H) * 'N_U(H) = 'N_G(H).
Proof.
apply/eqP; rewrite eqEsubset mul_subG ?setISS ?cent_sub //=.
apply/subsetP=> g /setIP[Gg /normP nHg].
have [|c Cc [u Uu defg]] := pprod_trans_coprime Gg; first by rewrite nHg.
rewrite defg mem_mulg // !inE Uu -{2}nHg defg conjsgM conjSg (normP _) //=.
by case/setIP: Cc => _; apply: (subsetP (cent_sub H)).
Qed.

End PprodSubCoprime.

Section Plength1Prod.

Variables (p : nat) (G S : {group gT}).
Hypotheses (sylS : p.-Sylow(G) S) (pl1G : p.-length_1 G).
Let K := 'O_p^'(G).
Let sSG : S \subset G. Proof. by case/andP: sylS. Qed.
Let nsKG : K <| G. Proof. apply: pcore_normal. Qed.
Let sKG : K \subset G. Proof. by case/andP: nsKG. Qed.
Let nKG : G \subset 'N(K). Proof. by case/andP: nsKG. Qed.
Let nKS : S \subset 'N(K). Proof. apply: subset_trans sSG nKG. Qed.
Let coKS : coprime #|K| #|S|.
Proof. exact: p'nat_coprime (pcore_pgroup _ G) (pHall_pgroup sylS). Qed.
Let sSN : S \subset 'N_G(S). Proof. by rewrite subsetI sSG normG. Qed.

Let sylGbp : p.-Sylow(G / K) 'O_p(G / K).
Proof. by rewrite -plength1_pcore_quo_Sylow. Qed.

(* This is B & G, Lemma 6.6(a1); note that we do not assume solvability. *)
Lemma plength1_Sylow_prod : K * S = 'O_{p^',p}(G).
Proof.
by rewrite -quotientK 1?(eq_Hall_pcore sylGbp) ?quotient_pHall //= /K -pseries1.
Qed.

Let sylS_Gp'p : p.-Sylow('O_{p^',p}(G)) S.
Proof.
have [_ sSGp'p] := mulG_sub plength1_Sylow_prod.
exact: pHall_subl sSGp'p (pseries_sub _ _) sylS.
Qed.

(* This is B & G, Lemma 6.6(a2); note that we do not assume solvability. *)
Lemma plength1_Frattini : K * 'N_G(S) = G.
Proof.
rewrite -{2}(Frattini_arg _ sylS_Gp'p) ?pseries_normal //= -plength1_Sylow_prod.
by rewrite -mulgA [S * _]mulSGid // subsetI sSG normG.
Qed.
Local Notation defG := plength1_Frattini.

(* This is B & G, Lemma 6.6(b); note that we do not assume solvability. *)
Lemma plength1_Sylow_sub_der1 : S \subset G^`(1) -> S \subset ('N_G(S))^`(1).
Proof.
by move/setIidPl=> sSG'; apply/setIidPl; rewrite -(pprod_focal_coprime defG).
Qed.

Hypothesis solG : solvable G.

(* This is B & G, Lemma 6.6(c). *)
Lemma plength1_Sylow_trans (Y : {set gT}) g :
    Y \subset S -> g \in G -> Y :^ g \subset S ->
  exists2 c, c \in 'C_G(Y) & exists2 u, u \in 'N_G(S) & g = c * u.
Proof.
rewrite -gen_subG -(gen_subG (Y :^ g)) genJ => sYS Gg sYgS.
have coKY := coprimegS sYS coKS.
have [sYN sYgN] := (subset_trans sYS sSN, subset_trans sYgS sSN).
have [c Cc defg] := pprod_trans_coprime defG nsKG sYN coKY solG Gg sYgN.
by exists c => //; apply: subsetP Cc; rewrite cent_gen setSI.
Qed.

(* This is B & G, Lemma 6.6(d). *)
Lemma plength1_Sylow_Jsub (Q : {group gT}) :
    Q \subset G -> p.-group Q ->
  exists2 x, x \in 'C_G(Q :&: S) & Q :^ x \subset S.
Proof.
move=> sQG pQ; have sQ_Gp'p: Q \subset 'O_{p^',p}(G).
  rewrite -sub_quotient_pre /= pcore_mod1 ?(subset_trans sQG) //.
  by rewrite (sub_Hall_pcore sylGbp) ?quotientS ?quotient_pgroup.
have [xy /= KSxy sQxyS] := Sylow_Jsub sylS_Gp'p sQ_Gp'p pQ.
rewrite -plength1_Sylow_prod in KSxy; have [x y Kx Sy def_xy] := mulsgP KSxy.
have{sQxyS} sQxS: Q :^ x \subset S.
  by rewrite -(conjSg _ _ y) (conjGid Sy) -conjsgM -def_xy.
exists x; rewrite // inE (subsetP sKG) //; apply/centP=> z; case/setIP=> Qz Sz.
apply/commgP; rewrite -in_set1 -set1gE -(coprime_TIg coKS) inE.
rewrite groupMl ?groupV ?memJ_norm ?(subsetP nKS) ?Kx //=.
by rewrite commgEr groupMr // (subsetP sQxS) ?memJ_conjg ?groupV.
Qed.

End Plength1Prod.

End OneType.

(* This is B & G, Theorem 6.7 *)
Theorem plength1_norm_pmaxElem gT p (G E L : {group gT}) :
    E \in 'E*_p(G) -> odd p -> solvable G -> p.-length_1 G ->
    L \subset G -> E \subset 'N(L) -> p^'.-group L ->
  L \subset 'O_p^'(G).
Proof.
move=> maxE p_odd solG pl1G sLG nEL p'L.
case p_pr: (prime p); last first.
  by rewrite pcore_pgroup_id // p'groupEpi mem_primes p_pr.
wlog Gp'1: gT G E L maxE solG pl1G sLG nEL p'L / 'O_p^'(G) = 1.
  set K := 'O_p^'(G); have [sKG nKG] := andP (pcore_normal _ G : K <| G).
  move/(_ _ (G / K) (E / K) (L / K))%G; rewrite morphim_sol ?plength1_quo //.
  rewrite morphimS ?morphim_norms ?quotient_pgroup // trivg_pcore_quotient.
  rewrite (quotient_sub1 (subset_trans sLG nKG)) => -> //.
  have [EpE _] := pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE.
  apply/pmaxElemP; rewrite inE quotient_abelem ?quotientS //.
  split=> // Fb; case/pElemP=> sFbG abelFb; have [pFb _ _] := and3P abelFb.
  have [S sylS sES] := Sylow_superset sEG (abelem_pgroup abelE).
  have [sSG pS _] := and3P sylS; have nKS := subset_trans sSG nKG.
  have: (E / K)%G \in 'E*_p(S / K).
    have: E \in 'E*_p(S) by rewrite (subsetP (pmaxElemS p sSG)) // inE maxE inE.
    have coKS: coprime #|K| #|S| := p'nat_coprime (pcore_pgroup _ _) pS.
    have [injK imK] := isomP (quotient_isom nKS (coprime_TIg coKS)).
    by rewrite -(injm_pmaxElem injK) ?imK ?inE //= morphim_restrm (setIidPr _).
  case/pmaxElemP=> _; apply; rewrite inE abelFb andbT.
  rewrite (sub_normal_Hall (quotient_pHall _ sylS)) //= -quotientMidl /= -/K.
  by rewrite plength1_Sylow_prod // quotient_pseries2 pcore_normal.
have [EpE _] := pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE.
have [S sylS sES] := Sylow_superset sEG (abelem_pgroup abelE).
have [sSG pS _] := and3P sylS; have oddS: odd #|S| := odd_pgroup_odd p_odd pS.
have defS: S :=: 'O_p(G) by apply eq_Hall_pcore; rewrite -?plength1_pcore_Sylow.
have coSL: coprime #|S| #|L| := pnat_coprime pS p'L.
have tiSL: S :&: L = 1 := coprime_TIg coSL.
have{solG} scSG: 'C_G(S) \subset S.
  by rewrite defS -Fitting_eq_pcore ?cent_sub_Fitting.
rewrite Gp'1 -tiSL subsetIidr (subset_trans _ scSG) // subsetI sLG /=.
have nSL: L \subset 'N(S) by rewrite (subset_trans sLG) // defS gFnorm.
have cLE: L \subset 'C(E).
  by rewrite (sameP commG1P trivgP) -tiSL setIC commg_subI ?(introT subsetIP).
have maxES: E \in 'E*_p(S) by rewrite (subsetP (pmaxElemS p sSG)) ?(maxE, inE).
have EpE: E \in 'E_p(S) by apply/setIdP.
by rewrite (coprime_odd_faithful_cent_abelem EpE) ?(pmaxElem_LdivP p_pr maxES).
Qed.

End Six.


From Coq Require Import OrderedType.
From mathcomp Require Import ssreflect ssrbool ssrnat seq eqtype ssrfun.
From ssrlib Require Import SsrOrder Compatibility Lists.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Lemmas for sequences of Type *)

Section SeqLemmas.

  Variable A : Type.

  Variable B : Type.

  Variable default : A.

  Lemma in_cat (x : A) (s1 s2 : seq A) :
    In x (s1 ++ s2) -> In x s1 \/ In x s2.
  Proof.
    elim: s1 s2 => [| y s1 IH] s2 /=.
    - move=> H; right; assumption.
    - case => H.
      + left; left; assumption.
      + case: (IH _ H) => {}H.
        * left; right; assumption.
        * right; assumption.
  Qed.

  Lemma in_cat_l (x : A) (s1 s2 : seq A) :
    In x s1 -> In x (s1 ++ s2).
  Proof.
    elim: s1 s2 => [| y s1 IH] s2 //=. case => H.
    + left; assumption.
    + right; exact: (IH _ H).
  Qed.

  Lemma in_cat_r (x : A) (s1 s2 : seq A) :
    In x s2 -> In x (s1 ++ s2).
  Proof.
    elim: s1 s2 => [| y s1 IH] s2 //=. move=> H; right; exact: (IH _ H).
  Qed.

  Lemma in_singleton (x y : A) :
    In x [:: y] -> x = y.
  Proof. by case => //=. Qed.

  Lemma singleton_seq (l : seq A) :
    size l = 1%N -> exists x : A, l = x :: nil.
  Proof.
    elim: l => //=.
    move=> hd tl; elim tl => //=.
    move=> _ _; exists hd.
    reflexivity.
  Qed.

  Lemma last_decomp (l : seq A) (n : nat) :
    size l = (n + 1)%N -> exists s x, l = rcons s x.
  Proof.
    move: l n. apply: last_ind => /=.
    - by case.
    - move=> l x IH n H. exists l; exists x; reflexivity.
  Qed.

  Lemma last_default_irrelevant (l : seq A) (n : nat) b1 b2 :
    size l = (n + 1)%N -> last b1 l = last b2 l.
  Proof.
    move: l n b1 b2. apply: last_ind => /=.
    - move=> n b1 b2; by case n.
    - move=> l lst IH n b1 b2 H. rewrite !last_rcons. reflexivity.
  Qed.

  Lemma nth_cons (x : A) (l : list A) (n : nat) :
    0 < n -> nth default (x::l) n = nth default l (n - 1).
  Proof. case: n => //=. move=> n _. by rewrite subn1 -pred_Sn. Qed.

  Lemma nth_tl (l : list A) (n : nat) : nth default (tl l) n = nth default l (n + 1).
  Proof.
    case: l => [| x l] //=.
    - by rewrite 2!nth_nil.
    - rewrite nth_cons; last by rewrite addn_gt0 orbT. by rewrite addn1 subn1 -pred_Sn.
  Qed.

  Lemma drop_take (s : seq A) n m :
    n <= m -> m < size s -> drop (m - n) (take m s) = take n (drop (m - n) s).
  Proof.
    elim: s n m => [| x s IH] n m Hnm Hms //. rewrite /= in Hms.
    case: m Hnm Hms.
    - rewrite leqn0 => /eqP ->. rewrite subnn drop0 take0. reflexivity.
    - move=> m Hnm Hms. rewrite -(addn1 m) -(addn1 (size s)) ltn_add2r in Hms.
      rewrite leq_eqVlt in Hnm. case/orP: Hnm => Hnm.
      + rewrite (eqP Hnm) subnn !drop0. reflexivity.
      + rewrite ltnS in Hnm. rewrite take_cons. rewrite !(subSn Hnm) !drop_cons.
        exact: (IH _ _ Hnm Hms).
  Qed.

  Lemma take_take (s : seq A) (n m : nat) : take n (take m s) = take (minn n m) s.
  Proof.
    elim: s n m => [| x s IH] n m //.
    case: m => [| m] //. case: n => [| n] //. rewrite minnSS.
    rewrite !take_cons. rewrite IH. reflexivity.
  Qed.

  Lemma nseq_addn (x : A) n m : nseq (n + m) x = nseq n x ++ nseq m x.
  Proof.
    elim: n m => [| n IHn] m //=. rewrite IHn. reflexivity.
  Qed.

  Lemma drop_nseq (x : A) n m : drop n (nseq m x) = nseq (m - n) x.
  Proof.
    case Hnm: (m <= n).
    - rewrite -{1}(subnK Hnm). rewrite -drop_drop.
      have Hm: m = size (nseq m x) by rewrite size_nseq.
      rewrite {2}Hm. rewrite drop_size /=. rewrite -subn_eq0 in Hnm.
      rewrite (eqP Hnm) /=. reflexivity.
    - move/idP/negP: Hnm. rewrite -ltnNge => Hnm. move: (subnK (ltnW Hnm)) => H.
      rewrite -{1}H. rewrite addnC nseq_addn.
      rewrite drop_size_cat; last by rewrite size_nseq. reflexivity.
  Qed.

  Lemma take_nseq (x : A) n m : take n (nseq m x) = nseq (minn n m) x.
  Proof.
    case Hnm: (n <= m).
    - move/minn_idPl: (Hnm) => ->. move: (subnK Hnm) => <-.
      rewrite addnC nseq_addn. rewrite take_size_cat; last by rewrite size_nseq.
      reflexivity.
    - move/idP/negP: Hnm. rewrite -ltnNge => Hnm.
      move/minn_idPr: (ltnW Hnm) => ->. rewrite take_oversize; first by reflexivity.
      rewrite size_nseq. exact: (ltnW Hnm).
  Qed.

  Lemma drop_nseq_more (s : seq A) (x : A) n m :
    n <= m -> drop n s = nseq (size s - n) x -> drop m s = nseq (size s - m) x.
  Proof.
    move=> Hmn Hdn. move: (subnK Hmn) => H. rewrite -{1}H.
    rewrite -drop_drop. rewrite Hdn. rewrite drop_nseq. rewrite -subnDA.
    rewrite addnC H. reflexivity.
  Qed.

  Lemma take_nseq_less_minn (s : seq A) (x : A) n m :
    m <= n -> take n s = nseq (minn n (size s)) x ->
    take m s = nseq (minn m (size s)) x.
  Proof.
    move=> Hmn. case Hns: (n <= size s).
    - move/minn_idPl: (Hns) => ->. move/minn_idPl: (leq_trans Hmn Hns) => ->.
      elim: s n m Hmn Hns => [| e s IH] n m Hmn Hns.
      + rewrite leqn0 in Hns. rewrite (eqP Hns) in Hmn.
        rewrite leqn0 in Hmn. rewrite (eqP Hmn). reflexivity.
      + case: n Hmn Hns => [| n] Hmn Hns.
        * rewrite leqn0 in Hmn. rewrite (eqP Hmn). reflexivity.
        * case: m Hmn => [| m] Hmn.
          -- reflexivity.
          -- rewrite /= !ltnS in Hmn Hns. rewrite !take_cons.
             rewrite -(addn1 n) -(addn1 m). rewrite (addnC n) (addnC m).
             rewrite !nseq_addn /=. case => -> H.
             rewrite (IH _ _ Hmn Hns H). reflexivity.
    - move/idP/negP: Hns. rewrite -ltnNge => Hsn. move/minn_idPr: (ltnW Hsn) => ->.
      rewrite (take_oversize (ltnW Hsn)). move=> ->. rewrite size_nseq.
      case Hms: (m <= size s).
      + rewrite take_nseq. move/minn_idPl: (Hms) => ->. reflexivity.
      + move/idP/negP: Hms. rewrite -ltnNge => Hsm. move/minn_idPr: (ltnW Hsm) => ->.
        rewrite take_oversize; first reflexivity.
        rewrite size_nseq. exact: (ltnW Hsm).
  Qed.

  Lemma take_nseq_less (s : seq A) (x : A) n m :
    m <= n -> n <= size s -> take n s = nseq n x -> take m s = nseq m x.
  Proof.
    move=> Hmn Hns. move/minn_idPl: (leq_trans Hmn Hns) => {2}<-.
    move/minn_idPl: (Hns) => {2}<-. exact: (take_nseq_less_minn Hmn).
  Qed.

  Lemma catsl_inj (s1 s2 s3 : seq A) : s1 ++ s2 = s1 ++ s3 -> s2 = s3.
  Proof. elim: s1 s2 s3 => [| hd tl IH] s2 s3 //=. case. exact: IH. Qed.

  Lemma catsr_inj (s1 s2 s3 : seq A) : s2 ++ s1 = s3 ++ s1 -> s2 = s3.
  Proof.
    elim: s1 s2 s3 => [| hd tl IH] s2 s3 /=.
    - rewrite !cats0. by apply.
    - rewrite -!cat_rcons. move=> H. move: (IH _ _ H) => {} H.
      move: (rcons_inj H). case. by apply.
  Qed.

  Lemma In_rcons x (s : seq A) l :
    List.In x (rcons s l) <-> List.In x s \/ x = l.
  Proof.
    elim: s => [| hd tl IH] /=.
    - split; case=> H //=.
      + right. symmetry. assumption.
      + left; symmetry. assumption.
    - move: IH=> [IH1 IH2]. split; case => H /=.
      + left; left. assumption.
      + case: (IH1 H) => {} H.
        * left; right; assumption.
        * right; assumption.
      + case: H => H.
        * left; assumption.
        * right. exact: (IH2 (or_introl H)).
      + right. exact: (IH2 (or_intror H)).
  Qed.

  Lemma incl_consl (a : A) (l m : seq A) :
    incl (a :: l) m -> In a m /\ incl l m.
  Proof.
    move=> H. split.
    - apply: (H a). exact: in_eq.
    - move=> x Hinx. apply: (H x). apply: List.in_cons. assumption.
  Qed.

  Lemma incl_empty (s : seq A) :
    incl s [::] -> s = [::].
  Proof.
    elim: s => [| x s IH] //=. move=> H. move: (incl_consl H) => [H1 H2].
    apply: False_ind. exact: (List.in_nil H1).
  Qed.

  Lemma split_cons (x : A * B) (s : seq (A * B)) :
    split (x::s) = (x.1::(split s).1, x.2::(split s).2).
  Proof.
    rewrite /=. case Hs: (split s) => [sa sb] /=. case: x => [xa xb] /=.
    reflexivity.
  Qed.

  Lemma split_cat (s1 s2 : seq (A * B)) :
    split (s1 ++ s2) = ((split s1).1 ++ (split s2).1, (split s1).2 ++ (split s2).2).
  Proof.
    elim: s1 => [| [hd1a hd1b] tl1 IH] //=.
    - by case: (split s2).
    - move: IH. case: (split (tl1 ++ s2)) => [cs1 cs2].
      case: (split tl1) => [tl11 tl12]. case: (split s2) => [tl21 tl22] /=.
      case=> ? ?; subst. reflexivity.
  Qed.

  Lemma split_rcons (s : seq (A * B)) (x : A * B) :
    split (rcons s x) = (rcons (split s).1 x.1, rcons (split s).2 x.2).
  Proof.
    move: s x. apply: last_ind.
    - move=> [xa xb] /=. reflexivity.
    - move=> s [ya yb] IH [xa xb] /=. rewrite IH /=.
      rewrite -(cats1 s) rcons_cat. rewrite split_cat /=.
      rewrite -cats1 cat_rcons. rewrite -cats1 cat_rcons. reflexivity.
  Qed.

  Lemma split_rev (s : seq (A * B)) :
    split (rev s) = (rev (split s).1, rev (split s).2).
  Proof.
    elim: s => [| [hda hdb] tl IH] //=. rewrite rev_cons.
    rewrite split_rcons. rewrite IH /=. case: (split tl) => [s1 s2] /=.
    rewrite !rev_cons. reflexivity.
  Qed.

  Lemma catrevs0 (s : seq A) : catrev s [::] = rev s.
  Proof. by rewrite catrevE cats0. Qed.

  Lemma catrev0s (s : seq A) : catrev [::] s = s.
  Proof. reflexivity. Qed.

  Lemma in_map_exists (s : seq A) (f : A -> B) (x : B) :
    In x (map f s) -> exists y, In y s /\ x = f y.
  Proof.
    elim: s => [| hd tl IH] //=. case=> Hin.
    - subst. exists hd. tauto.
    - move: (IH Hin) => [y [Hiny Hxy]]. exists y. tauto.
  Qed.

  Lemma In_rev x (s : seq A) :
    In x (rev s) <-> In x s.
  Proof.
    elim: s => [| e s IH] //=. move: IH => [IH1 IH2].
    rewrite rev_cons. split => H.
    - case/In_rcons: H => H.
      + right; exact: (IH1 H).
      + left; rewrite H; reflexivity.
    - apply/In_rcons. case: H => H.
      + right; rewrite H; reflexivity.
      + left; exact: (IH2 H).
  Qed.

  Lemma catrev_rev (s1 s2 : seq A) :
    catrev (rev s1) s2 = s1 ++ s2.
  Proof.
    move: s1 s2. apply: last_ind => [| s1 x1 IH1] s2 //=.
    rewrite rev_rcons /= IH1. rewrite cat_rcons. reflexivity.
  Qed.

  (* all, has, Forall, and Exists *)

  Lemma all_Forall (P : pred A) (s : seq A) :
    all P s <-> Forall P s.
  Proof.
    split.
    - elim: s => [| e s IH] //=. move/andP=> [H1 H2]. move: (IH H2) => {}H2.
      by apply: Forall_cons.
    - elim: s => [| e s IH] //=. move=> /Forall_cons_iff [H1 H2].
      by rewrite H1 (IH H2).
  Qed.

  Lemma all_forall (P : pred A) (s : seq A) :
    all P s <-> (forall e, In e s -> P e).
  Proof.
    split => H.
    - apply/Forall_forall. apply/all_Forall. assumption.
    - apply/all_Forall. apply/Forall_forall. assumption.
  Qed.

  Lemma has_Exists (P : pred A) (s : seq A) :
    has P s <-> Exists P s.
  Proof.
    split.
    - elim: s => [| e s IH] //=. case/orP=> H.
      + apply: Exists_cons_hd. assumption.
      + apply: Exists_cons_tl. exact: (IH H).
    - elim: s => [| e s IH] //=.
      + move/Exists_nil. by elim.
      + case/Exists_cons => H.
        * by rewrite H.
        * by rewrite (IH H) orbT.
  Qed.

  Lemma has_exists (P : pred A) (s : seq A) :
    has P s <-> exists e, In e s /\ P e.
  Proof.
    split.
    - move/has_Exists. move/Exists_exists. by apply.
    - move/Exists_exists. move/has_Exists. by apply.
  Qed.

  Lemma all_flatten (P : pred A) (ss : seq (seq A)) :
    all P (flatten ss) = all (all P) ss.
  Proof.
    elim: ss => [| s ss IH] //=. rewrite all_cat IH. reflexivity.
  Qed.

  Lemma has_flatten (P : pred A) (ss : seq (seq A)) :
    has P (flatten ss) = has (has P) ss.
  Proof.
    elim: ss => [| s ss IH] //=. rewrite has_cat IH. reflexivity.
  Qed.

  Lemma all_in (P : pred A) (s : seq A) (x : A) :
    all P s -> In x s -> P x.
  Proof. move/all_forall. by apply. Qed.

End SeqLemmas.

(** Lemmas for foldl and folr *)

Section Fold.

  Context {A : Type} {B : Type} {R : relation B} {E : Equivalence R}.

  Context {f : B -> A -> B}.

  Context {g : A -> B -> B}.

  Context {Rf_swap : forall (a1 a2 : A) (b : B),
              R (f (f b a1) a2) (f (f b a2) a1)}.

  Context {R_foldl : forall (b1 b2 : B) (ls : seq A),
              R b1 b2 -> R (foldl f b1 ls) (foldl f b2 ls)}.

  Lemma foldl_fold_left a s : foldl f a s = fold_left f s a.
  Proof. by elim: s a => [| x s IH] a //=. Qed.

  Lemma foldr_fold_right a s : foldr g a s = fold_right g a s.
  Proof. reflexivity. Qed.

  Lemma foldl_map {C : Type} (h : C -> A) r s :
    foldl f r (map h s) = foldl (fun x y => f x (h y)) r s.
  Proof. by elim: s r => [| x s IH] r //=. Qed.

  Lemma foldl_cons (hd : A) (tl : seq A) (r : B) :
    R (foldl f r (hd::tl)) (f (foldl f r tl) hd).
  Proof.
    elim: tl hd r => /=.
    - move=> hd r. reflexivity.
    - move=> tl_hd tl_tl IH hd r. rewrite -(IH hd (f r tl_hd)).
      move: (Rf_swap tl_hd hd r) => H. rewrite (R_foldl _ H). reflexivity.
  Qed.

  Lemma flodr_cons r x s : foldr g r (x::s) = g x (foldr g r s).
  Proof. reflexivity. Qed.

  Lemma foldr_rev r s : foldr g r (rev s) = foldl (fun r x => g x r) r s.
  Proof.
    elim: s r => [| x s IH] r //=. rewrite rev_cons foldr_rcons. rewrite IH.
    reflexivity.
  Qed.

End Fold.

(** Tail-recursive flatten, the result is the reverse of flatten *)

Section TailRecursiveFlatten.

  Context {A : Type}.

  Definition tflatten (ss : seq (seq A)) := foldl (fun r s => catrev s r) [::] ss.

  Lemma tflatten_flatten ss : tflatten ss = rev (flatten ss).
  Proof.
    rewrite /tflatten. rewrite -(cats0 (rev (flatten ss))).
    move: [::]. move: ss. apply: last_ind => [| ss x IH] l //=.
    rewrite flatten_rcons. rewrite rev_cat -catA. rewrite -IH.
    rewrite foldl_rcons. rewrite catrevE. reflexivity.
  Qed.

  Lemma tflatten_cons s ss : tflatten (s::ss) = (tflatten ss) ++ (rev s).
  Proof. rewrite !tflatten_flatten /=. rewrite rev_cat. reflexivity. Qed.

  Lemma tflatten_rcons ss s :
    tflatten (rcons ss s) = rev s ++ tflatten ss.
  Proof. rewrite !tflatten_flatten. rewrite flatten_rcons rev_cat. reflexivity. Qed.

  Lemma tflattens_cat ss1 ss2 :
    tflatten (ss1 ++ ss2) = tflatten ss2 ++ tflatten ss1.
  Proof. rewrite !tflatten_flatten. rewrite flatten_cat rev_cat. reflexivity. Qed.

  Lemma filter_tflatten ss (p : pred A) :
    filter p (tflatten ss) = tflatten [seq filter p i | i <- ss].
  Proof.
    rewrite (tflatten_flatten [seq filter p i | i <- ss]).
    rewrite -filter_flatten. rewrite -filter_rev. rewrite -tflatten_flatten.
    reflexivity.
  Qed.

  Lemma all_tflatten (p : pred A) ss :
    all p (tflatten ss) = all (all p) ss.
  Proof. rewrite tflatten_flatten. rewrite all_rev. exact: all_flatten. Qed.

  Lemma has_tflatten (p : pred A) ss :
    has p (tflatten ss) = has (has p) ss.
  Proof. rewrite tflatten_flatten. rewrite has_rev. exact: has_flatten. Qed.

End TailRecursiveFlatten.

Lemma map_tflatten {A B : Type} (f : A -> B) ss :
  map f (tflatten ss) = tflatten (map (map f) ss).
Proof.
  rewrite (tflatten_flatten (map (map f) ss)). rewrite -map_flatten.
  rewrite -map_rev. rewrite -tflatten_flatten. reflexivity.
Qed.

(* Tail-recursive maps.
   mapr: the result is the reverse of map
   tmap: the result is the same as map *)

Section MapRev.

  Context {A : Type} {B : Type}.

  Variable f : A -> B.

  Fixpoint mapr_rec res es :=
    match es with
    | [::] => res
    | hd::tl => mapr_rec (f hd::res) tl
    end.

  Definition mapr es := mapr_rec [::] es.

  Lemma mapr_rec_rev_map res es : mapr_rec res es = rev (map f es) ++ res.
  Proof.
    elim: es res => [| e es IH] res //=. rewrite IH. rewrite rev_cons.
    rewrite cat_rcons. reflexivity.
  Qed.

  Lemma mapr_rev_map es : mapr es = rev (map f es).
  Proof. rewrite /mapr. rewrite mapr_rec_rev_map. by rewrite cats0. Qed.

  Lemma mapr_map es : mapr es = map f (rev es).
  Proof. rewrite map_rev. exact: mapr_rev_map. Qed.

  Lemma mapr_rec_cons res e es : mapr_rec res (e::es) = mapr_rec (f e::res) es.
  Proof. reflexivity. Qed.

  Lemma mapr_rec_split res es : mapr_rec res es = mapr_rec [::] es ++ res.
  Proof.
    elim: es res => [| e es IH] //= res. rewrite (IH (f e::res)).
    rewrite (IH [:: f e]). rewrite -cat_rcons. rewrite -cats1. reflexivity.
  Qed.

  Lemma mapr_cons e es : mapr (e::es) = rcons (mapr es) (f e).
  Proof.
    rewrite !mapr_map. rewrite rev_cons map_rcons. reflexivity.
  Qed.

  Lemma mapr_rec_rcons res es e :
    mapr_rec res (rcons es e) = f e :: mapr_rec res es.
  Proof. by elim: es res e => [| e1 es IH] //=. Qed.

  Lemma mapr_rcons es e : mapr (rcons es e) = f e :: mapr es.
  Proof. exact: mapr_rec_rcons. Qed.

  Lemma mapr_rec_cat res es1 es2 :
    mapr_rec res (es1 ++ es2) = mapr_rec (mapr_rec res es1) es2.
  Proof. by elim: es1 res es2 => [| e1 es1 IH] res es2 //=. Qed.

  Lemma mapr_cat es1 es2 : mapr (es1 ++ es2) = mapr es2 ++ mapr es1.
  Proof.
    rewrite !mapr_map. rewrite rev_cat map_cat. reflexivity.
  Qed.

  Lemma size_mapr es : size (mapr es) = size es.
  Proof.
    rewrite mapr_map. rewrite size_map size_rev. reflexivity.
  Qed.

  Lemma mapr_rev es : mapr (rev es) = map f es.
  Proof.
    elim: es => [| e es IH] //=. rewrite rev_cons. rewrite mapr_rcons.
    rewrite IH. reflexivity.
  Qed.

  Definition tmap es := mapr (rev es).

  Lemma tmap_map es : tmap es = map f es.
  Proof. rewrite /tmap mapr_rev. reflexivity. Qed.

  Lemma in_tmap e es : In e es -> In (f e) (tmap es).
  Proof.
    rewrite tmap_map. exact: in_map.
  Qed.

End MapRev.

Section FlattenMap.

  Lemma in_flatten {A : Type} x (ss : seq (seq A)) :
    In x (flatten ss) <-> exists s, In s ss /\ In x s.
  Proof.
    elim: ss => [| s ss IH] //=.
    - split => //=. move=> [s H]. tauto.
    - move: IH => [IH1 IH2]. split => H.
      + case: (in_cat H) => {}H.
        * exists s. split; [ by left | assumption ].
        * move: (IH1 H) => [t [Hint Hinx]]. exists t; tauto.
      + move: H => [t [Hint Hinx]]. case: Hint => Hint.
        * subst. apply: in_cat_l. assumption.
        * apply: in_cat_r. apply: IH2. exists t. tauto.
  Qed.

  Lemma in_tflatten {A : Type} x (ss : seq (seq A)) :
    In x (tflatten ss) <-> exists s, In s ss /\ In x s.
  Proof.
    rewrite tflatten_flatten. move: (in_flatten x ss) => Hin. split => H.
    - move/In_rev: H. tauto.
    - apply/In_rev. tauto.
  Qed.

  Lemma in_flatten_map {A B : Type} (f : B -> seq A) x e (s : seq B) :
    In e s ->
    In x (f e) ->
    In x (flatten (map f s)).
  Proof.
    move=> Hine Hinx. apply/in_flatten. exists (f e). split; [| assumption ].
    apply: in_map. assumption.
  Qed.

  Lemma in_tflatten_tmap {A B : Type} (f : B -> seq A) x e (s : seq B) :
    In e s ->
    In x (f e) ->
    In x (tflatten (tmap f s)).
  Proof.
    move=> H1 H2. rewrite tflatten_flatten tmap_map.
    apply/In_rev. exact: (in_flatten_map H1 H2).
  Qed.

End FlattenMap.

(** Tail-recursive append. *)

Section TailRecursiveAppend.

  Context {A : Type}.

  Definition tappend (es1 es2 : seq A) := rev_append (rev es1) es2.

  Lemma tappend_cat es1 es2 : tappend es1 es2 = es1 ++ es2.
  Proof.
    rewrite /tappend. move: es1 es2. apply: last_ind => [| es1 e1 IH1] es2 //=.
    rewrite rev_rcons /=. rewrite IH1. rewrite cat_rcons. reflexivity.
  Qed.

End TailRecursiveAppend.

(** Lemmas for sequences of eqType *)

Section EqSeqLemmas.

  Variable A : eqType.

  Variable B : eqType.

  Lemma singleton_eq (x y : A) : ([::x] == [::y]) = (x == y).
  Proof.
    case H: (x == y).
    - by rewrite (eqP H) eqxx.
    - apply/negP => /eqP [] Heq. by rewrite Heq eqxx in H.
  Qed.

  Lemma in_In (x : A) (s : seq A) : x \in s <-> In x s.
  Proof.
    elim: s => [| y ys IH] //=. rewrite in_cons. case H: (x == y) => /=.
    - split.
      + move=> _. left. rewrite (eqP H). reflexivity.
      + done.
    - split.
      + move=> Hin. right. apply/IH. exact: Hin.
      + case.
        * move=> Hyx; rewrite Hyx eqxx in H; discriminate.
        * move/IH. by apply.
  Qed.

  Lemma map_l_nil (f : A -> B) (l : seq A) :
    (map f l == [::]) = (l == [::]).
  Proof. by case: l. Qed.

  Lemma seq_neq_split (x y : A) (xs ys : seq A) :
    (x::xs != y::ys) = ((x != y) || (xs != ys)).
  Proof.
    rewrite negb_and -/eqseq. case Hxy: (x == y) => /=; by trivial.
  Qed.

  Lemma has_catrev p (l1 l2 : seq A) : has p (catrev l1 l2) = has p l1 || has p l2.
  Proof.
    elim: l1 l2 => [| hd tl IH] l2 //=. rewrite -cat1s catrev_catr has_cat IH /=.
    rewrite orbF (Bool.orb_comm (has p tl)). reflexivity.
  Qed.

  Lemma all_catrev p (l1 l2 : seq A) : all p (catrev l1 l2) = all p l1 && all p l2.
  Proof.
    elim: l1 l2 => [| hd tl IH] l2 //=. rewrite -cat1s catrev_catr all_cat IH /=.
    rewrite andbT (Bool.andb_comm (all p tl)). reflexivity.
  Qed.

  Lemma cat_nseql (x : A) s1 s2 n :
    s1 ++ s2 = nseq n x -> s1 = nseq (size s1) x.
  Proof.
    move=> H. have: size (s1 ++ s2) = size (nseq n x) by rewrite H.
    rewrite size_cat size_nseq => Hn. rewrite -Hn in H.
    rewrite nseq_addn in H. move/eqP: H. rewrite eqseq_cat; last by rewrite size_nseq.
    move/andP=> [/eqP <- _]. reflexivity.
  Qed.

  Lemma cat_nseqr (x : A) s1 s2 n :
    s1 ++ s2 = nseq n x -> s2 = nseq (size s2) x.
  Proof.
    move=> H. have: size (s1 ++ s2) = size (nseq n x) by rewrite H.
    rewrite size_cat size_nseq => Hn. rewrite -Hn in H.
    rewrite nseq_addn in H. move/eqP: H. rewrite eqseq_cat; last by rewrite size_nseq.
    move/andP=> [_ /eqP <-]. reflexivity.
  Qed.

  Lemma in_rcons (x : A) s (y : A) :
    x \in rcons s y = (x \in s) || (x == y).
  Proof. rewrite mem_rcons in_cons orbC. reflexivity. Qed.

  Lemma in_rev (x : A) s :
    (x \in rev s) = (x \in s).
  Proof.
    elim: s => [| y s IH] //=. rewrite rev_cons in_rcons IH in_cons orbC.
    reflexivity.
  Qed.

  Lemma in_split_rev_l {C : Type} (x : A) (s : seq (A * C)) :
    (x \in (split (rev s)).1) = (x \in (split s).1).
  Proof.
    rewrite split_rev /=. rewrite mem_rev. reflexivity.
  Qed.

  Lemma in_split_rev_r {C : Type} (x : B) (s : seq (C * B)) :
    (x \in (split (rev s)).2) = (x \in (split s).2).
  Proof.
    rewrite split_rev /=. rewrite mem_rev. reflexivity.
  Qed.

  (* Tail-recursive filter function, the result is the reverse of filter *)

  Variable p : pred A.

  Definition tfilter es := foldl (fun r x => if p x then x::r else r) [::] es.

  Lemma tfilter_filter es : tfilter es = filter p (rev es).
  Proof.
    rewrite -(cats0 (filter p (rev es))). rewrite /tfilter. rewrite filter_rev.
    move: [::]. elim: es => [| e es IH] r //=. case: (p e).
    - rewrite rev_cons. rewrite cat_rcons. rewrite -IH. reflexivity.
    - exact: IH.
  Qed.

  Lemma tfilter_cat es1 es2 : tfilter (es1 ++ es2) = tfilter es2 ++ tfilter es1.
  Proof.
    rewrite !tfilter_filter. rewrite rev_cat filter_cat. reflexivity.
  Qed.

  Lemma tfilter_rcons es e :
    tfilter (rcons es e) = if p e
                           then e::(tfilter es)
                           else tfilter es.
  Proof.
    rewrite !tfilter_filter. rewrite rev_rcons /=. reflexivity.
  Qed.

  Lemma tfilter_cons e es :
    tfilter (e::es) = if p e
                      then rcons (tfilter es) e
                      else tfilter es.
  Proof.
    rewrite !tfilter_filter. rewrite rev_cons filter_rcons. reflexivity.
  Qed.

  Lemma tfilter_nil : tfilter [::] = [::].
  Proof. reflexivity. Qed.

End EqSeqLemmas.

(* Tail-recursive zip *)

Section TailRecursiveZip.

  Context {A : Type} {B : Type}.

  Fixpoint zipr_rec res_rev (xs : seq A) (ys : seq B) : seq (A * B) :=
    match xs, ys with
    | _, [::]
    | [::], _ => res_rev
    | x::xs, y::ys => zipr_rec ((x, y)::res_rev) xs ys
    end.

  Definition zipr (xs : seq A) (ys : seq B) : seq (A * B) := zipr_rec [::] xs ys.

  Definition unzip1r := mapr (@fst A B).

  Definition unzip2r := mapr (@snd A B).

  Lemma zipr_rec_cons r x xs y ys : zipr_rec r (x::xs) (y::ys) = zipr_rec ((x, y)::r) xs ys.
  Proof. reflexivity. Qed.

  Lemma zipr_zip xs ys : zipr xs ys = rev (zip xs ys).
  Proof.
    rewrite /zipr. rewrite -(cats0 (rev (zip xs ys))). move: [::].
    elim: xs ys => [| x xs IHx] [| y ys] r //=. rewrite IHx. rewrite rev_cons.
    rewrite cat_rcons. reflexivity.
  Qed.

  Lemma unzip1r_unzip1 s : unzip1r s = rev (unzip1 s).
  Proof. rewrite /unzip1r. rewrite mapr_map map_rev. reflexivity. Qed.

  Lemma unzip2r_unzip2 s : unzip2r s = rev (unzip2 s).
  Proof. rewrite /unzip2r. rewrite mapr_map map_rev. reflexivity. Qed.

  Lemma zipr_cons x xs y ys : zipr (x::xs) (y::ys) = rcons (zipr xs ys) (x, y).
  Proof. rewrite !zipr_zip /=. rewrite rev_cons. reflexivity. Qed.

  Lemma zipr_rcons xs x ys y :
    size xs = size ys -> zipr (rcons xs x) (rcons ys y) = (x, y)::(zipr xs ys).
  Proof.
    move=> Hs. rewrite !zipr_zip. rewrite (zip_rcons _ _ Hs).
    rewrite rev_rcons. reflexivity.
  Qed.

  Lemma zipr_cat xs1 xs2 ys1 ys2 :
    size xs1 = size ys1 -> zipr (xs1 ++ xs2) (ys1 ++ ys2) = zipr xs2 ys2 ++ zipr xs1 ys1.
  Proof.
    move=> Hs. rewrite !zipr_zip. rewrite (zip_cat _ _ Hs). rewrite rev_cat.
    reflexivity.
  Qed.

  Lemma rev_zipr xs ys : size xs = size ys -> rev (zipr xs ys) = zipr (rev xs) (rev ys).
  Proof.
    move=> Hs. rewrite !zipr_zip. rewrite (rev_zip Hs). reflexivity.
  Qed.

  Lemma unzip1_zipr s t : size s <= size t -> unzip1 (zipr s t) = rev s.
  Proof.
    rewrite zipr_zip => Hs. move: (unzip1_zip Hs). rewrite /unzip1.
    rewrite map_rev. move=> ->. reflexivity.
  Qed.

  Lemma unzip2_zipr s t : size t <= size s -> unzip2 (zipr s t) = rev t.
  Proof.
    rewrite zipr_zip => Hs. move: (unzip2_zip Hs). rewrite /unzip2.
    rewrite map_rev. move=> ->. reflexivity.
  Qed.

  Lemma unzip1r_zipr s t : size s <= size t -> unzip1r (zipr s t) = s.
  Proof.
    rewrite unzip1r_unzip1 => Hs. rewrite (unzip1_zipr Hs). by rewrite revK.
  Qed.

  Lemma unzip2r_zipr s t : size t <= size s -> unzip2r (zipr s t) = t.
  Proof.
    rewrite unzip2r_unzip2 => Hs. rewrite (unzip2_zipr Hs). by rewrite revK.
  Qed.

  Lemma size1_zipr s t : size s <= size t -> size (zipr s t) = size s.
  Proof.
    rewrite zipr_zip => Hs. rewrite size_rev. rewrite (size1_zip Hs). reflexivity.
  Qed.

  Lemma size2_zipr s t : size t <= size s -> size (zipr s t) = size t.
  Proof.
    rewrite zipr_zip => Hs. rewrite size_rev. rewrite (size2_zip Hs). reflexivity.
  Qed.

  Lemma size_zipr xs ys : size (zipr xs ys) = minn (size xs) (size ys).
  Proof. rewrite zipr_zip size_rev size_zip. reflexivity. Qed.

  Lemma nth_zipr x y s t i :
    size s = size t -> nth (x, y) (zipr s t) i = (nth x (rev s) i, nth y (rev t) i).
  Proof.
    move=> Hs. rewrite zipr_zip. rewrite (rev_zip Hs). rewrite nth_zip; first reflexivity.
    rewrite !size_rev; assumption.
  Qed.

  Lemma zipr_map {C : eqType} (f : C -> A) (g : C -> B) (s : seq C) :
    zipr (map f s) (map g s) = mapr (fun x => (f x, g x)) s.
  Proof. rewrite zipr_zip. rewrite zip_map mapr_map map_rev. reflexivity. Qed.

  Lemma zipr_mapr {C : eqType} (f : C -> A) (g : C -> B) (s : seq C) :
    zipr (mapr f s) (mapr g s) = map (fun x => (f x, g x)) s.
  Proof.
    rewrite zipr_zip. rewrite !mapr_map !map_rev.
    rewrite rev_zip; last by rewrite !size_rev !size_map. rewrite !revK.
    rewrite zip_map. reflexivity.
  Qed.

End TailRecursiveZip.

Section ZipLemmas.

  Context {A : eqType} {B : eqType}.

  Lemma unzip1_l_nil (pairs : seq (A * B)) :
    (unzip1 pairs == [::]) = (pairs == [::]).
  Proof. by rewrite /unzip1 map_l_nil. Qed.

  Lemma unzip2_l_nil (pairs : seq (A * B)) :
    (unzip2 pairs == [::]) = (pairs == [::]).
  Proof. by rewrite /unzip2 map_l_nil. Qed.

End ZipLemmas.

Section Map2.

  Context {S T U : Type}.

  Context (f : S -> T -> U).

  (* This function is tail-recursive. *)
  Definition map2 (s : seq S) (t : seq T) : seq U :=
    mapr (fun '(a, b) => f a b) (zipr s t).

  Lemma map2s0 s : map2 s [::] = [::].
  Proof. by case: s. Qed.

  Lemma map20s t : map2 [::] t = [::].
  Proof. by case: t. Qed.

  Lemma map2_cons s ss t tt : map2 (s::ss) (t::tt) = (f s t)::(map2 ss tt).
  Proof. rewrite /map2. rewrite zipr_cons mapr_rcons. reflexivity. Qed.

  Lemma map2_rcons ss s tt t :
    size ss = size tt ->
    map2 (rcons ss s) (rcons tt t) = rcons (map2 ss tt) (f s t).
  Proof.
    move=> Hs. rewrite /map2 (zipr_rcons _ _ Hs). rewrite mapr_cons. reflexivity.
  Qed.

  Lemma map2_cat ss1 ss2 tt1 tt2 :
    size ss1 = size tt1 ->
    map2 (ss1 ++ ss2) (tt1 ++ tt2) = (map2 ss1 tt1) ++ (map2 ss2 tt2).
  Proof.
    move=> Hs. rewrite /map2. rewrite (zipr_cat _ _ Hs). rewrite mapr_cat. reflexivity.
  Qed.

  Lemma map2_equal_size ss tt :
    map2 ss tt = map2 (take (minn (size ss) (size tt)) ss)
                      (take (minn (size ss) (size tt)) tt).
  Proof.
    elim: ss tt => [| s ss IH] [| t tt] //=. rewrite map2_cons. rewrite !minnSS.
    rewrite !take_cons map2_cons. rewrite -IH. reflexivity.
  Qed.

  Lemma map2_size_gt_l ss tt :
    size tt < size ss -> map2 ss tt = map2 (take (size tt) ss) tt.
  Proof.
    move=> Hs. rewrite map2_equal_size /minn. move: (ltn_geF Hs).
    rewrite leq_eqVlt. move/Bool.orb_false_elim => [_ {}Hs]. rewrite Hs take_size.
    reflexivity.
  Qed.

  Lemma map2_size_gt_r ss tt :
    size ss < size tt -> map2 ss tt = map2 ss (take (size ss) tt).
  Proof.
    move=> Hs. rewrite map2_equal_size /minn. rewrite Hs take_size.
    reflexivity.
  Qed.

End Map2.

Section Map2SSS.

  Context {S : Type}.
  Context (f : S -> S -> S).
  Context {f_commutative : commutative f}.
  Context {f_associative : associative f}.
  Context {f_idempotent : idempotent f}.

  Lemma map2_comm xs ys : map2 f xs ys = map2 f ys xs.
  Proof.
    elim: xs ys => [| x xs IH] [| y ys] //=.
    rewrite !map2_cons. rewrite f_commutative IH. reflexivity.
  Qed.

  Lemma map2_assoc xs ys zs : map2 f xs (map2 f ys zs) = map2 f (map2 f xs ys) zs.
  Proof.
    elim: xs ys zs => [| x xs IH] //=.
    - move=> ys zs. rewrite !map20s. reflexivity.
    - case=> [| y ys] //=.
      + move=> zs. rewrite map20s map2s0. reflexivity.
      + case=> [| z zs] //=.
        * rewrite !map2s0. reflexivity.
        * rewrite !map2_cons. rewrite f_associative IH. reflexivity.
  Qed.

  Lemma map2_idem xs : map2 f xs xs = xs.
  Proof.
    elim: xs => [| x xs IH] //=. rewrite map2_cons f_idempotent IH. reflexivity.
  Qed.

End Map2SSS.

Section PrefixOf.

  Variable A : eqType.

  Implicit Type s : seq A.

  Fixpoint prefix_of (s1 s2 : seq A) : bool :=
    match s1 with
    | [::] => true
    | x1::s1 => match s2 with
                | [::] => false
                | x2::s2 => (x1 == x2) && (prefix_of s1 s2)
                end
    end.

  Lemma prefix_of_nil s : prefix_of nil s.
  Proof. done. Qed.

  Lemma prefix_of_is_nil s : prefix_of s nil = (s == nil).
  Proof. by case: s. Qed.

  Lemma prefix_of_take s1 s2 :
    prefix_of s1 s2 = (s1 == take (size s1) s2).
  Proof.
    elim: s1 s2 => [|x1 s1 IH1] /=.
    - by move=> ?; rewrite take0 eqxx.
    - case => //=. move=> x2 s2. rewrite eqseq_cons IH1. reflexivity.
  Qed.

  Lemma prefix_of_size s1 s2 : prefix_of s1 s2 -> size s1 <= size s2.
  Proof.
    rewrite prefix_of_take. move=> /eqP ->. rewrite size_take.
    case H: (size s1 < size s2) => //=. by apply: ltnW.
  Qed.

  Lemma prefix_of_cons x1 s1 x2 s2 :
    prefix_of (x1::s1) (x2::s2) = ((x1 == x2) && prefix_of s1 s2).
  Proof. reflexivity. Qed.

  Lemma prefix_of_rcons s1 s2 x :
    prefix_of s1 s2 -> prefix_of s1 (rcons s2 x).
  Proof.
    elim: s1 s2 x => [| hd1 tl1 IH1] [| hd2 tl2] x //=.
    move=> /andP [/eqP -> Htl]. by rewrite eqxx (IH1 _ _ Htl).
  Qed.

  Lemma prefix_of_cat s1 s2 s3 :
    prefix_of s1 s2 -> prefix_of s1 (s2 ++ s3).
  Proof.
    move: s3 s2. apply: last_ind => [| s3 x IH] s2 Hpre12 //=.
    - rewrite cats0. assumption.
    - rewrite -rcons_cat. apply: prefix_of_rcons. exact: (IH _ Hpre12).
  Qed.

  Lemma prefix_of_belast x s1 s2 :
    prefix_of (x::s1) s2 -> prefix_of (belast x s1) s2.
  Proof.
    elim: s1 s2 x => [| hd1 tl1 IH1] [| hd2 [| tl2_hd tl2_tl]] x //=.
    - by rewrite andbF.
    - move=> /andP [/eqP -> /andP [/eqP -> H]]. rewrite eqxx andTb. apply: IH1.
      by rewrite prefix_of_cons eqxx H.
  Qed.

  Lemma prefix_of_refl s : prefix_of s s.
  Proof. elim: s => //=. move=> ? ? ->; by rewrite eqxx. Qed.

  Lemma prefix_of_antisym s1 s2 : (prefix_of s1 s2 && prefix_of s2 s1) = (s1 == s2).
  Proof.
    elim: s1 s2 => [| hd1 tl1 IH1] /=.
    - move=> s2. rewrite prefix_of_is_nil eq_sym. reflexivity.
    - case=> [|hd2 tl2] => //=. rewrite (andbA ((hd1 == hd2) && prefix_of tl1 tl2)).
      rewrite -(andbA (hd1 == hd2)). rewrite (andbC (prefix_of tl1 tl2)).
      rewrite andbA. rewrite (eq_sym hd2). rewrite Bool.andb_diag. rewrite -andbA.
      rewrite IH1. reflexivity.
  Qed.

  Lemma prefix_of_trans s1 s2 s3 :
    prefix_of s1 s2 -> prefix_of s2 s3 -> prefix_of s1 s3.
  Proof.
    elim: s1 s2 s3 => [| hd1 tl1 IH1] [| hd2 tl2] [| hd3 tl3] //=.
    move=> /andP [/eqP -> H12] /andP [/eqP -> H23].
      by rewrite eqxx (IH1 _ _ H12 H23).
  Qed.

  Lemma prefix_of_cons_ident x s1 s2 :
    prefix_of (x::s1) s2 -> prefix_of s1 s2 -> constant (x::s1).
  Proof.
    elim: s1 s2 x => [| hd1 tl1 IH1] [| hd2 [| tl2_hd tl2_tl]] x //=.
    - by rewrite andbF.
    - move=> /andP [/eqP <- /andP [/eqP <- H1]]. move=> /andP [/eqP -> H2].
      rewrite eqxx andTb. apply: (IH1 _ _ _ H2).
      by rewrite prefix_of_cons eqxx andTb H1.
  Qed.

  Variable default : A.

  Lemma prefix_of_nth s1 s2 i :
    prefix_of s1 s2 -> i < size s1 -> nth default s1 i = nth default s2 i.
  Proof.
    rewrite prefix_of_take. move=> /eqP Hs Hi. rewrite Hs (nth_take _ Hi).
    reflexivity.
  Qed.

End PrefixOf.

Section ExtSeq.

  Context {A : Type} (a : A).
  (* Extend a sequence *)
  Fixpoint extseq (xs ys : seq A) :=
    match xs, ys with
    | _, [::] => [::]
    | [::], _::ys => a::(extseq xs ys)
    | x::xs, y::ys => x::(extseq xs ys)
    end.

  Lemma extseq_cons x xs y ys :
    extseq (x::xs) (y::ys) = x::(extseq xs ys).
  Proof. reflexivity. Qed.

  Lemma extseqs0 xs : extseq xs [::] = [::].
  Proof. by elim: xs => [| x xs IH] //=. Qed.

  Lemma extseq0s ys : extseq [::] ys = nseq (size ys) a.
  Proof.
    elim: ys => [| y ys IH] //=. rewrite IH. reflexivity.
  Qed.

  Lemma extseq_eqsize xs ys : size xs = size ys -> extseq xs ys = xs.
  Proof.
    elim: xs ys => [| x xs IH] [| y ys] //= Hs. move: (eq_add_S _ _ Hs) => {}Hs.
    rewrite (IH _ Hs). reflexivity.
  Qed.

  Lemma extseq_lesize xs ys :
    size xs <= size ys -> extseq xs ys = xs ++ nseq (size ys - size xs) a.
  Proof.
    elim: xs ys => [| x xs IH] [| y ys] //=.
    - move=> _. rewrite extseq0s. reflexivity.
    - move=> Hs. move: (ltnSE Hs) => {}Hs. rewrite subSS. rewrite (IH _ Hs).
      reflexivity.
  Qed.

  Lemma extseq_gesize xs ys : size ys <= size xs -> extseq xs ys = take (size ys) xs.
  Proof.
    elim: xs ys => [| x xs IH] [| y ys] //=. move=> Hs. move: (ltnSE Hs) => {}Hs.
    rewrite (IH _ Hs). reflexivity.
  Qed.

  Lemma size_extseq xs ys : size (extseq xs ys) = size ys.
  Proof.
    case Hseq: (size xs == size ys).
    - rewrite (extseq_eqsize (eqP Hseq)). exact: (eqP Hseq).
    - case/orP: (leq_total (size xs) (size ys)) => Hs.
      + rewrite (extseq_lesize Hs). rewrite seq.size_cat size_nseq.
        rewrite (subnKC Hs). reflexivity.
      + rewrite (extseq_gesize Hs). rewrite size_take. rewrite leq_eqVlt in Hs.
        rewrite eq_sym in Hseq. rewrite Hseq /= in Hs. rewrite Hs. reflexivity.
  Qed.

End ExtSeq.

Module SeqOrderMinimal (X : SsrOrder) <: SsrOrderMinimal.
  Definition t := seq_eqType X.T.
  Definition eqn (x y : t) : bool := x == y.
  Fixpoint ltn (x y : t) : bool :=
    match x, y with
    | _, [::] => false
    | [::], hd::_ => true
    | hd1::tl1, hd2::tl2 => (X.ltn hd1 hd2) || ((hd1 == hd2) && (ltn tl1 tl2))
    end.
  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof.
    elim: x y z.
    - case; first by trivial.
      move=> hdy tly. elim; by trivial.
    - move=> hdx tlx IHx. case; first by trivial.
      move=> hdy tly. case; first by trivial.
      move=> hdz tlz /= /orP H1 /orP H2. case: H1; case: H2.
      + move=> Hyz Hxy. by rewrite (X.lt_trans Hxy Hyz).
      + move=> /andP [Hyz_hd Hyz_tl] Hxy_hd. by rewrite -(eqP Hyz_hd) Hxy_hd.
      + move=> Hyz_hd /andP [Hxy_hd Hxy_tl]. by rewrite (eqP Hxy_hd) Hyz_hd.
      + move=> /andP [Hyz_hd Hyz_tl] /andP [Hxy_hd Hxy_tl].
        by rewrite (eqP Hxy_hd) (eqP Hyz_hd) eqxx (IHx _ _ Hxy_tl Hyz_tl) orbT.
  Qed.
  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof.
    elim: x y.
    - case; by trivial.
    - move=> hdx tlx IHx. case; first by trivial.
      move=> hdy tly /=. rewrite seq_neq_split. case/orP.
      + move=> Hhd. move/negP: (X.lt_not_eq Hhd). by move=> ->.
      + move/andP=> [Hhd Htl]. by rewrite (IHx _ Htl) orbT.
  Qed.
  Definition compare (x y : t) : Compare ltn eqn x y.
    elim: x y.
    - case.
      + by apply: EQ.
      + move=> hdy tly. by apply: LT.
    - move=> hdx tlx IHx. case.
      + by apply: GT.
      + move=> hdy tly. case (X.compare hdx hdy) => Hhd.
        * apply: LT. by rewrite /= Hhd.
        * case: (IHx tly) => Htl.
          -- apply: LT. by rewrite /= Hhd Htl orbT.
          -- apply: EQ. apply/andP; rewrite -/eqseq. split; first assumption.
             rewrite /eq in Htl. apply/eqP. exact: (eqP Htl).
          -- apply: GT. by rewrite /= eq_sym Hhd Htl orbT.
        * apply: GT. by rewrite /= Hhd.
  Defined.
End SeqOrderMinimal.

Module SeqOrder (X : SsrOrder) <: SsrOrder.
  Module Y := SeqOrderMinimal X.
  Module M := MakeSsrOrder Y.
  Include M.
End SeqOrder.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Coq Require Import List Arith Psatz.
From DanTrick Require Import DanTrickLanguage StackLangTheorems.

Definition dantrick_sem_mut_ind_theorem (P: imp_Dan -> list nat -> fun_env -> nat_env -> nat_env -> Prop)
           (P0: aexp_Dan -> list nat -> fun_env -> nat_env -> nat -> Prop)
           (P1: bexp_Dan -> list nat -> fun_env -> nat_env -> bool -> Prop)
           (P2: list aexp_Dan -> list nat -> fun_env -> nat_env -> (list nat) -> Prop): Prop :=
  (forall i dbenv fenv nenv nenv',
      i_Dan i dbenv fenv nenv nenv' ->
      P i dbenv fenv nenv nenv') /\
    (forall a dbenv fenv nenv n,
        a_Dan a dbenv fenv nenv n ->
        P0 a dbenv fenv nenv n) /\
    (forall b dbenv fenv nenv v,
        b_Dan b dbenv fenv nenv v ->
        P1 b dbenv fenv nenv v) /\
    (forall args dbenv fenv nenv vals,
        args_Dan args dbenv fenv nenv vals ->
        P2 args dbenv fenv nenv vals).

Definition dantrick_sem_mut_ind_theorem_P (P: imp_Dan -> list nat -> fun_env -> nat_env -> nat_env -> Prop): forall (i: imp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv nenv': nat_env), i_Dan i dbenv fenv nenv nenv' -> Prop :=
  fun (i: imp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv nenv': nat_env) =>
  fun (_: i_Dan i dbenv fenv nenv nenv') =>
    P i dbenv fenv nenv nenv'.

Definition dantrick_sem_mut_ind_theorem_P0 (P0: aexp_Dan -> list nat -> fun_env -> nat_env -> nat -> Prop) :=
  fun (a: aexp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) (n: nat) =>
  fun (_: a_Dan a dbenv fenv nenv n) =>
    P0 a dbenv fenv nenv n.
Definition dantrick_sem_mut_ind_theorem_P1 (P1: bexp_Dan -> list nat -> fun_env -> nat_env -> bool -> Prop) :=
  fun (b: bexp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) (v: bool) =>
  fun (_: b_Dan b dbenv fenv nenv v) =>
    P1 b dbenv fenv nenv v.
Definition dantrick_sem_mut_ind_theorem_P2 (P2: list aexp_Dan -> list nat -> fun_env -> nat_env -> (list nat) -> Prop) :=
  fun (args: list aexp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) (vals: (list nat)) =>
  fun (_: args_Dan args dbenv fenv nenv vals) =>
    P2 args dbenv fenv nenv vals.

Ltac dantrick_sem_mutual_induction P P0 P1 P2 P_def P0_def P1_def P2_def :=
  pose (dantrick_sem_mut_ind_theorem_P P_def) as P;
  pose (dantrick_sem_mut_ind_theorem_P0 P0_def) as P0;
  pose (dantrick_sem_mut_ind_theorem_P1 P1_def) as P1;
  pose (dantrick_sem_mut_ind_theorem_P2 P2_def) as P2;
  apply (i_Dan_mutind P P0 P1 P2);
  unfold P, P0, P1, P2;
  unfold dantrick_sem_mut_ind_theorem_P, dantrick_sem_mut_ind_theorem_P0, dantrick_sem_mut_ind_theorem_P1, dantrick_sem_mut_ind_theorem_P2;
  unfold P_def, P0_def, P1_def, P2_def.

Ltac dantrick_sem_mutual_induction' P P0 P1 P2 P_term P0_term P1_term P2_term P_def P0_def P1_def P2_def :=
  pose (dantrick_sem_mut_ind_theorem_P P_term) as P;
  pose (dantrick_sem_mut_ind_theorem_P0 P0_term) as P0;
  pose (dantrick_sem_mut_ind_theorem_P1 P1_term) as P1;
  pose (dantrick_sem_mut_ind_theorem_P2 P2_term) as P2;
  apply (i_Dan_mutind P P0 P1 P2);
  unfold P, P0, P1, P2;
  unfold dantrick_sem_mut_ind_theorem_P, dantrick_sem_mut_ind_theorem_P0, dantrick_sem_mut_ind_theorem_P1, dantrick_sem_mut_ind_theorem_P2;
  unfold P_def, P0_def, P1_def, P2_def.


From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
From Undecidability.L Require Import L_facts LM_heap_def.

From Coq Require Import List.
Import Vector.VectorNotations ListNotations.

From Undecidability.TM Require Import TM_facts ProgrammingTools WriteValue CaseList Copy ListTM Hoare.
From Undecidability.TM.L Require Import Alphabets Eval.
From Undecidability.TM.L.CompilerBoolFuns Require Import Compiler_spec Compiler_facts ClosedLAdmissible.

Set Default Proof Using "Type".

Section APP_right.

  Definition APP_right : pTM (sigPro)^+ unit 2 :=
    App _;;
    WriteValue ( [appT]%list) @ [|Fin1|];;
    App _.

  Lemma APP_right_Spec :
    { f & forall s1 s2 : term,
    TripleT ≃≃([],[|Contains _ (compile s1);Contains _ (compile s2)|])
    (f s1 s2) APP_right (fun _ => ≃≃([],[|Contains _ (compile (L.app s1 s2));Void|])) }.
  Proof.
    evar (f : term -> term -> nat).
    eexists f. [f]:intros s1 s2.
    intros s1 s2.
    unfold APP_right.
    hsteps_cbn.
    -rewrite app_assoc.  reflexivity.
    -reflexivity.
    -unfold f. reflexivity.
  Qed.

End APP_right.

Lemma tabulate_nth [X : Type] [n : nat] (v : Vector.t X n): tabulate (fun i => v[@i]) = v.
Proof. induction v;cbn. all:congruence. Qed.

Global Hint Rewrite  Nat.eqb_refl tabulate_nth nth_tabulate: cleanupParamTM.

Ltac cleanupParamTM :=
  try fold Nat.add;rewrite ?Nat.eqb_refl, ?tabulate_nth, ?nth_tabulate;cbn.

Section MK_isVoid.

  Context {Σ : finType}.

  Definition MK_isVoid : pTM Σ^+ unit 1 :=
    Write (inl UNKNOWN).

  Lemma MK_isVoid_Sem :
    RealiseIn MK_isVoid (fun t '(r, t') => t = [| niltape|] -> isVoid (t'[@Fin0])) 1.
  Proof.
    eapply RealiseIn_monotone.
    { unfold MK_isVoid. TM_Correct. }
    easy.
    intros ? [] H ->. hnf in H. cbn in *. rewrite H. hnf. eauto.
  Qed.

  Lemma MK_isVoid_Spec :
   TripleT ≃≃([],[|Custom (eq niltape)|]) 1 MK_isVoid (fun _ => ≃≃([],[|Void|])).
  Proof.
    eapply RealiseIn_TripleT. now apply MK_isVoid_Sem. cbn. intros ? ? ? ? [_ H']%tspecE.
    specialize  (H' Fin0). eapply tspecI. easy. intros i; destruct_fin i;cbn. apply H. now vector_destruct tin.
  Qed.

  Fixpoint MK_isVoid_multi m' : pTM (Σ) ^+ unit m' :=
    match m' with
    0 => Nop
    | S m' => MK_isVoid @ [|Fin0|];;MK_isVoid_multi m'@(tabulate (fun i => Fin.FS i))
    end.

  Lemma helper n m i f:
    injective f ->
      lookup_index_vector (m:=m) (n:=n)
    (tabulate f)
    (f i) = Some i.
  Proof.
    revert n i f. induction m;cbn. easy.
    intros n i f Hinj. specialize (Fin.eqb_eq _ (f i) (f Fin0)) as H'.
    destruct Fin.eqb.
    -destruct H' as [H' _]. specialize (H' eq_refl). apply Hinj in H' as ->. easy.
    -destruct H' as [_ H']. destruct (fin_destruct_S i) as [[i' ->]| ->]. 2:now discriminate H'.
     specialize IHm with (f:= fun m => f (Fin.FS m) ). cbn in IHm. rewrite IHm. easy. intros ? ? ?%Hinj. now apply Fin.FS_inj.
  Qed.

  Instance Proper_tabulate X n: Proper (pointwise_relation _ eq ==> eq) (@tabulate X n).
  Proof.
    unfold pointwise_relation.
    induction n;hnf;intros f g H;cbn. reflexivity. f_equal. apply H. now apply IHn.
  Qed.

  Theorem MK_isVoid_multi_SpecT m' :
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) m')
    (m'*2) (MK_isVoid_multi m')
    (fun _ => ≃≃([],Vector.const Void m')).
  Proof using All.
    induction m';cbn. now hsteps_cbn.
    hstep. {hsteps_cbn;cbn. apply MK_isVoid_Spec. }
    cbn;intros _. rewrite Nat.eqb_refl,tabulate_nth;cbn.
    eapply ConsequenceT.
    {
      eapply LiftTapes_SpecT with (Q:=fun _ => _)(Q':=fun _ => _) (P:= Void:::Vector.const (Custom (eq niltape)) _). now eapply dupfree_tabulate_injective,Fin.FS_inj.
      eapply ConsequenceT . eassumption. 2:cbn;intro;reflexivity. 2:reflexivity.
      unfold Downlift,select. rewrite Vector_map_tabulate. cbn. now rewrite tabulate_nth.
    }
    1,3,4:reflexivity. cbn. intros _.
    rewrite lookup_index_vector_None. 2:{rewrite in_tabulate. intros (?&?). congruence. }
    eapply EntailsI. intros ? [_ H]%tspecE. eapply tspecI. easy. intros i. cbn.
    specialize (H i);cbn in H. destruct (fin_destruct_S i) as [[i' ->]| ->];cbn in H|-*. 2:easy.
    rewrite nth_tabulate in H. rewrite helper in H. easy. hnf. eapply Fin.FS_inj.
  Qed.

End MK_isVoid.
Opaque MK_isVoid_multi.

From Undecidability Require Import TM.L.Transcode.Boollist_to_Enc.
From Undecidability Require Import EncBoolsTM_boolList.

Section mk_init_one.

  Variable Σ : finType.

  Variable s b : Σ^+.
  Variable (H_disj : s <> b).

  Variable (retr_pro : Retract sigPro Σ).
  Variable (retr_list : Retract (sigList bool) Σ).

   (* Tapes:
       0: bs (input, encBoolsTM)
       1: ter (input)
       2: intern, bs als listBool
       3: intern
       4: intern
       5: intern
     *)

  Definition M_init_one : pTM (Σ) ^+ unit 6:=
    encBoolsTM2boollist.M s retr_list @[|Fin0;Fin3|];;
    Rev _ ⇑ retr_list @ [|Fin3;Fin2;Fin4|];;
    BoollistToEnc.M retr_list retr_pro @[|Fin2;Fin3;Fin4;Fin5|];;
    APP_right ⇑ retr_pro  @[|Fin1;Fin3|].

  Lemma M_init_one_Spec :
    { f & forall (bs:list bool) (ter : L.term),
    TripleT ≃≃([],[|Custom (eq (encBoolsTM s b bs));Contains _ (compile ter);Void;Void;Void;Void|])
    (f bs ter) M_init_one (fun _ => ≃≃([],[|Custom (eq (encBoolsTM s b bs));Contains _ (compile (L.app ter (encBoolsL bs)));Void;Void;Void;Void|])) }.
  Proof using H_disj.
    evar (f : list bool -> term -> nat).
    eexists f. [f]:intros bs ter.
    intros bs ter.
    unfold M_init_one.
    hstep. { hsteps_cbn. cbn. eapply (projT2 (encBoolsTM2boollist.SpecT _ H_disj)). }
    cbn. intros _. hstep. { hsteps_cbn. cbn. tspec_ext. } 2:reflexivity.
    cbn. intros _. hstep.
    {
      hsteps_cbn. cbn. eapply ConsequenceT. eapply (projT2 (@BoollistToEnc.SpecT _ _ _) (rev bs)).
      all:cbn. now tspec_ext. now rewrite rev_involutive. reflexivity.
    } 2:reflexivity.
    cbn. intros _. hsteps_cbn.
     now eapply (projT2 (APP_right_Spec)). 1,2:now cbn;tspec_ext.
     subst f. cbn beta. reflexivity.
  Qed.

End  mk_init_one.

Section mk_init.

  Variable Σ : finType.
  Variable s b : Σ^+.
  Variable (H_disj : s <> b).

  Context (retr_pro : Retract sigPro Σ) (retr_bools : Retract (sigList bool) Σ).

  Variable m k : nat.

  Variable sim : term.

  Notation aux n := (Fin.L k (Fin.L m n)) (only parsing).
  Notation auxm n := (Fin.L k (Fin.R 6 n)) (only parsing).
  Notation auxk n := (Fin.R (6 + m) n) (only parsing).

  Fixpoint M_init' k' : (Vector.t (Fin.t k) k') -> pTM (Σ) ^+ unit ((6 + m)+ k).
  Proof using m s retr_bools sim retr_pro.
    simple notypeclasses refine (match k' with
    0 => fun _ => MK_isVoid_multi _ @ [|aux Fin1;aux Fin2;aux Fin3;aux Fin4; aux Fin5|];;
        WriteValue ( (compile sim)) ⇑ retr_pro @ [|aux Fin1|]
    | S k' =>
    fun ren =>
      _;;M_init_one s retr_pro retr_bools @ [|auxk (ren[@Fin0]);aux Fin1;aux Fin2;aux Fin3;aux Fin4;aux Fin5|]
    end). all:try exact _.
    2:{apply (M_init' _ (Vector.tl ren)). }
  Defined. (* because definition *)

  Theorem M_init'_SpecT k' (ren :Vector.t (Fin.t k) k') (v:Vector.t (list bool) k):
  { k &
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (6+m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v)
    k (M_init' ren)
    (fun _ => ≃≃([],
      ([|Custom (eq niltape);
        Contains retr_pro (compile (Vector.fold_right (fun l_i s => L.app s (encBoolsL l_i)) (select ren v) sim))
         ;Void;Void;Void;Void|]++Vector.const (Custom (eq niltape)) m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v))}.
  Proof using All.
    induction ren. all:cbn [compile Vector.fold_left M_init' Vector.tl Vector.caseS].
    {
      eexists. cbn.
      hstep. hsteps_cbn;cbn. exact (MK_isVoid_multi_SpecT 5). cbn;cleanupParamTM. 2:reflexivity.
      hsteps_cbn. reflexivity.
      cleanupParamTM.
      apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
      intros i. clear - i.
      repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
    }
    {
      eexists. cbn. hstep.
      3:reflexivity. now apply (projT2 (IHren)). clear IHren.
      cbn. intros _. hstep. { cbn. rewrite Vector_nth_R,nth_map'. cbn. eapply (projT2 (M_init_one_Spec H_disj _ _)). }
      cbn;fold Nat.add;rewrite Nat.eqb_refl;cbn. intros _.
      apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
      intros i. clear - i.
      repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
      rewrite nth_tabulate. destruct (Fin.eqb _ _) eqn:H'. 2:tauto.
      cbn. eapply Fin.eqb_eq in H' as ->. rewrite Vector_nth_R,nth_map'. cbn. tauto.
    }
  Qed.

  Program Definition startRen := Vectors.tabulate (n:=k) (fun i => Fin.of_nat_lt (n:=k) (p:=k - 1 -proj1_sig (Fin.to_nat i)) _).
  Next Obligation.
  destruct Fin.to_nat;cbn. nia.
  Defined. (* because definition *)

  Lemma startRen_spec A (v:Vector.t A _): select startRen v = Vector.rev v.
  Proof.
    unfold select.
    apply eq_nth_iff'. intros i. rewrite nth_map'.
    unfold startRen.
    unshelve erewrite nth_tabulate, vector_nth_rev. 1:abstract (inv i;nia).
    f_equal.  eapply Fin.of_nat_ext.
  Qed.

  Import CasePair Code.CaseList.

  Definition M_init : pTM (Σ) ^+ unit ((6 + m)+ k) :=
    M_init' startRen.

  Theorem M_init_SpecT (v:Vector.t (list bool) k):
  { k &
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (6+m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v)
    k M_init
    (fun _ => ≃≃([],
      ([|Custom (eq niltape);
        Contains retr_pro (compile (Vector.fold_left (fun s l_i => L.app s (encBoolsL l_i)) sim v));
         Void;Void;Void;Void|]
         ++Vector.const (Custom (eq niltape)) m) ++ Vector.map (fun bs => Custom (eq (encBoolsTM s b bs))) v))}.
  Proof using H_disj.
    eexists. unfold M_init.
    eapply ConsequenceT. eapply (projT2 (M_init'_SpecT _ _)). reflexivity. 2:reflexivity.
    cbn. intros _.
    rewrite vector_fold_left_right with (v:=v), <- (startRen_spec v).
    apply EntailsI. intros t H. eapply tspec_ext. eassumption. easy.
    intros i. clear - i.
    repeat (destruct (fin_destruct_S i) as [(i'&->) | ->];[rename i' into i;cbn| ]);try (intros H;exact H).
  Qed.

End mk_init.

From Undecidability Require Import Enc_to_Boollist.

Section conv_output.

  Variable Σ : finType.
  Variable s b : Σ^+.
  Variable (retr_pro : Retract sigPro Σ).
  Variable (retr_list : Retract (sigList bool) Σ).

  Definition M_out : pTM (Σ) ^+ unit 4 :=
    EncToBoollist.M _ _ @ [|Fin0;Fin2;Fin3|];;
    Boollist2encBoolsTM.M s b _ @ [|Fin2;Fin1;Fin3|].

  Theorem M_out_SpecT bs:
    { k &
    TripleT ≃≃([],[|Contains _ (compile (encBoolsL bs));Custom (eq niltape);Void;Void|])
      k M_out
      (fun _ => ≃≃([],
        ([|Custom (fun _ => True); Custom (eq (encBoolsTM s b bs)); Void;Void|])))}.
  Proof.
    eexists. unfold M_out. hsteps_cbn;cbn.
    -eapply (projT2 (@EncToBoollist.SpecT _ _ _)).
    -eapply (projT2 (Boollist2encBoolsTM.SpecT _ _ _)).
    - cbn. rewrite rev_involutive. tspec_ext. easy.
    -reflexivity.
  Qed.

End conv_output.

Section main.

  Variable k : nat.
  Variable (R : Vector.t (list bool) k -> (list bool) -> Prop).

  Variable s : term.

  Hypothesis Hscl : closed s.

  Variable Hs1 : (forall v, forall m : list bool,
   R v m <->
   L.eval (Vector.fold_left (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) (encBoolsL m)).

  Variable Hs2 : (forall v, forall o : term,
                     L.eval (Vector.fold_left (n := k) (fun (s0 : term) (n : list bool) => L.app s0 (encBoolsL n)) s v) o ->
                     exists m : list bool, o = encBoolsL m).

  Definition n_main := 14.

  Definition Σ : Type := sigList bool + EvalL.Σintern.

  Definition retr_bools : Retract (sigList bool) Σ := (Retract_inl _ _).
  Definition retr_intern : Retract EvalL.Σintern Σ := (Retract_inr _ _).

  Definition retr_closs : Retract (sigList sigHClos) Σ
  := ComposeRetract retr_intern _.
  Definition retr_clos : Retract sigHClos Σ := ComposeRetract retr_closs _.
  Definition retr_pro : Retract sigPro Σ := ComposeRetract retr_clos _.

  Definition sym_s : Σ^+ := inr (inl (sigList_X true)).
  Definition sym_b : Σ^+ := inr (inl (sigList_X false)).

  (*
    auxiliary tapes:

    0    : T

   *)

  Notation aux n := (Fin.L k (Fin.R 1 n)).

  Definition garb : Σ^+ := inl UNKNOWN.

  Definition M_main : pTM (Σ ^+)  unit (1 + n_main + k):=
        M_init sym_s retr_pro retr_bools (1 + n_main - 6) k s ;;
        MK_isVoid_multi _ @ [|aux Fin5;aux Fin6;aux Fin7;aux Fin8;aux Fin9;aux Fin10;aux Fin11;aux Fin12;aux Fin13 |] ;;
        EvalL.M retr_intern retr_pro @ [| aux Fin0 ; aux Fin1 ; aux Fin2; aux Fin5 ; aux Fin6 ; aux Fin7 ; aux Fin8 ; aux Fin9 ; aux Fin10 ; aux Fin11 ; aux Fin12 |] ;;
        M_out sym_s sym_b retr_pro retr_bools @ [|aux Fin0;Fin.L k Fin0;aux Fin7;aux Fin8|].

  Lemma syms_diff : sym_s <> sym_b. Proof. cbv. congruence. Qed.

  Theorem M_main_Spec v:
    Triple ≃≃([],Vector.const (Custom (eq niltape)) (S n_main) ++ Vector.map (fun bs => Custom (eq (encBoolsTM sym_s sym_b bs))) v)
       M_main
      (fun _ t => exists m, t ≃≃ ([R v m]%list,
        (Custom (eq (encBoolsTM sym_s sym_b m)):::Vector.const (Custom (fun _ => True)) _))).
  Proof  using Hscl Hs2 Hs1.
    unfold M_main.
    hstep. { eapply TripleT_Triple,(projT2 (M_init_SpecT syms_diff _ _ _ _ _)). }
    cbn. intros _.
    start_TM.
    hstep. {hsteps_cbn;cbn. eapply TripleT_Triple. exact (MK_isVoid_multi_SpecT 9). }
    cbn;cleanupParamTM. intros _.
    hstep. {eapply LiftTapes_Spec_ex. now smpl_dupfree. cbn. refine (EvalL.Spec _ _ _). now eapply closed_compiler_helper. }
    cbn;cleanupParamTM.
    intros _. eapply Triple_exists_pre. intros s'.
    change (fun x => ?f x) with f.
    hintros Heval%eval_iff. specialize (Hs2 Heval) as (res&->).
    unfold_abbrev.
    eapply Triple_exists_con. eexists res.
    hstep. { eapply Consequence_pre. eapply TripleT_Triple. refine (projT2 (M_out_SpecT _ _ _ _ res)). cbn. reflexivity. }
    cbn;cleanupParamTM. intros _.
    apply Hs1 in Heval.
    eapply EntailsI. intros tin [[] Hin]%tspecE.
    eapply tspecI;cbn. easy.
    intros i. specialize (Hin i). destruct_fin i;try exact Logic.I;cbn in *.
    now simpl_vector. eassumption.
  Qed.

Theorem M_main_SpecT v res:
  R v res -> exists k__steps,
  TripleT ≃≃([],Vector.const (Custom (eq niltape)) (S n_main) ++ Vector.map (fun bs => Custom (eq (encBoolsTM sym_s sym_b bs))) v)
  k__steps M_main
    (fun _ => ≃≃([],Custom (eq (encBoolsTM sym_s sym_b res)):::Vector.const (Custom (fun _ => True)) _)).
Proof  using Hscl Hs2 Hs1.
  unfold M_main. intros ?.
  apply Hs1 in H as H%eval_iff. eapply eval_evalIn in H as [? H].
  (* edestruct EvalL.SpecT'. 2:eassumption. now eapply closed_compiler_helper. *)
  eexists.
  hstep. { eapply (projT2 (M_init_SpecT syms_diff _ _ _ _ _)). } 2:reflexivity.
  cbn. intros _.
  start_TM.
  hstep. {hsteps_cbn;cbn. exact (MK_isVoid_multi_SpecT 9). } 2:reflexivity.
  cbn;cleanupParamTM. intros _.
  hstep. { eapply LiftTapes_SpecT. now smpl_dupfree. cbn. apply @EvalL.SpecT. }
  cbn;cleanupParamTM.
  intros _.
  hstep. now refine (projT2 (M_out_SpecT _ _ _ _ res)).
  cbn;cleanupParamTM. intros _.
  eapply EntailsI. intros tin [[] Hin]%tspecE.
  eapply tspecI;cbn. easy.
  intros i. specialize (Hin i). destruct_fin i;try exact Logic.I;cbn in *.
  now simpl_vector. eassumption. reflexivity.
  Unshelve. 3:easy. now eapply closed_compiler_helper.
Qed.

End main.

Theorem compiler_correct {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) :
  L_bool_computable_closed R -> TM_bool_computable_hoare' R.
Proof.
  intros H.
  destruct H as [sim [cs Hsim]].
  hnf.
  eexists _, _, sym_s, sym_b. split. eapply syms_diff. exists (M_main k sim).
  intros v. split.
  - eapply M_main_Spec. easy. all:firstorder.
  - eapply M_main_SpecT. easy. all:firstorder.
Qed.