(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat div fintype bigop prime.
From mathcomp
Require Import finset fingroup morphism perm action quotient gproduct.
From mathcomp
Require Import cyclic center pgroup nilpotent sylow hall abelian.

(******************************************************************************)
(*  Definition of Frobenius groups, some basic results, and the Frobenius     *)
(* theorem on the number of solutions of x ^+ n = 1.                          *)
(*    semiregular K H <->                                                     *)
(*       the internal action of H on K is semiregular, i.e., no nontrivial    *)
(*       elements of H and K commute; note that this is actually a symmetric  *)
(*       condition.                                                           *)
(*    semiprime K H <->                                                       *)
(*       the internal action of H on K is "prime", i.e., an element of K that *)
(*       centralises a nontrivial element of H must centralise all of H.      *)
(*    normedTI A G L <=>                                                      *)
(*       A is nonempty, strictly disjoint from its conjugates in G, and has   *)
(*       normaliser L in G.                                                   *)
(*    [Frobenius G = K ><| H] <=>                                             *)
(*       G is (isomorphic to) a Frobenius group with kernel K and complement  *)
(*       H. This is an effective predicate (in bool), which tests the         *)
(*       equality with the semidirect product, and then the fact that H is a  *)
(*       proper self-normalizing TI-subgroup of G.                            *)
(*    [Frobenius G with kernel H] <=>                                         *)
(*       G is (isomorphic to) a Frobenius group with kernel K; same as above, *)
(*       but without the semi-direct product.                                 *)
(*    [Frobenius G with complement H] <=>                                     *)
(*       G is (isomorphic to) a Frobenius group with complement H; same as    *)
(*       above, but without the semi-direct product. The proof that this form *)
(*       is equivalent to the above (i.e., the existence of Frobenius         *)
(*       kernels) requires character theory and will only be proved in the    *)
(*       vcharacter.v file.                                                   *)
(*    [Frobenius G] <=> G is a Frobenius group.                               *)
(*    Frobenius_action G H S to <->                                           *)
(*       The action to of G on S defines an isomorphism of G with a           *)
(*       (permutation) Frobenius group, i.e., to is faithful and transitive   *)
(*       on S, no nontrivial element of G fixes more than one point in S, and *)
(*       H is the stabilizer of some element of S, and non-trivial. Thus,     *)
(*        Frobenius_action G H S 'P                                           *)
(*       asserts that G is a Frobenius group in the classic sense.            *)
(*    has_Frobenius_action G H <->                                            *)
(*        Frobenius_action G H S to holds for some sT : finType, S : {set st} *)
(*        and to : {action gT &-> sT}. This is a predicate in Prop, but is    *)
(*        exactly reflected by [Frobenius G with complement H] : bool.        *)
(******************************************************************************)

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

Import GroupScope.

Section Definitions.

Variable gT : finGroupType.
Implicit Types A G K H L : {set gT}.

(* Corresponds to "H acts on K in a regular manner" in B & G. *)
Definition semiregular K H := {in H^#, forall x, 'C_K[x] = 1}.

(* Corresponds to "H acts on K in a prime manner" in B & G. *)
Definition semiprime K H := {in H^#, forall x, 'C_K[x] = 'C_K(H)}.

Definition normedTI A G L := [&& A != set0, trivIset (A :^: G) & 'N_G(A) == L].

Definition Frobenius_group_with_complement G H := (H != G) && normedTI H^# G H.

Definition Frobenius_group G :=
  [exists H : {group gT}, Frobenius_group_with_complement G H].

Definition Frobenius_group_with_kernel_and_complement G K H :=
  (K ><| H == G) && Frobenius_group_with_complement G H.

Definition Frobenius_group_with_kernel G K :=
  [exists H : {group gT}, Frobenius_group_with_kernel_and_complement G K H].

Section FrobeniusAction.

Variables G H : {set gT}.
Variables (sT : finType) (S : {set sT}) (to : {action gT &-> sT}).

Definition Frobenius_action :=
  [/\ [faithful G, on S | to],
      [transitive G, on S | to],
      {in G^#, forall x, #|'Fix_(S | to)[x]| <= 1},
      H != 1
    & exists2 u, u \in S & H = 'C_G[u | to]].

End FrobeniusAction.

Variant has_Frobenius_action G H : Prop :=
  HasFrobeniusAction sT S to of @Frobenius_action G H sT S to.

End Definitions.

Arguments semiregular {gT} K%g H%g.
Arguments semiprime {gT} K%g H%g.
Arguments normedTI {gT} A%g G%g L%g.
Arguments Frobenius_group_with_complement {gT} G%g H%g.
Arguments Frobenius_group {gT} G%g.
Arguments Frobenius_group_with_kernel {gT} G%g K%g.
Arguments Frobenius_group_with_kernel_and_complement {gT} G%g K%g H%g.
Arguments Frobenius_action {gT} G%g H%g {sT} S%g to%act.
Arguments has_Frobenius_action {gT} G%g H%g.

Notation "[ 'Frobenius' G 'with' 'complement' H ]" :=
  (Frobenius_group_with_complement G H)
  (at level 0, G at level 50, H at level 35,
   format "[ 'Frobenius'  G  'with'  'complement'  H ]") : group_scope.

Notation "[ 'Frobenius' G 'with' 'kernel' K ]" :=
  (Frobenius_group_with_kernel G K)
  (at level 0, G at level 50, K at level 35,
   format "[ 'Frobenius'  G  'with'  'kernel'  K ]") : group_scope.

Notation "[ 'Frobenius' G ]" :=
  (Frobenius_group G)
  (at level 0, G at level 50,
   format "[ 'Frobenius'  G ]") : group_scope.

Notation "[ 'Frobenius' G = K ><| H ]" :=
  (Frobenius_group_with_kernel_and_complement G K H)
  (at level 0, G at level 50, K, H at level 35,
   format "[ 'Frobenius'  G  =  K  ><|  H ]") : group_scope.

Section FrobeniusBasics.

Variable gT : finGroupType.
Implicit Types (A B : {set gT}) (G H K L R X : {group gT}).

Lemma semiregular1l H : semiregular 1 H.
Proof. by move=> x _ /=; rewrite setI1g. Qed.

Lemma semiregular1r K : semiregular K 1.
Proof. by move=> x; rewrite setDv inE. Qed.

Lemma semiregular_sym H K : semiregular K H -> semiregular H K.
Proof.
move=> regH x /setD1P[ntx Kx]; apply: contraNeq ntx.
rewrite -subG1 -setD_eq0 -setIDAC => /set0Pn[y /setIP[Hy cxy]].
by rewrite (sameP eqP set1gP) -(regH y Hy) inE Kx cent1C.
Qed.

Lemma semiregularS K1 K2 A1 A2 :
  K1 \subset K2 -> A1 \subset A2 -> semiregular K2 A2 -> semiregular K1 A1.
Proof.
move=> sK12 sA12 regKA2 x /setD1P[ntx /(subsetP sA12)A2x].
by apply/trivgP; rewrite -(regKA2 x) ?inE ?ntx ?setSI.
Qed.

Lemma semiregular_prime H K : semiregular K H -> semiprime K H.
Proof.
move=> regH x Hx; apply/eqP; rewrite eqEsubset {1}regH // sub1G.
by rewrite -cent_set1 setIS ?centS // sub1set; case/setD1P: Hx.
Qed.

Lemma semiprime_regular H K : semiprime K H -> 'C_K(H) = 1 -> semiregular K H.
Proof. by move=> prKH tiKcH x Hx; rewrite prKH. Qed.

Lemma semiprimeS K1 K2 A1 A2 :
  K1 \subset K2 -> A1 \subset A2 -> semiprime K2 A2 -> semiprime K1 A1.
Proof.
move=> sK12 sA12 prKA2 x /setD1P[ntx A1x].
apply/eqP; rewrite eqEsubset andbC -{1}cent_set1 setIS ?centS ?sub1set //=.
rewrite -(setIidPl sK12) -!setIA prKA2 ?setIS ?centS //.
by rewrite !inE ntx (subsetP sA12).
Qed.

Lemma cent_semiprime H K X :
   semiprime K H -> X \subset H -> X :!=: 1 -> 'C_K(X) = 'C_K(H).
Proof.
move=> prKH sXH /trivgPn[x Xx ntx]; apply/eqP.
rewrite eqEsubset -{1}(prKH x) ?inE ?(subsetP sXH) ?ntx //=.
by rewrite -cent_cycle !setIS ?centS ?cycle_subG.
Qed.

Lemma stab_semiprime H K X :
   semiprime K H -> X \subset K -> 'C_H(X) != 1 -> 'C_H(X) = H.
Proof.
move=> prKH sXK ntCHX; apply/setIidPl; rewrite centsC -subsetIidl.
rewrite -{2}(setIidPl sXK) -setIA -(cent_semiprime prKH _ ntCHX) ?subsetIl //.
by rewrite !subsetI subxx sXK centsC subsetIr.
Qed.

Lemma cent_semiregular H K X :
   semiregular K H -> X \subset H -> X :!=: 1 -> 'C_K(X) = 1.
Proof.
move=> regKH sXH /trivgPn[x Xx ntx]; apply/trivgP.
rewrite -(regKH x) ?inE ?(subsetP sXH) ?ntx ?setIS //=.
by rewrite -cent_cycle centS ?cycle_subG.
Qed.

Lemma regular_norm_dvd_pred K H :
  H \subset 'N(K) -> semiregular K H -> #|H| %| #|K|.-1.
Proof.
move=> nKH regH; have actsH: [acts H, on K^# | 'J] by rewrite astabsJ normD1.
rewrite (cardsD1 1 K) group1 -(acts_sum_card_orbit actsH) /=.
rewrite (eq_bigr (fun _ => #|H|)) ?sum_nat_const ?dvdn_mull //.
move=> _ /imsetP[x /setIdP[ntx Kx] ->]; rewrite card_orbit astab1J.
rewrite ['C_H[x]](trivgP _) ?indexg1 //=.
apply/subsetP=> y /setIP[Hy cxy]; apply: contraR ntx => nty.
by rewrite -[[set 1]](regH y) inE ?nty // Kx cent1C.

Qed.

Lemma regular_norm_coprime K H :
  H \subset 'N(K) -> semiregular K H -> coprime #|K| #|H|.
Proof.
move=> nKH regH.
by rewrite (coprime_dvdr (regular_norm_dvd_pred nKH regH)) ?coprimenP.
Qed.

Lemma semiregularJ K H x : semiregular K H -> semiregular (K :^ x) (H :^ x).
Proof.
move=> regH yx; rewrite -conjD1g => /imsetP[y Hy ->].
by rewrite cent1J -conjIg regH ?conjs1g.
Qed.

Lemma semiprimeJ K H x : semiprime K H -> semiprime (K :^ x) (H :^ x).
Proof.
move=> prH yx; rewrite -conjD1g => /imsetP[y Hy ->].
by rewrite cent1J centJ -!conjIg prH.
Qed.

Lemma normedTI_P A G L :
  reflect [/\ A != set0, L \subset 'N_G(A)
           & {in G, forall g, ~~ [disjoint A & A :^ g] -> g \in L}]
          (normedTI A G L).
Proof.
apply: (iffP and3P) => [[nzA /trivIsetP tiAG /eqP <-] | [nzA sLN tiAG]].
  split=> // g Gg; rewrite inE Gg (sameP normP eqP) /= eq_sym; apply: contraR.
  by apply: tiAG; rewrite ?mem_orbit ?orbit_refl.
have [/set0Pn[a Aa] /subsetIP[_ nAL]] := (nzA, sLN); split=> //; last first.
  rewrite eqEsubset sLN andbT; apply/subsetP=> x /setIP[Gx nAx].
  by apply/tiAG/pred0Pn=> //; exists a; rewrite /= (normP nAx) Aa.
apply/trivIsetP=> _ _ /imsetP[x Gx ->] /imsetP[y Gy ->]; apply: contraR.
rewrite -setI_eq0 -(mulgKV x y) conjsgM; set g := (y * x^-1)%g.
have Gg: g \in G by rewrite groupMl ?groupV.
rewrite -conjIg (inj_eq (act_inj 'Js x)) (eq_sym A) (sameP eqP normP).
by rewrite -cards_eq0 cardJg cards_eq0 setI_eq0 => /tiAG/(subsetP nAL)->.
Qed.
Arguments normedTI_P {A G L}.

Lemma normedTI_memJ_P A G L :
  reflect [/\ A != set0, L \subset G
            & {in A & G, forall a g, (a ^ g \in A) = (g \in L)}]
          (normedTI A G L).
Proof.
apply: (iffP normedTI_P) => [[-> /subsetIP[sLG nAL] tiAG] | [-> sLG tiAG]].
  split=> // a g Aa Gg; apply/idP/idP=> [Aag | Lg]; last first.
    by rewrite memJ_norm ?(subsetP nAL).
  by apply/tiAG/pred0Pn=> //; exists (a ^ g)%g; rewrite /= Aag memJ_conjg.
split=> // [ | g Gg /pred0Pn[ag /=]]; last first.
  by rewrite andbC => /andP[/imsetP[a Aa ->]]; rewrite tiAG.
apply/subsetP=> g Lg; have Gg := subsetP sLG g Lg.
by rewrite !inE Gg; apply/subsetP=> _ /imsetP[a Aa ->]; rewrite tiAG.
Qed.

Lemma partition_class_support A G :
  A != set0 -> trivIset (A :^: G) -> partition (A :^: G) (class_support A G).
Proof.
rewrite /partition cover_imset -class_supportEr eqxx => nzA ->.
by apply: contra nzA => /imsetP[x _ /eqP]; rewrite eq_sym -!cards_eq0 cardJg.
Qed.

Lemma partition_normedTI A G L :
  normedTI A G L -> partition (A :^: G) (class_support A G).
Proof. by case/and3P=> ntA tiAG _; apply: partition_class_support. Qed.

Lemma card_support_normedTI A G L :
  normedTI A G L -> #|class_support A G| = (#|A| * #|G : L|)%N.
Proof.
case/and3P=> ntA tiAG /eqP <-; rewrite -card_conjugates mulnC.
apply: card_uniform_partition (partition_class_support ntA tiAG).
by move=> _ /imsetP[y _ ->]; rewrite cardJg.
Qed.

Lemma normedTI_S A B G L :
    A != set0 -> L \subset 'N(A) -> A \subset B -> normedTI B G L ->
  normedTI A G L.
Proof.
move=> nzA /subsetP nAL /subsetP sAB /normedTI_memJ_P[nzB sLG tiB].
apply/normedTI_memJ_P; split=> // a x Aa Gx.
by apply/idP/idP => [Aax | /nAL/memJ_norm-> //]; rewrite -(tiB a) ?sAB.
Qed.

Lemma cent1_normedTI A G L :
  normedTI A G L -> {in A, forall x, 'C_G[x] \subset L}.
Proof.
case/normedTI_memJ_P=> [_ _ tiAG] x Ax; apply/subsetP=> y /setIP[Gy cxy].
by rewrite -(tiAG x) // /(x ^ y) -(cent1P cxy) mulKg.
Qed.

Lemma Frobenius_actionP G H :
  reflect (has_Frobenius_action G H) [Frobenius G with complement H].
Proof.
apply: (iffP andP) => [[neqHG] | [sT S to [ffulG transG regG ntH [u Su defH]]]].
  case/normedTI_P=> nzH /subsetIP[sHG _] tiHG.
  suffices: Frobenius_action G H (rcosets H G) 'Rs by apply: HasFrobeniusAction.
  pose Hfix x := 'Fix_(rcosets H G | 'Rs)[x].
  have regG: {in G^#, forall x, #|Hfix x| <= 1}.
    move=> x /setD1P[ntx Gx].
    apply: wlog_neg; rewrite -ltnNge => /ltnW/card_gt0P/=[Hy].
    rewrite -(cards1 Hy) => /setIP[/imsetP[y Gy ->{Hy}] cHyx].
    apply/subset_leq_card/subsetP=> _ /setIP[/imsetP[z Gz ->] cHzx].
    rewrite -!sub_astab1 !astab1_act !sub1set astab1Rs in cHyx cHzx *.
    rewrite !rcosetE; apply/set1P/rcoset_eqP; rewrite mem_rcoset.
    apply: tiHG; [by rewrite !in_group | apply/pred0Pn; exists (x ^ y^-1)].
    by rewrite conjD1g !inE conjg_eq1 ntx -mem_conjg cHyx conjsgM memJ_conjg.
  have ntH: H :!=: 1 by rewrite -subG1 -setD_eq0.
  split=> //; first 1 last; first exact: transRs_rcosets.
    by exists (val H); rewrite ?orbit_refl // astab1Rs (setIidPr sHG).
  apply/subsetP=> y /setIP[Gy cHy]; apply: contraR neqHG => nt_y.
  rewrite (index1g sHG) //; apply/eqP; rewrite eqn_leq indexg_gt0 andbT.
  apply: leq_trans (regG y _); last by rewrite setDE 2!inE Gy nt_y /=.
  by rewrite /Hfix (setIidPl _) -1?astabC ?sub1set.
have sHG: H \subset G by rewrite defH subsetIl.
split.
  apply: contraNneq ntH => /= defG.
  suffices defS: S = [set u] by rewrite -(trivgP ffulG) /= defS defH.
  apply/eqP; rewrite eq_sym eqEcard sub1set Su.
  by rewrite -(atransP transG u Su) card_orbit -defH defG indexgg cards1.
apply/normedTI_P; rewrite setD_eq0 subG1 normD1 subsetI sHG normG.
split=> // x Gx; rewrite -setI_eq0 conjD1g defH inE Gx conjIg conjGid //.
rewrite -setDIl -setIIr -astab1_act setDIl => /set0Pn[y /setIP[Gy /setD1P[_]]].
case/setIP; rewrite 2!(sameP astab1P afix1P) => cuy cuxy; apply/astab1P.
apply: contraTeq (regG y Gy) => cu'x.
rewrite (cardD1 u) (cardD1 (to u x)) inE Su cuy inE /= inE cu'x cuxy.
by rewrite (actsP (atrans_acts transG)) ?Su.
Qed.

Section FrobeniusProperties.

Variables G H K : {group gT}.
Hypothesis frobG : [Frobenius G = K ><| H].

Lemma FrobeniusWker : [Frobenius G with kernel K].
Proof. by apply/existsP; exists H. Qed.

Lemma FrobeniusWcompl : [Frobenius G with complement H].
Proof. by case/andP: frobG. Qed.

Lemma FrobeniusW : [Frobenius G].
Proof. by apply/existsP; exists H; apply: FrobeniusWcompl. Qed.

Lemma Frobenius_context :
  [/\ K ><| H = G, K :!=: 1, H :!=: 1, K \proper G & H \proper G].
Proof.
have [/eqP defG neqHG ntH _] := and4P frobG; rewrite setD_eq0 subG1 in ntH.
have ntK: K :!=: 1 by apply: contraNneq neqHG => K1; rewrite -defG K1 sdprod1g.
rewrite properEcard properEneq neqHG; have /mulG_sub[-> ->] := sdprodW defG.
by rewrite -(sdprod_card defG) ltn_Pmulr ?cardG_gt1.
Qed.

Lemma Frobenius_partition : partition (gval K |: (H^# :^: K)) G.
Proof.
have [/eqP defG _ tiHG] := and3P frobG; have [_ tiH1G /eqP defN] := and3P tiHG.
have [[_ /mulG_sub[sKG sHG] nKH tiKH] mulHK] := (sdprodP defG, sdprodWC defG).
set HG := H^# :^: K; set KHG := _ |: _.
have defHG: HG = H^# :^: G.
  have: 'C_G[H^# | 'Js] * K = G by rewrite astab1Js defN mulHK.
  move/subgroup_transitiveP/atransP.
  by apply; rewrite ?atrans_orbit ?orbit_refl.
have /and3P[defHK _ nzHG] := partition_normedTI tiHG.
rewrite -defHG in defHK nzHG tiH1G.
have [tiKHG HG'K]: trivIset KHG /\ gval K \notin HG.
  apply: trivIsetU1 => // _ /imsetP[x Kx ->]; rewrite -setI_eq0.
  by rewrite -(conjGid Kx) -conjIg setIDA tiKH setDv conj0g.
rewrite /partition andbC tiKHG !inE negb_or nzHG eq_sym -card_gt0 cardG_gt0 /=.
rewrite eqEcard; apply/andP; split.
  rewrite /cover big_setU1 //= subUset sKG -/(cover HG) (eqP defHK).
  by rewrite class_support_subG // (subset_trans _ sHG) ?subD1set.
rewrite -(eqnP tiKHG) big_setU1 //= (eqnP tiH1G) (eqP defHK).
rewrite (card_support_normedTI tiHG) -(Lagrange sHG) (cardsD1 1) group1 mulSn.
by rewrite leq_add2r -mulHK indexMg -indexgI tiKH indexg1.
Qed.

Lemma Frobenius_cent1_ker : {in K^#, forall x, 'C_G[x] \subset K}.
Proof.
have [/eqP defG _ /normedTI_memJ_P[_ _ tiHG]] := and3P frobG.
move=> x /setD1P[ntx Kx]; have [_ /mulG_sub[sKG _] _ tiKH] := sdprodP defG.
have [/eqP <- _ _] := and3P Frobenius_partition; rewrite big_distrl /=.
apply/bigcupsP=> _ /setU1P[|/imsetP[y Ky]] ->; first exact: subsetIl.
apply: contraR ntx => /subsetPn[z]; rewrite inE mem_conjg => /andP[Hzy cxz] _.
rewrite -(conjg_eq1 x y^-1) -in_set1 -set1gE -tiKH inE andbC.
rewrite -(tiHG _ _ Hzy) ?(subsetP sKG) ?in_group // Ky andbT -conjJg.
by rewrite /(z ^ x) (cent1P cxz) mulKg.
Qed.

Lemma Frobenius_reg_ker : semiregular K H.
Proof.
move=> x /setD1P[ntx Hx].
apply/trivgP/subsetP=> y /setIP[Ky cxy]; apply: contraR ntx => nty.
have K1y: y \in K^# by rewrite inE nty.
have [/eqP/sdprod_context[_ sHG _ _ tiKH] _] := andP frobG.
suffices: x \in K :&: H by rewrite tiKH inE.
by rewrite inE (subsetP (Frobenius_cent1_ker K1y)) // inE cent1C (subsetP sHG).
Qed.

Lemma Frobenius_reg_compl : semiregular H K.
Proof. by apply: semiregular_sym; apply: Frobenius_reg_ker. Qed.

Lemma Frobenius_dvd_ker1 : #|H| %| #|K|.-1.
Proof.
apply: regular_norm_dvd_pred Frobenius_reg_ker.
by have[/sdprodP[]] := Frobenius_context.
Qed.

Lemma ltn_odd_Frobenius_ker : odd #|G| -> #|H|.*2 < #|K|.
Proof.
move/oddSg=> oddG.
have [/sdprodW/mulG_sub[sKG sHG] ntK _ _ _] := Frobenius_context.
by rewrite dvdn_double_ltn ?oddG ?cardG_gt1 ?Frobenius_dvd_ker1.
Qed.

Lemma Frobenius_index_dvd_ker1 : #|G : K| %| #|K|.-1.
Proof.
have[defG _ _ /andP[sKG _] _] := Frobenius_context.
by rewrite -divgS // -(sdprod_card defG) mulKn ?Frobenius_dvd_ker1.
Qed.

Lemma Frobenius_coprime : coprime #|K| #|H|.
Proof. by rewrite (coprime_dvdr Frobenius_dvd_ker1) ?coprimenP. Qed.

Lemma Frobenius_trivg_cent : 'C_K(H) = 1.
Proof.
by apply: (cent_semiregular Frobenius_reg_ker); case: Frobenius_context.
Qed.

Lemma Frobenius_index_coprime : coprime #|K| #|G : K|.
Proof. by rewrite (coprime_dvdr Frobenius_index_dvd_ker1) ?coprimenP. Qed.

Lemma Frobenius_ker_Hall : Hall G K.
Proof.
have [_ _ _ /andP[sKG _] _] := Frobenius_context.
by rewrite /Hall sKG Frobenius_index_coprime.
Qed.

Lemma Frobenius_compl_Hall : Hall G H.
Proof.
have [defG _ _ _ _] := Frobenius_context.
by rewrite -(sdprod_Hall defG) Frobenius_ker_Hall.
Qed.

End FrobeniusProperties.

Lemma normedTI_J x A G L : normedTI (A :^ x) (G :^ x) (L :^ x) = normedTI A G L.
Proof.
rewrite {1}/normedTI normJ -conjIg -(conj0g x) !(can_eq (conjsgK x)).
congr [&&  _, _ == _ & _]; rewrite /cover (reindex_inj (@conjsg_inj _ x)).
  by apply: eq_big => Hy; rewrite ?orbit_conjsg ?cardJg.
by rewrite bigcupJ cardJg (eq_bigl _ _ (orbit_conjsg _ _ _ _)).
Qed.

Lemma FrobeniusJcompl x G H :
  [Frobenius G :^ x with complement H :^ x] = [Frobenius G with complement H].
Proof.
by congr (_ && _); rewrite ?(can_eq (conjsgK x)) // -conjD1g normedTI_J.
Qed.

Lemma FrobeniusJ x G K H :
  [Frobenius G :^ x = K :^ x ><| H :^ x] = [Frobenius G = K ><| H].
Proof.
by congr (_ && _); rewrite ?FrobeniusJcompl // -sdprodJ (can_eq (conjsgK x)).
Qed.

Lemma FrobeniusJker x G K :
  [Frobenius G :^ x with kernel K :^ x] = [Frobenius G with kernel K].
Proof.
apply/existsP/existsP=> [] [H]; last by exists (H :^ x)%G; rewrite FrobeniusJ.
by rewrite -(conjsgKV x H) FrobeniusJ; exists (H :^ x^-1)%G.
Qed.

Lemma FrobeniusJgroup x G : [Frobenius G :^ x] = [Frobenius G].
Proof.
apply/existsP/existsP=> [] [H].
  by rewrite -(conjsgKV x H) FrobeniusJcompl; exists (H :^ x^-1)%G.
by exists (H :^ x)%G; rewrite FrobeniusJcompl.
Qed.

Lemma Frobenius_ker_dvd_ker1 G K :
  [Frobenius G with kernel K] -> #|G : K| %| #|K|.-1.
Proof. by case/existsP=> H; apply: Frobenius_index_dvd_ker1. Qed.

Lemma Frobenius_ker_coprime G K :
  [Frobenius G with kernel K] -> coprime #|K| #|G : K|.
Proof. by case/existsP=> H; apply: Frobenius_index_coprime. Qed.

Lemma Frobenius_semiregularP G K H :
    K ><| H = G -> K :!=: 1 -> H :!=: 1 ->
  reflect (semiregular K H) [Frobenius G = K ><| H].
Proof.
move=> defG ntK ntH.
apply: (iffP idP) => [|regG]; first exact: Frobenius_reg_ker.
have [nsKG sHG defKH nKH tiKH]:= sdprod_context defG; have [sKG _]:= andP nsKG.
apply/and3P; split; first by rewrite defG.
  by rewrite eqEcard sHG -(sdprod_card defG) -ltnNge ltn_Pmull ?cardG_gt1.
apply/normedTI_memJ_P; rewrite setD_eq0 subG1 sHG -defKH -(normC nKH).
split=> // z _ /setD1P[ntz Hz] /mulsgP[y x Hy Kx ->]; rewrite groupMl // !inE.
rewrite conjg_eq1 ntz; apply/idP/idP=> [Hzxy | Hx]; last by rewrite !in_group.
apply: (subsetP (sub1G H)); have Hzy: z ^ y \in H by apply: groupJ.
rewrite -(regG (z ^ y)); last by apply/setD1P; rewrite conjg_eq1.
rewrite inE Kx cent1C (sameP cent1P commgP) -in_set1 -[[set 1]]tiKH inE /=.
rewrite andbC groupM ?groupV -?conjgM //= commgEr groupMr //.
by rewrite memJ_norm ?(subsetP nKH) ?groupV.
Qed.

Lemma prime_FrobeniusP G K H :
    K :!=: 1 -> prime #|H| ->
  reflect (K ><| H = G /\ 'C_K(H) = 1) [Frobenius G = K ><| H].
Proof.
move=> ntK H_pr; have ntH: H :!=: 1 by rewrite -cardG_gt1 prime_gt1.
have [defG | not_sdG] := eqVneq (K ><| H) G; last first.
  by apply: (iffP andP) => [] [defG]; rewrite defG ?eqxx in not_sdG.
apply: (iffP (Frobenius_semiregularP defG ntK ntH)) => [regH | [_ regH x]].
  split=> //; have [x defH] := cyclicP (prime_cyclic H_pr).
  by rewrite defH cent_cycle regH // !inE defH cycle_id andbT -cycle_eq1 -defH.
case/setD1P=> nt_x Hx; apply/trivgP; rewrite -regH setIS //= -cent_cycle.
by rewrite centS // prime_meetG // (setIidPr _) ?cycle_eq1 ?cycle_subG.
Qed.

Lemma Frobenius_subl G K K1 H :
    K1 :!=: 1 -> K1 \subset K -> H \subset 'N(K1) -> [Frobenius G = K ><| H] ->
  [Frobenius K1 <*> H = K1 ><| H].
Proof.
move=> ntK1 sK1K nK1H frobG; have [_ _ ntH _ _] := Frobenius_context frobG.
apply/Frobenius_semiregularP=> //.
  by rewrite sdprodEY ?coprime_TIg ?(coprimeSg sK1K) ?(Frobenius_coprime frobG).
by move=> x /(Frobenius_reg_ker frobG) cKx1; apply/trivgP; rewrite -cKx1 setSI.
Qed.

Lemma Frobenius_subr G K H H1 :
    H1 :!=: 1 -> H1 \subset H -> [Frobenius G = K ><| H] ->
  [Frobenius K <*> H1 = K ><| H1].
Proof.
move=> ntH1 sH1H frobG; have [defG ntK _ _ _] := Frobenius_context frobG.
apply/Frobenius_semiregularP=> //.
  have [_ _ /(subset_trans sH1H) nH1K tiHK] := sdprodP defG.
  by rewrite sdprodEY //; apply/trivgP; rewrite -tiHK setIS.
by apply: sub_in1 (Frobenius_reg_ker frobG); apply/subsetP/setSD.
Qed.

Lemma Frobenius_kerP G K :
  reflect [/\ K :!=: 1, K \proper G, K <| G
            & {in K^#, forall x, 'C_G[x] \subset K}]
          [Frobenius G with kernel K].
Proof.
apply: (iffP existsP) => [[H frobG] | [ntK ltKG nsKG regK]].
  have [/sdprod_context[nsKG _ _ _ _] ntK _ ltKG _] := Frobenius_context frobG.
  by split=> //; apply: Frobenius_cent1_ker frobG.
have /andP[sKG nKG] := nsKG.
have hallK: Hall G K.
  rewrite /Hall sKG //= coprime_sym coprime_pi' //.
  apply: sub_pgroup (pgroup_pi K) => p; have [P sylP] := Sylow_exists p G.
  have [[sPG pP p'GiP] sylPK] := (and3P sylP, Hall_setI_normal nsKG sylP).
  rewrite -p_rank_gt0 -(rank_Sylow sylPK) rank_gt0 => ntPK.
  rewrite inE /= -p'natEpi // (pnat_dvd _ p'GiP) ?indexgS //.
  have /trivgPn[z]: P :&: K :&: 'Z(P) != 1.
    by rewrite meet_center_nil ?(pgroup_nil pP) ?(normalGI sPG nsKG).
  rewrite !inE -andbA -sub_cent1=> /and4P[_ Kz _ cPz] ntz.
  by apply: subset_trans (regK z _); [apply/subsetIP | apply/setD1P].
have /splitsP[H /complP[tiKH defG]] := SchurZassenhaus_split hallK nsKG.
have [_ sHG] := mulG_sub defG; have nKH := subset_trans sHG nKG.
exists H; apply/Frobenius_semiregularP; rewrite ?sdprodE //.
  by apply: contraNneq (proper_subn ltKG) => H1; rewrite -defG H1 mulg1.
apply: semiregular_sym => x Kx; apply/trivgP; rewrite -tiKH.
by rewrite subsetI subsetIl (subset_trans _ (regK x _)) ?setSI.
Qed.

Lemma set_Frobenius_compl G K H :
  K ><| H = G -> [Frobenius G with kernel K] -> [Frobenius G = K ><| H].
Proof.
move=> defG /Frobenius_kerP[ntK ltKG _ regKG].
apply/Frobenius_semiregularP=> //.
  by apply: contraTneq ltKG => H_1; rewrite -defG H_1 sdprodg1 properxx.
apply: semiregular_sym => y /regKG sCyK.
have [_ sHG _ _ tiKH] := sdprod_context defG.
by apply/trivgP; rewrite /= -(setIidPr sHG) setIAC -tiKH setSI.
Qed.

Lemma Frobenius_kerS G K G1 :
    G1 \subset G -> K \proper G1 ->
  [Frobenius G with kernel K] -> [Frobenius G1 with kernel K].
Proof.
move=> sG1G ltKG1 /Frobenius_kerP[ntK _ /andP[_ nKG] regKG].
apply/Frobenius_kerP; rewrite /normal proper_sub // (subset_trans sG1G) //.
by split=> // x /regKG; apply: subset_trans; rewrite setSI.
Qed.

Lemma Frobenius_action_kernel_def G H K sT S to :
    K ><| H = G -> @Frobenius_action _ G H sT S to ->
  K :=: 1 :|: [set x in G | 'Fix_(S | to)[x] == set0].
Proof.
move=> defG FrobG.
have partG: partition (gval K |: (H^# :^: K)) G.
  apply: Frobenius_partition; apply/andP; rewrite defG; split=> //.
  by apply/Frobenius_actionP; apply: HasFrobeniusAction FrobG.
have{FrobG} [ffulG transG regG ntH [u Su defH]]:= FrobG.
apply/setP=> x; rewrite !inE; have [-> | ntx] := altP eqP; first exact: group1.
rewrite /= -(cover_partition partG) /cover.
have neKHy y: gval K <> H^# :^ y.
  by move/setP/(_ 1); rewrite group1 conjD1g setD11.
rewrite big_setU1 /= ?inE; last by apply/imsetP=> [[y _ /neKHy]].
have [nsKG sHG _ _ tiKH] := sdprod_context defG; have [sKG nKG]:= andP nsKG.
symmetry; case Kx: (x \in K) => /=.
  apply/set0Pn=> [[v /setIP[Sv]]]; have [y Gy ->] := atransP2 transG Su Sv.
  rewrite -sub1set -astabC sub1set astab1_act mem_conjg => Hxy.
  case/negP: ntx; rewrite -in_set1 -(conjgKV y x) -mem_conjgV conjs1g -tiKH.
  by rewrite defH setIA inE -mem_conjg (setIidPl sKG) (normsP nKG) ?Kx.
apply/andP=> [[/bigcupP[_ /imsetP[y Ky ->] Hyx] /set0Pn[]]]; exists (to u y).
rewrite inE (actsP (atrans_acts transG)) ?(subsetP sKG) // Su.
rewrite -sub1set -astabC sub1set astab1_act.
by rewrite conjD1g defH conjIg !inE in Hyx; case/and3P: Hyx.
Qed.

End FrobeniusBasics.

Arguments normedTI_P {gT A G L}.
Arguments normedTI_memJ_P {gT A G L}.
Arguments Frobenius_kerP {gT G K}.

Lemma Frobenius_coprime_quotient (gT : finGroupType) (G K H N : {group gT}) :
    K ><| H = G -> N <| G -> coprime #|K| #|H| /\ H :!=: 1%g ->
    N \proper K /\ {in H^#, forall x, 'C_K[x] \subset N} ->
  [Frobenius G / N = (K / N) ><| (H / N)]%g.
Proof.
move=> defG nsNG [coKH ntH] [ltNK regH].
have [[sNK _] [_ /mulG_sub[sKG sHG] _ _]] := (andP ltNK, sdprodP defG).
have [_ nNG] := andP nsNG; have nNH := subset_trans sHG nNG.
apply/Frobenius_semiregularP; first exact: quotient_coprime_sdprod.
- by rewrite quotient_neq1 ?(normalS _ sKG).
- by rewrite -(isog_eq1 (quotient_isog _ _)) ?coprime_TIg ?(coprimeSg sNK).
move=> _ /(subsetP (quotientD1 _ _))/morphimP[x nNx H1x ->].
rewrite -cent_cycle -quotient_cycle //=.
rewrite -strongest_coprime_quotient_cent ?cycle_subG //.
- by rewrite cent_cycle quotientS1 ?regH.
- by rewrite subIset ?sNK.
- rewrite (coprimeSg (subsetIl N _)) ?(coprimeSg sNK) ?(coprimegS _ coKH) //.
  by rewrite cycle_subG; case/setD1P: H1x.
by rewrite orbC abelian_sol ?cycle_abelian.
Qed.

Section InjmFrobenius.

Variables (gT rT : finGroupType) (D G : {group gT}) (f : {morphism D >-> rT}).
Implicit Types (H K : {group gT}) (sGD : G \subset D) (injf : 'injm f).

Lemma injm_Frobenius_compl H sGD injf :
  [Frobenius G with complement H] -> [Frobenius f @* G with complement f @* H].
Proof.
case/andP=> neqGH /normedTI_P[nzH /subsetIP[sHG _] tiHG].
have sHD := subset_trans sHG sGD; have sH1D := subset_trans (subD1set H 1) sHD.
apply/andP; rewrite (can_in_eq (injmK injf)) //; split=> //.
apply/normedTI_P; rewrite normD1 -injmD1 // -!cards_eq0 card_injm // in nzH *.
rewrite subsetI normG morphimS //; split=> // _ /morphimP[x Dx Gx ->] ti'fHx.
rewrite mem_morphim ?tiHG //; apply: contra ti'fHx; rewrite -!setI_eq0 => tiHx.
by rewrite -morphimJ // -injmI ?conj_subG // (eqP tiHx) morphim0.
Qed.

Lemma injm_Frobenius H K sGD injf :
  [Frobenius G = K ><| H] -> [Frobenius f @* G = f @* K ><| f @* H].
Proof.
case/andP=> /eqP defG frobG.
by apply/andP; rewrite (injm_sdprod _ injf defG) // eqxx injm_Frobenius_compl.
Qed.

Lemma injm_Frobenius_ker K sGD injf :
  [Frobenius G with kernel K] -> [Frobenius f @* G with kernel f @* K].
Proof.
case/existsP=> H frobG; apply/existsP.
by exists (f @* H)%G; apply: injm_Frobenius.
Qed.

Lemma injm_Frobenius_group sGD injf : [Frobenius G] -> [Frobenius f @* G].
Proof.
case/existsP=> H frobG; apply/existsP; exists (f @* H)%G.
exact: injm_Frobenius_compl.
Qed.

End InjmFrobenius.

Theorem Frobenius_Ldiv (gT : finGroupType) (G : {group gT}) n :
  n %| #|G| -> n %| #|'Ldiv_n(G)|.
Proof.
move=> nG; move: {2}_.+1 (ltnSn (#|G| %/ n)) => mq.
elim: mq => // mq IHm in gT G n nG *; case/dvdnP: nG => q oG.
have [q_gt0 n_gt0] : 0 < q /\ 0 < n by apply/andP; rewrite -muln_gt0 -oG.
rewrite ltnS oG mulnK // => leqm.
have:= q_gt0; rewrite leq_eqVlt => /predU1P[q1 | lt1q].
  rewrite -(mul1n n) q1 -oG (setIidPl _) //.
  by apply/subsetP=> x Gx; rewrite inE -order_dvdn order_dvdG.
pose p := pdiv q; have pr_p: prime p by apply: pdiv_prime.
have lt1p: 1 < p := prime_gt1 pr_p; have p_gt0 := ltnW lt1p.
have{leqm} lt_qp_mq: q %/ p < mq by apply: leq_trans leqm; rewrite ltn_Pdiv.
have: n %| #|'Ldiv_(p * n)(G)|.
  have: p * n %| #|G| by rewrite oG dvdn_pmul2r ?pdiv_dvd.
  move/IHm=> IH; apply: dvdn_trans (IH _); first exact: dvdn_mull.
  by rewrite oG divnMr.
rewrite -(cardsID 'Ldiv_n()) dvdn_addl.
  rewrite -setIA ['Ldiv_n(_)](setIidPr _) //.
  by apply/subsetP=> x; rewrite !inE -!order_dvdn; apply: dvdn_mull.
rewrite -setIDA; set A := _ :\: _.
have pA x: x \in A -> #[x]`_p = (n`_p * p)%N.
  rewrite !inE -!order_dvdn => /andP[xn xnp].
  rewrite !p_part // -expnSr; congr (p ^ _)%N; apply/eqP.
  rewrite eqn_leq -{1}addn1 -(pfactorK 1 pr_p) -lognM ?expn1 // mulnC.
  rewrite dvdn_leq_log ?muln_gt0 ?p_gt0 //= ltnNge; apply: contra xn => xn.
  move: xnp; rewrite -[#[x]](partnC p) //.
  rewrite !Gauss_dvd ?coprime_partC //; case/andP=> _.
  rewrite p_part ?pfactor_dvdn // xn Gauss_dvdr // coprime_sym.
  exact: pnat_coprime (pnat_id _) (part_pnat _ _).
rewrite -(partnC p n_gt0) Gauss_dvd ?coprime_partC //; apply/andP; split.
  rewrite -sum1_card (partition_big_imset (@cycle _)) /=.
  apply: dvdn_sum => _ /imsetP[x /setIP[Gx Ax] ->].
  rewrite (eq_bigl (generator <[x]>)) => [|y].
    rewrite sum1dep_card -totient_gen -[#[x]](partnC p) //.
    rewrite totient_coprime ?coprime_partC // dvdn_mulr // .
    by rewrite (pA x Ax) p_part // -expnSr totient_pfactor // dvdn_mull.
  rewrite /generator eq_sym andbC; case xy: {+}(_ == _) => //.
  rewrite !inE -!order_dvdn in Ax *.
  by rewrite -cycle_subG /order -(eqP xy) cycle_subG Gx.
rewrite -sum1_card (partition_big_imset (fun x => x.`_p ^: G)) /=.
apply: dvdn_sum => _ /imsetP[x /setIP[Gx Ax] ->].
set y := x.`_p; have oy: #[y] = (n`_p * p)%N by rewrite order_constt pA.
rewrite (partition_big (fun x => x.`_p) (mem (y ^: G))) /= => [|z]; last first.
  by case/andP=> _ /eqP <-; rewrite /= class_refl.
pose G' := ('C_G[y] / <[y]>)%G; pose n' := gcdn #|G'| n`_p^'.
have n'_gt0: 0 < n' by rewrite gcdn_gt0 cardG_gt0.
rewrite (eq_bigr (fun _ => #|'Ldiv_n'(G')|)) => [|_ /imsetP[a Ga ->]].
  rewrite sum_nat_const -index_cent1 indexgI.
  rewrite -(dvdn_pmul2l (cardG_gt0 'C_G[y])) mulnA LagrangeI.
  have oCy: #|'C_G[y]| = (#[y] * #|G'|)%N.
    rewrite card_quotient ?subcent1_cycle_norm // Lagrange //.
    by rewrite subcent1_cycle_sub ?groupX.
  rewrite oCy -mulnA -(muln_lcm_gcd #|G'|) -/n' mulnA dvdn_mul //.
    rewrite muln_lcmr -oCy order_constt pA // mulnAC partnC // dvdn_lcm.
    by rewrite cardSg ?subsetIl // mulnC oG dvdn_pmul2r ?pdiv_dvd.
  apply: IHm; [exact: dvdn_gcdl | apply: leq_ltn_trans lt_qp_mq].
  rewrite -(@divnMr n`_p^') // -muln_lcm_gcd mulnC divnMl //.
  rewrite leq_divRL // divn_mulAC ?leq_divLR ?dvdn_mulr ?dvdn_lcmr //.
  rewrite dvdn_leq ?muln_gt0 ?q_gt0 //= mulnC muln_lcmr dvdn_lcm.
  rewrite -(@dvdn_pmul2l n`_p) // mulnA -oy -oCy mulnCA partnC // -oG.
  by rewrite cardSg ?subsetIl // dvdn_mul ?pdiv_dvd.
pose h := [fun z => coset <[y]> (z ^ a^-1)].
pose h' := [fun Z : coset_of <[y]> => (y * (repr Z).`_p^') ^ a].
rewrite -sum1_card (reindex_onto h h') /= => [|Z]; last first.
  rewrite conjgK coset_kerl ?cycle_id ?morph_constt ?repr_coset_norm //.
  rewrite /= coset_reprK 2!inE -order_dvdn dvdn_gcd => /and3P[_ _ p'Z].
  by apply: constt_p_elt (pnat_dvd p'Z _); apply: part_pnat.
apply: eq_bigl => z; apply/andP/andP=> [[]|[]].
  rewrite inE -andbA => /and3P[Gz Az _] /eqP zp_ya.
  have czy: z ^ a^-1 \in 'C[y].
    rewrite -mem_conjg -normJ conjg_set1 -zp_ya.
    by apply/cent1P; apply: commuteX.
  have Nz:  z ^ a^-1 \in 'N(<[y]>) by apply: subsetP czy; apply: norm_gen.
  have G'z: h z \in G' by rewrite mem_morphim //= inE groupJ // groupV.
  rewrite inE G'z inE -order_dvdn dvdn_gcd order_dvdG //=.
  rewrite /order -morphim_cycle // -quotientE card_quotient ?cycle_subG //.
  rewrite -(@dvdn_pmul2l #[y]) // Lagrange; last first.
    by rewrite /= cycleJ cycle_subG mem_conjgV -zp_ya mem_cycle.
  rewrite oy mulnAC partnC // [#|_|]orderJ; split.
    by rewrite !inE -!order_dvdn mulnC in Az; case/andP: Az.
  set Z := coset _ _; have NZ := repr_coset_norm Z; have:= coset_reprK Z.
  case/kercoset_rcoset=> {NZ}// _ /cycleP[i ->] ->{Z}.
  rewrite consttM; last exact/commute_sym/commuteX/cent1P.
  rewrite (constt1P _) ?p_eltNK 1?p_eltX ?p_elt_constt // mul1g.
  by rewrite conjMg consttJ conjgKV -zp_ya consttC.
rewrite 2!inE -order_dvdn; set Z := coset _ _ => /andP[Cz n'Z] /eqP def_z.
have Nz: z ^ a^-1 \in 'N(<[y]>).
  rewrite -def_z conjgK groupMr; first by rewrite -(cycle_subG y) normG.
  by rewrite groupX ?repr_coset_norm.
have{Cz} /setIP[Gz Cz]: z ^ a^-1 \in 'C_G[y].
  case/morphimP: Cz => u Nu Cu /kercoset_rcoset[] // _ /cycleP[i ->] ->.
  by rewrite groupMr // groupX // inE groupX //; apply/cent1P.
have{def_z} zp_ya: z.`_p = y ^ a.
  rewrite -def_z consttJ consttM.
    rewrite constt_p_elt ?p_elt_constt //.
    by rewrite (constt1P _) ?p_eltNK ?p_elt_constt ?mulg1.
  apply: commute_sym; apply/cent1P.
  by rewrite -def_z conjgK groupMl // in Cz; apply/cent1P.
have ozp: #[z ^ a^-1]`_p = #[y] by rewrite -order_constt consttJ zp_ya conjgK.
split; rewrite zp_ya // -class_lcoset lcoset_id // eqxx andbT.
rewrite -(conjgKV a z) !inE groupJ //= -!order_dvdn orderJ; apply/andP; split.
  apply: contra (partn_dvd p n_gt0) _.
  by rewrite ozp -(muln1 n`_p) oy dvdn_pmul2l // dvdn1 neq_ltn lt1p orbT.
rewrite -(partnC p n_gt0) mulnCA mulnA -oy -(@partnC p #[_]) // ozp.
apply dvdn_mul => //; apply: dvdn_trans (dvdn_trans n'Z (dvdn_gcdr _ _)).
rewrite {2}/order -morphim_cycle // -quotientE card_quotient ?cycle_subG //.
rewrite -(@dvdn_pmul2l #|<[z ^ a^-1]> :&: <[y]>|) ?cardG_gt0 // LagrangeI.
rewrite -[#|<[_]>|](partnC p) ?order_gt0 // dvdn_pmul2r // ozp.
by rewrite cardSg ?subsetIr.
Qed.


Require Export Metalib.Metatheory.
Require Export String.

Inductive typ : Set :=
  | typ_nat : typ
  | typ_top : typ
  | typ_bot : typ
  | typ_bvar : nat -> typ
  | typ_fvar : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_all : typ -> typ -> typ
  | typ_all_lb : typ -> typ -> typ
  | typ_mu : typ -> typ
  | typ_label : var -> typ -> typ
.

Coercion typ_bvar : nat >-> typ.
Coercion typ_fvar : atom >-> typ.

Inductive exp : Set :=
  | exp_bvar : nat -> exp
  | exp_fvar : atom -> exp
  | exp_abs : typ -> exp -> exp
  | exp_app : exp -> exp -> exp
  | exp_tabs : typ -> exp -> exp
  | exp_tabs_lb : typ -> exp -> exp
  | exp_tapp : exp -> typ -> exp
  | exp_nat : exp
  | exp_unfold : typ -> exp -> exp
  | exp_fold : typ -> exp -> exp
.

Coercion exp_bvar : nat >-> exp.
Coercion exp_fvar : atom >-> exp.

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_nat         => typ_nat
  | typ_top         => typ_top
  | typ_bot         => typ_bot
  | typ_bvar J      => if K === J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T1 T2 => typ_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  | typ_all_lb T1 T2 => typ_all_lb (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  | typ_mu T        => typ_mu (open_tt_rec (S K) U T)
  | typ_label l T        => typ_label l (open_tt_rec K U T)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_bot :
      type typ_bot
  | type_nat :
      type typ_nat
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_mu : forall L T,
      (forall X, X \notin L -> type (open_tt T (typ_fvar X))) ->
      type (typ_mu T)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X, X `notin` L -> type (open_tt T2 (typ_fvar X))) ->
      type (typ_all T1 T2)
  | type_all_lb : forall L T1 T2,
      type T1 ->
      (forall X, X `notin` L -> type (open_tt T2 (typ_fvar X))) ->
      type (typ_all_lb T1 T2)
  | type_label: forall l A,
      type A ->
      type (typ_label l A)
.

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_bot => typ_bot
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_mu T => typ_mu (subst_tt Z U T)
  | typ_label l T => typ_label l (subst_tt Z U T)
  | typ_all T1 T2 => typ_all (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all_lb T1 T2 => typ_all_lb (subst_tt Z U T1) (subst_tt Z U T2)
  end.

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_bot => {}
  | typ_nat => {}
  | typ_bvar J => {}
  | typ_fvar X => {{ X }}
  | typ_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_all T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_all_lb T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_mu T => (fv_tt T)
  | typ_label l T => (fv_tt T)
  end.

Inductive binding : Set :=
| bind_sub : typ -> binding
| bind_sub_lb : typ -> binding
| bind_typ : typ -> binding.

Definition env := list (atom * binding).
Notation empty := (@nil (atom * binding)).

Inductive WF : env -> typ -> Prop :=
| WF_top : forall E, WF E typ_top
| WF_bot : forall E, WF E typ_bot
| WF_nat : forall E, WF E typ_nat
| WF_var: forall U E (X : atom),
      binds X (bind_sub U) E ->
      WF E (typ_fvar X)
| WF_var_lb: forall U E (X : atom),
      binds X (bind_sub_lb U) E ->
      WF E (typ_fvar X)
| WF_arrow : forall E A B,
    WF E A ->
    WF E B ->
    WF E (typ_arrow A B)
| WF_all : forall L E T1 T2,
      WF E T1 ->
      (forall X : atom, X `notin` L ->
        WF (X ~ bind_sub T1 ++ E) (open_tt T2 X)) ->
      WF E (typ_all T1 T2)
| WF_all_lb : forall L E T1 T2,
      WF E T1 ->
      (forall X : atom, X `notin` L ->
        WF (X ~ bind_sub_lb T1 ++ E) (open_tt T2 X)) ->
      WF E (typ_all_lb T1 T2)
| WF_rec : forall L E A,
      (forall X, X \notin L ->
                 WF (X ~ bind_sub typ_top ++ E) (open_tt A X)) ->
      (forall X, X \notin L ->
                 WF (X ~ bind_sub typ_top ++ E) (open_tt A (typ_label X (open_tt A X)))) ->
      WF E (typ_mu A)
| WF_label: forall E A X,
    WF E A ->
    WF E (typ_label X A)
.

Fixpoint fl_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_bot => {}
  | typ_nat => {}
  | typ_bvar J => {}
  | typ_fvar X => {}
  | typ_arrow T1 T2 => (fl_tt T1) `union` (fl_tt T2)
  | typ_mu T => (fl_tt T)
  | typ_label X T => {{ X }} `union` fl_tt T
  | typ_all T1 T2 => (fl_tt T1) \u (fl_tt T2)
  | typ_all_lb T1 T2 => (fl_tt T1) \u (fl_tt T2)
  end.

Fixpoint fv_env (E:env) : atoms :=
  match E with
  | nil => {}
  | (x,bind_sub y)::E' => (fv_tt y) \u (fv_env E')
  | (x,bind_sub_lb y)::E' => (fv_tt y) \u (fv_env E')
  | (x,bind_typ y)::E' => (fv_tt y) \u (fv_env E')
  end.

Fixpoint fl_env (E:env) : atoms :=
  match E with
  | nil => {}
  | (x,bind_sub y)::E' => (fl_tt y) \u (fl_env E')
  | (x,bind_sub_lb y)::E' => (fl_tt y) \u (fl_env E')
  | (x,bind_typ y)::E' => (fl_tt y) \u (fl_env E')
  end.

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_sub : forall (E : env) (X : atom) (T : typ),
      wf_env E ->
      WF E T ->
      X `notin` dom E ->
      wf_env (X ~ bind_sub T ++ E)
  | wf_env_subb : forall (E : env) (X : atom) (T : typ),
      wf_env E ->
      WF E T ->
      X `notin` dom E ->
      wf_env (X ~ bind_sub_lb T ++ E)
  | wf_env_typ : forall (E : env) (x : atom) (T : typ),
      wf_env E ->
      WF E T ->
      x `notin` dom E ->
      wf_env (x ~ bind_typ T ++ E).

Inductive sub : env -> typ -> typ -> Prop :=
| sa_nat: forall E,
    wf_env E ->
    sub E typ_nat typ_nat
| sa_fvar: forall E X,
    wf_env E ->
    WF E (typ_fvar X) ->
    sub E (typ_fvar X) (typ_fvar X)
| sa_top : forall E A,
    wf_env E ->
    WF E A ->
    sub E A typ_top
| sa_bot : forall E A,
    wf_env E ->
    WF E A ->
    sub E typ_bot A
| sa_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      sub E U T ->
      sub E (typ_fvar X) T
| sa_trans_tvar_lb : forall U E T X,
      binds X (bind_sub_lb U) E ->
      sub E T U ->
      sub E T (typ_fvar X)
| sa_arrow: forall E A1 A2 B1 B2,
    sub E B1 A1 ->
    sub E A2 B2 ->
    sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| sa_all : forall L E S1 S2 T1 T2,
    sub E S1 S2 ->
    sub E S2 S1 ->
      (forall X : atom, X `notin` L ->
          sub (X ~ bind_sub S2 ++ E) (open_tt T1 X) (open_tt T2 X)) ->
      sub E (typ_all S1 T1) (typ_all S2 T2)
| sa_all_lb : forall L E S1 S2 T1 T2,
    sub E S1 S2 ->
    sub E S2 S1 ->
      (forall X : atom, X `notin` L ->
          sub (X ~ bind_sub_lb S2 ++ E) (open_tt T1 X) (open_tt T2 X)) ->
      sub E (typ_all_lb S1 T1) (typ_all_lb S2 T2)
| sa_rec: forall L A1 A2 E,
    (forall X,
        X \notin L ->
        WF (X ~ bind_sub typ_top ++ E) (open_tt A1 X)) ->
    (forall X,
        X \notin L ->
        WF (X ~ bind_sub typ_top ++ E) (open_tt A2 X)) ->
    (forall X,
        X \notin L ->
        sub (X ~ bind_sub typ_top ++ E) (open_tt A1 (typ_label X (open_tt A1 X))) (open_tt A2 (typ_label X (open_tt A2 X)))) ->
    sub E (typ_mu A1) (typ_mu A2)
| sa_label: forall E X A B,
    sub E A B ->
    sub E (typ_label X A) (typ_label X B)
.

Definition subst_tb (Z : atom) (P : typ) (b : binding) : binding :=
  match b with
  | bind_sub T => bind_sub (subst_tt Z P T)
  | bind_sub_lb T => bind_sub_lb (subst_tt Z P T)
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

Fixpoint open_te_rec (K : nat) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | exp_app e1 e2 => exp_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | exp_tabs V e1 => exp_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | exp_tabs_lb V e1 => exp_tabs_lb (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | exp_tapp e1 V => exp_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  | exp_unfold V e => exp_unfold (open_tt_rec K U V) (open_te_rec K U e)
  | exp_fold V e => exp_fold (open_tt_rec K U V) (open_te_rec K U e)
  end.

Fixpoint open_ee_rec (k : nat) (f : exp) (e : exp)  {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => if k == i then f else (exp_bvar i)
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs V (open_ee_rec (S k) f e1)
  | exp_app e1 e2 => exp_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | exp_tabs V e1 => exp_tabs V (open_ee_rec k f e1)
  | exp_tabs_lb V e1 => exp_tabs_lb V (open_ee_rec k f e1)
  | exp_tapp e1 V => exp_tapp (open_ee_rec k f e1) V
  | exp_unfold V e => exp_unfold V (open_ee_rec k f e)
  | exp_fold V e => exp_fold V (open_ee_rec k f e)
  end.

Definition open_te e U := open_te_rec 0 U e.
Definition open_ee e1 e2 := open_ee_rec 0 e2 e1.

Inductive expr : exp -> Prop :=
  | expr_nat : expr exp_nat
  | expr_var : forall x,
      expr (exp_fvar x)
  | expr_abs : forall L T e1,
      type T ->
      (forall x : atom, x `notin` L -> expr (open_ee e1 x)) ->
      expr (exp_abs T e1)
  | expr_app : forall e1 e2,
      expr e1 ->
      expr e2 ->
      expr (exp_app e1 e2)
  | expr_tabs : forall L T e1,
      type T ->
      (forall X : atom, X `notin` L -> expr (open_te e1 X)) ->
      expr (exp_tabs T e1)
  | expr_tabs_lb : forall L T e1,
      type T ->
      (forall X : atom, X `notin` L -> expr (open_te e1 X)) ->
      expr (exp_tabs_lb T e1)
  | expr_tapp : forall e1 V,
      expr e1 ->
      type V ->
      expr (exp_tapp e1 V)
  | expr_unfold: forall T e,
     type T ->
     expr e ->
     expr (exp_unfold T e)
  | expr_fold: forall T e,
     type T ->
     expr e ->
     expr (exp_fold T e)
.

Definition body_e (e : exp) :=
  exists L, forall x : atom, x `notin` L -> expr (open_ee e x).

Inductive typing : env -> exp -> typ -> Prop :=
  | typing_nat: forall G,
    wf_env G ->
    typing G (exp_nat) (typ_nat)
  | typing_var : forall E x T,
      wf_env E ->
      binds x (bind_typ T) E ->
      typing E (exp_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x : atom, x `notin` L ->
        typing (x ~ bind_typ V ++ E) (open_ee e1 x) T1) ->
      typing E (exp_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (exp_app e1 e2) T2
  | typing_tabs : forall L E V e1 T1,
      (forall X : atom, X `notin` L ->
        typing (X ~ bind_sub V ++ E) (open_te e1 X) (open_tt T1 X)) ->
      typing E (exp_tabs V e1) (typ_all V T1)
  | typing_tabs_lb : forall L E V e1 T1,
      (forall X : atom, X `notin` L ->
        typing (X ~ bind_sub_lb V ++ E) (open_te e1 X) (open_tt T1 X)) ->
      typing E (exp_tabs_lb V e1) (typ_all_lb V T1)
  | typing_tapp : forall T1 E e1 T T2,
      typing E e1 (typ_all T1 T2) ->
      sub E T T1 ->
      typing E (exp_tapp e1 T) (open_tt T2 T)
  | typing_tapp_lb : forall T1 E e1 T T2,
      typing E e1 (typ_all_lb T1 T2) ->
      sub E T1 T ->
      typing E (exp_tapp e1 T) (open_tt T2 T)
  | typing_fold : forall G A T e ,
      sub G (typ_mu A) T ->
      typing G e (open_tt A T)  ->
      typing G (exp_fold T e) T
 | typing_unfold : forall G A T e,
     typing G e A -> sub G A (typ_mu T) ->
     typing G (exp_unfold A e)  (open_tt T A)
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T
.

Inductive value : exp -> Prop :=
  | value_abs : forall t1 T,
      expr (exp_abs T t1) ->
      value (exp_abs T t1)
  | value_tabs : forall t1 T,
      expr (exp_tabs T t1) ->
      value (exp_tabs T t1)
  | value_tabs_lb : forall t1 T,
      expr (exp_tabs_lb T t1) ->
      value (exp_tabs_lb T t1)
  | value_nat:
      value exp_nat
  | value_fold: forall T e,
      type T ->
      value e ->
      value (exp_fold T e)
.

Inductive step : exp -> exp -> Prop :=
 | step_beta : forall (e1 e2:exp) T,
     expr (exp_abs T e1) ->
     value e2 ->
     step (exp_app  (exp_abs T e1) e2)  (open_ee e1 e2)
 | step_app1 : forall (e1 e2 e1':exp),
     expr e2 ->
     step e1 e1' ->
     step (exp_app e1 e2) (exp_app e1' e2)
 | step_app2 : forall v1 e2 e2',
     value v1 ->
     step e2 e2' ->
     step (exp_app v1 e2) (exp_app v1 e2')
 | step_tapp : forall e1 e1' V,
      type V ->
      step e1 e1' ->
      step (exp_tapp e1 V) (exp_tapp e1' V)
 | step_tabs : forall T1 e1 T2,
      expr (exp_tabs T1 e1) ->
      type T2 ->
      step (exp_tapp (exp_tabs T1 e1) T2) (open_te e1 T2)
 | step_tabs_lb : forall T1 e1 T2,
    expr (exp_tabs_lb T1 e1) ->
    type T2 ->
    step (exp_tapp (exp_tabs_lb T1 e1) T2) (open_te e1 T2)
 | step_fld: forall S T v,
     value v ->
     type T ->
     type S ->
     step (exp_unfold S (exp_fold T v)) v
 | step_fold: forall e e' T,
     step e e' ->
     type T ->
     step (exp_fold T e) (exp_fold T e')
 | step_unfold: forall e e' T,
     step e e' ->
     type T ->
     step (exp_unfold T e) (exp_unfold T e')
.

Hint Constructors type WF wf_env sub expr typing step value: core.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
  match e with
  | exp_nat => {}
  | exp_bvar i => {}
  | exp_fvar x => {}
  | exp_abs V e1  => (fv_tt V) `union` (fv_te e1)
  | exp_app e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_tabs V e1 => (fv_tt V) `union` (fv_te e1)
  | exp_tabs_lb V e1 => (fv_tt V) `union` (fv_te e1)
  | exp_tapp e1 V => (fv_tt V) `union` (fv_te e1)
  | exp_fold V e => fv_tt V \u fv_te e
  | exp_unfold V e => fv_tt V \u fv_te e
  end.

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
  match e with
  | exp_nat => {}
  | exp_bvar i => {}
  | exp_fvar x => {{ x }}
  | exp_abs V e1 => (fv_ee e1)
  | exp_app e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_tabs V e1 => (fv_ee e1)
  | exp_tabs_lb V e1 => (fv_ee e1)
  | exp_tapp e1 V => (fv_ee e1)
  | exp_fold V e => fv_ee e
  | exp_unfold V e => fv_ee e
  end.

Fixpoint subst_te (Z : atom) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | exp_app e1 e2 => exp_app  (subst_te Z U e1) (subst_te Z U e2)
  | exp_tabs V e1 => exp_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | exp_tabs_lb V e1 => exp_tabs_lb (subst_tt Z U V)  (subst_te Z U e1)
  | exp_tapp e1 V => exp_tapp (subst_te Z U e1) (subst_tt Z U V)
  | exp_fold V e => exp_fold (subst_tt Z U V) (subst_te Z U e)
  | exp_unfold V e => exp_unfold (subst_tt Z U V) (subst_te Z U e)
  end.

Fixpoint subst_ee (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => exp_bvar i
  | exp_fvar x => if x == z then u else e
  | exp_abs V e1 => exp_abs V (subst_ee z u e1)
  | exp_app e1 e2 => exp_app (subst_ee z u e1) (subst_ee z u e2)
  | exp_tabs V e1 => exp_tabs V (subst_ee z u e1)
  | exp_tabs_lb V e1 => exp_tabs_lb V (subst_ee z u e1)
  | exp_tapp e1 V => exp_tapp (subst_ee z u e1) V
  | exp_fold V e => exp_fold V (subst_ee z u e)
  | exp_unfold V e => exp_unfold V (subst_ee z u e)
  end.

Inductive Mode := Pos | Neg.

Definition choose (m : Mode)  (C : typ) (D : typ) :=
  match m with
  | Pos => C
  | Neg => D
  end.

Definition flip (m : Mode) : Mode :=
  match m with
  | Pos => Neg
  | Neg => Pos
  end.

Definition equiv E A B := sub E A B /\ sub E B A.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : typ => fl_tt x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : env => fv_env x) in
  let H := gather_atoms_with (fun x : env => fl_env x) in
  let A1 := gather_atoms_with (fun x : exp => fv_te x) in
  let A2 := gather_atoms_with (fun x : exp => fv_ee x) in
  let A3 := gather_atoms_with (fun x : list (var * nat) => dom x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u A1 \u A2 \u A3).


(** Non dependent lexicographic product *)
(** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From Coq Require Import Relations Wellfounded.Lexicographic_Product
        Wellfounded.Inverse_Image Wellfounded.Inclusion Setoid.
From Coq Require Export RelationClasses.

Section Definitions.

  Variables (A B : Type)
            (ltA : relation A)
            (ltB : relation B).

  Hypothesis wfA : well_founded ltA.
  Hypothesis wfB : well_founded ltB.

  Let pair2sig (p: A * B) := existT (fun _ : A => B) (fst p) (snd p).

  Inductive lexico : relation (A * B) :=
    lex_1 : forall a a' b b', ltA a a' -> lexico (a,b) (a',b')
  |  lex_2 : forall a  b b', ltB b b' -> lexico (a,b) (a,b') .

  #[global] Instance Trans_lex  {SA : StrictOrder ltA}
         {SB : StrictOrder ltB}  :Transitive lexico.
  Proof.
    intros (x,y) (z,t) (u,v) H H'.
    inversion H; inversion H'.
    - left; now transitivity z.
    - left; subst u; assumption.
    - now left.
    - right; now transitivity t.
  Qed.

  #[global] Instance Strict_lex {SA : StrictOrder ltA}
         {SB : StrictOrder ltB}  : StrictOrder lexico.
  Proof.
    split.
    - intros (x,y) H; inversion_clear H.
    + now destruct (StrictOrder_Irreflexive x).
    + now destruct (StrictOrder_Irreflexive y).
   -  apply Trans_lex.
  Qed.

  Lemma wf_lexico : well_founded lexico.
  Proof.
    pose (R  :=
            fun p q : A * B =>
              lexprod A (fun _ : A => B) ltA
                      (fun _ : A => ltB)
                      (pair2sig p)
                      (pair2sig q)).
    apply wf_incl with R.
    - intros p q H; destruct p, q; red.
      destruct H.
      + now left.
      + now right.
    - unfold R;apply wf_inverse_image, wf_lexprod.
      + trivial.
      + intro; trivial.
  Defined.

End Definitions.

Arguments lexico {A B} _ _ _ _.
Arguments wf_lexico {A B ltA ltB} _ _ _.

Example Ex1 : lexico lt lt (3,5) (4,2).
Proof.
  left;auto.
Qed.

Example Ex2 : lexico lt lt (3,5) (3,6).
Proof.
right;auto.
Qed.


Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import HMAC_common_defs.
Require Import Arith.
Require Import HMAC_spec_concat.
Require Import ByteBitRelations.

Module HMAC_List.

Section HMAC.

  Variable c p : nat.
  Definition b := c + p.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Blist)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable splitAndPad : Blist -> list (Blist).
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* fpad can be a constant *)
  Variable fpad : Blist -> Blist.
  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad x.

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

  Definition HMAC_2K (k : Blist) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Blist.
  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Blist) :=
    GHMAC_2K (BLxor k opad ++ BLxor k ipad).

  Definition HMAC (k : Blist) :=
    HMAC_2K (BLxor k opad ++ BLxor k ipad).

End HMAC.

End HMAC_List.

(* TODO fill these in *)
(* toBlocks should take an int giving size of block *)
Parameter toBlocks : Blist -> list Blist. (* TODO: inverse of concat *)

Definition sha_splitandpad_blocks (msg : Blist) : list Blist :=
  toBlocks (sha_splitandpad_inc msg).

Definition sha_splitandpad_inc' (msg : Blist) : Blist :=
  concat (sha_splitandpad_blocks msg).

Lemma concat_toBlocks_id : forall (l : Blist),
                             (* TODO: iff InBlocks l (define toBlocks such that this is true) *)
                             True ->
                             concat (toBlocks l) = l.
Proof.
  intros l len.
  unfold concat.

Admitted.

(* since sha_splitandpad_inc is used instead of the modified version in the Concat-Pad proof *)
Lemma sha_splitandpad_inc_eq : forall (msg : Blist),
                                 True ->
                                 sha_splitandpad_inc msg = sha_splitandpad_inc' msg.
Proof.
  intros msg msg_blocks.
  unfold sha_splitandpad_inc'. unfold sha_splitandpad_blocks.
  symmetry.
  apply concat_toBlocks_id.
  apply msg_blocks.
Qed.

Theorem fold_hash_blocks_eq : forall (l : Blist) (ls : list Blist),
                                length l = b ->
                                (* TODO InBlocks ls *)
                                True ->
                                fold_left sha_h (l :: ls) sha_iv =
                                hash_blocks_bits sha_h sha_iv (l ++ concat ls).
Proof.
  intros l ls len_l len_ls.
  simpl.
  rewrite -> hash_blocks_bits_equation.

  unfold b in *.
  rewrite -> length_not_emp.
  *
    rewrite -> firstn_exact.
    rewrite -> skipn_exact.

    SearchAbout fold_left.

    (* TODO may need to write with fold_right, + hash_blocks_bits with "fold_right" version
       (to blocks, reverse, concat) *)
    admit.
    - apply len_l.
    - apply len_l.
  *
    rewrite app_length.
    rewrite -> len_l.
    unfold c, p in *.
    omega.
Qed.

Lemma fpad_list_concat_eq :
  HMAC_List.app_fpad = HMAC_Concat.app_fpad.
Proof. reflexivity. Qed.

Theorem HMAC_list_concat : forall (k m : Blist) (op ip : Blist),
                             (* assumptions on lengths of k, m, op, ip *)
                             True ->
                             True ->
                             True ->
                             True ->
  HMAC_List.HMAC c p sha_h sha_iv sha_splitandpad_blocks fpad op ip k m =
  HMAC_Concat.HMAC c p sha_h sha_iv sha_splitandpad_inc' fpad op ip k m.
Proof.
  intros k m op ip k_len m_len op_len ip_len.
  unfold c, p in *. simpl in *.
  unfold HMAC_List.HMAC. unfold HMAC_Concat.HMAC.
  unfold HMAC_List.HMAC_2K. unfold HMAC_Concat.HMAC_2K.
  unfold HMAC_List.GHMAC_2K. unfold HMAC_Concat.GHMAC_2K.

  repeat rewrite -> split_append_id.
  unfold HMAC_List.hash_words. unfold HMAC_Concat.hash_words.
  rewrite -> fpad_list_concat_eq.

  unfold HMAC_List.h_star.
  unfold HMAC_Concat.h_star.

  unfold sha_splitandpad_inc'.
  rewrite <- fold_hash_blocks_eq.
  assert (forall (l1 l2 : Blist), l1 ++ l2 = l1 ++ concat (l2 :: nil)) as create_concat.
    intros. unfold concat. simpl.
    rewrite -> app_nil_r. reflexivity.

  rewrite -> create_concat.
  rewrite <- fold_hash_blocks_eq.
  reflexivity.

  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
Qed.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Coq.Sets.Ensembles
        Coq.ZArith.ZArith
        Coq.Classes.Morphisms
        Coq.Classes.SetoidTactics
        Fiat.Computation
        Fiat.Computation.SetoidMorphisms
        Coq.Logic.FunctionalExtensionality.

Require Fiat.Common.Frame.
Require Fiat.Common.

Record funSig :=
  { funDom : list Type;
    funCod : Type }.

Fixpoint funType
         (fDom : list Type)
         (fCod : Type)
         {struct fDom}
  : Type :=
  match fDom with
  | nil => Comp fCod
  | cons T fDom' => T -> funType fDom' fCod
  end.

Definition funDef (fSig : funSig) :=
  funType (funDom fSig) (funCod fSig).

Fixpoint refineFun
         {fDom : list Type}
         {fCod : Type}
         (fSet' fSet : funType fDom fCod)
         {struct fDom} : Prop :=
  match fDom as fDom' return
        funType fDom' fCod
        -> funType fDom' fCod
        -> Prop
  with
  | nil =>
    fun fSet' fSet => refine fSet' fSet
  | cons T fDom' =>
    fun fSet' fSet =>
      forall (t : T), refineFun (fSet' t) (fSet t)
  end fSet' fSet.

Lemma refineFun_refl
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef : funType fDom fCod),
    refineFun fDef fDef.
Proof.
  induction fDom; simpl; intros.
  - reflexivity.
  - eauto.
Qed.

Lemma refineFun_trans
      {fDom : list Type}
      {fCod : Type}
  : forall (fDef fDef' fDef'' : funType fDom fCod),
    refineFun fDef fDef'
    -> refineFun fDef' fDef''
    -> refineFun fDef fDef''.
Proof.
  induction fDom; simpl; intros.
  - rewrite H; eauto.
  - eauto.
Qed.

#[global]
Instance PreOrder_refineFun
         {fDom : list Type}
         {fCod : Type}
  : PreOrder (@refineFun fDom fCod).
Proof.
  constructor.
  unfold Reflexive; apply refineFun_refl.
  unfold Transitive; apply refineFun_trans.
Qed.

Definition refineEquivFun
           {fDom : list Type}
           {fCod : Type}
           (fSet' fSet : funType fDom fCod)
  : Prop :=
  refineFun fSet fSet' /\ refineFun fSet' fSet.

Add Parametric Morphism fDom fCod
  : (@refineFun fDom fCod)
    with signature (refineEquivFun
                      ==> refineEquivFun
                      ==> Basics.impl)
      as refineEquiv_iff.
  unfold Basics.impl, refineEquivFun; intuition.
  rewrite H0, <- H4; eauto.
Qed.

Fixpoint FunMax
         {fDom : list Type}
         {fCod : Type}
         (fSet' fSet : funType fDom fCod)
         {struct fDom} : funType fDom fCod :=
  match fDom as fDom' return
        funType fDom' fCod
        -> funType fDom' fCod
        -> funType fDom' fCod
  with
  | nil =>
    fun fSet' fSet => @Intersection _ fSet' fSet
  | cons T fDom' =>
    fun fSet' fSet =>
      (fun (t : T) => FunMax (fSet' t) (fSet t))
  end fSet' fSet.

Fixpoint FunMin
         {fDom : list Type}
         {fCod : Type}
         (fSet' fSet : funType fDom fCod)
         {struct fDom} : funType fDom fCod :=
  match fDom as fDom' return
        funType fDom' fCod
        -> funType fDom' fCod
        -> funType fDom' fCod
  with
  | nil =>
    fun fSet' fSet => @Union _ fSet' fSet
  | cons T fDom' =>
    fun fSet' fSet =>
      (fun (t : T) => FunMin (fSet' t) (fSet t))
  end fSet' fSet.

Module LeastFixedPointFun.
  Import Fiat.Common.Frame.

#[global]
  Instance funDefOps
           {fDom : list Type}
           {fCod : Type}
    : Fiat.Common.Frame.Lattice.Ops (funType fDom fCod) :=
    { le := refineFun;
      eq := refineEquivFun;
      max := FunMax;
      min := FunMin
    }.

#[global]
  Instance PreO_refineFun
           {fDom : list Type}
           {fCod : Type}
    : PreO.t (@refineFun fDom fCod) :=
    { le_refl := refineFun_refl;
      le_trans := refineFun_trans }.

  Lemma refineFun_Proper
        {fDom : list Type}
        {fCod : Type}
    : Proper (refineEquivFun ==> refineEquivFun ==> iff)
             (@refineFun fDom fCod).
  Proof.
    unfold Proper, respectful, refineEquivFun;
      intros; intuition.
    rewrite H1, H0; eauto.
    rewrite H2, H0; eauto.
  Qed.

  Lemma refineFun_antisym
        {fDom : list Type}
        {fCod : Type}
    : forall (x y : funType fDom fCod),
      refineFun x y -> refineFun y x ->
      refineEquivFun x y.
  Proof.
    unfold refineEquivFun; intuition.
  Qed.

#[global]
  Instance PO_refineFun
           {fDom : list Type}
           {fCod : Type}
    : PO.t (@refineFun fDom fCod) refineEquivFun :=
    { PreO := PreO_refineFun;
      le_proper := refineFun_Proper;
      le_antisym := refineFun_antisym}.

  Local Transparent computes_to.

  Lemma funMax_Proper
        {fDom : list Type}
        {fCod : Type}
    : Proper (@refineEquivFun
                fDom fCod
                ==> @refineEquivFun fDom fCod
                ==> @refineEquivFun fDom fCod)
             FunMax.
  Proof.
    unfold refineEquivFun, Proper, respectful; intuition.
    - induction fDom; simpl in *.
      + intros c Comp_v; destruct Comp_v.
        apply H0 in H; apply H2 in H4;
          constructor; eauto.
      + intros. eapply IHfDom; eauto.
    - induction fDom; simpl in *.
      + intros c Comp_v; destruct Comp_v.
        apply H1 in H; apply H3 in H4;
          constructor; eauto.
      + intros. eapply IHfDom; eauto.
  Qed.

  Lemma funMin_Proper
        {fDom : list Type}
        {fCod : Type}
    : Proper (@refineEquivFun
                fDom fCod
                ==> @refineEquivFun fDom fCod
                ==> @refineEquivFun fDom fCod)
             FunMin.
  Proof.
    unfold refineEquivFun, Proper, respectful; intuition.
    - induction fDom; simpl in *.
      + intros c Comp_v; destruct Comp_v.
        * constructor; apply H0; auto.
        * constructor 2; apply H2; auto.
      + intros; eapply IHfDom; eauto.
    - induction fDom; simpl in *.
      + intros c Comp_v; destruct Comp_v.
        * constructor; apply H1; auto.
        * constructor 2; apply H3; auto.
      + intros; eapply IHfDom; eauto.
  Qed.

  Lemma FunMax_ok
        {fDom : list Type}
        {fCod : Type}
    : forall l r : funType fDom fCod,
      PreO.max (le := refineFun) l r (FunMax l r).
  Proof.
    constructor.
    - induction fDom; simpl in *.
      + intros v Comp_v; destruct Comp_v; eauto.
      + eauto.
    - induction fDom; simpl in *.
      + intros v Comp_v; destruct Comp_v; eauto.
      + eauto.
    - induction fDom; simpl in *.
      + intros.
        intros v Comp_v; econstructor.
        * apply H; eauto.
        * apply H0; eauto.
      + intros; eapply IHfDom; eauto.
  Qed.

  Lemma FunMin_ok
        {fDom : list Type}
        {fCod : Type}
    : forall l r : funType fDom fCod,
      PreO.min (le := refineFun) l r (FunMin l r).
  Proof.
    constructor.
    - induction fDom; simpl in *.
      + intros v Comp_v; econstructor; eauto.
      + eauto.
    - induction fDom; simpl in *.
      + intros v Comp_v; econstructor 2; eauto.
      + eauto.
    - induction fDom; simpl in *.
      + intros.
        intros v Comp_v; destruct Comp_v.
        * apply H; eauto.
        * apply H0; eauto.
      + intros; eapply IHfDom; eauto.
  Qed.

#[global]
  Instance Lattice_funDef
           {fDom : list Type}
           {fCod : Type}
    : Lattice.t _ (@funDefOps fDom fCod) :=
    { PO := PO_refineFun;
      max_proper := funMax_Proper;
      max_ok := FunMax_ok;
      min_proper := funMin_Proper;
      min_ok := FunMin_ok
    }.

  Fixpoint unCurry_funType
           (fDom : list Type)
    : Type :=
    match fDom with
    | nil => unit
    | cons T fDom' => prod T (unCurry_funType fDom')
    end.

  Fixpoint unCurry
           (fDom : list Type)
           {fCod : Type}
           (f : funType fDom fCod)
           {struct fDom}
    : funType (cons (unCurry_funType fDom) nil) fCod :=
    match fDom return
          funType fDom fCod
          -> funType (cons (unCurry_funType fDom) nil) fCod
    with
    | nil => fun f _ => f
    | cons T fDom' => fun f t => unCurry fDom' (f (fst t)) (snd t)
    end f.

  Fixpoint Curry
           (fDom : list Type)
           {fCod : Type}
           (f : funType (cons (unCurry_funType fDom) nil) fCod)
           {struct fDom}
    : funType fDom fCod :=
    match fDom return
          funType (cons (unCurry_funType fDom) nil) fCod
          -> funType fDom fCod
    with
    | nil => fun f => f tt
    | cons T fDom' => fun f t => Curry _ (fun t' => f (t, t'))
    end f.

  Lemma refineFunEquiv_Curry
        (fDom : list Type)
        {fCod : Type}
    : forall (f : funType (cons (unCurry_funType fDom) nil) fCod),
      refineEquivFun f (unCurry _ (Curry _ f)).
  Proof.
    induction fDom; simpl.
    - split; simpl; intros; destruct t; apply PreOrder_Reflexive.
    - simpl in *; split; simpl; intros.
      + destruct t; simpl in *.
        eapply (IHfDom (fun u => f (a0, u))).
      + destruct t; simpl in *.
        eapply (IHfDom (fun u => f (a0, u))).
  Qed.

  Lemma refineFunEquiv_unCurry
        (fDom : list Type)
        {fCod : Type}
    : forall (f : funType fDom fCod),
      refineEquivFun f (Curry _ (unCurry _ f)).
  Proof.
    induction fDom; simpl.
    - split; simpl; intros; apply PreOrder_Reflexive.
    - simpl in *; split; simpl; intros.
      + eapply (IHfDom (f t)).
      + eapply (IHfDom (f t)).
  Qed.

  Lemma refineFun_Curry'
        (fDom : list Type)
        {fCod : Type}
    : forall (f f' : funType (cons (unCurry_funType fDom) nil) fCod),
      refineFun f f'
      -> refineFun (Curry _ f) (Curry _ f').
  Proof.
    induction fDom; simpl.
    - intros; simpl in *; eauto.
    - simpl in *; intros.
      + eapply IHfDom; intros; eauto.
  Qed.

  Lemma refineFunEquiv_Curry'
        (fDom : list Type)
        {fCod : Type}
    : forall (f f' : funType (cons (unCurry_funType fDom) nil) fCod),
      refineEquivFun f f'
      -> refineEquivFun (Curry _ f) (Curry _ f').
  Proof.
    induction fDom; simpl.
    - split; intros; destruct H; simpl in *; eauto.
    - split; destruct H; simpl in *; intros.
      + eapply IHfDom; split; intros; eauto.
        * simpl in *; intros; eauto.
        * simpl in *; intros; eauto.
      + eapply IHfDom; split; intros; eauto.
        * simpl in *; intros; eauto.
        * simpl in *; intros; eauto.
  Qed.

  Lemma refineFunEquiv_unCurry'
        (fDom : list Type)
        {fCod : Type}
    : forall (f f' : funType fDom fCod),
      refineEquivFun f f'
      -> refineEquivFun (unCurry _ f) (unCurry _ f').
  Proof.
    induction fDom; simpl.
    - split; intros; destruct H; simpl in *; eauto.
    - split; destruct H; simpl in *; intros.
      + eapply IHfDom; split; intros; eauto.
      + eapply IHfDom; split; intros; eauto.
  Qed.

  Lemma refineFun_unCurry
        (fDom : list Type)
        {fCod : Type}
    : forall (f f' : funType fDom fCod),
      refineFun f f'
      -> refineFun (unCurry _ f) (unCurry _ f').
  Proof.
    induction fDom; simpl.
    - intros; eauto.
    - intros.
      eapply IHfDom; eauto.
  Qed.

  Lemma refineFun_unCurry'
        (fDom : list Type)
        {fCod : Type}
    : forall (f f' : funType fDom fCod),
      refineFun (unCurry _ f) (unCurry _ f')
      -> refineFun f f'.
  Proof.
    induction fDom; simpl.
    - intros; eapply (H tt).
    - intros.
      eapply IHfDom; eauto.
      simpl; intros.
      eapply (H (t, t0)).
  Qed.

  Fixpoint refineFun_lift
           (fDom : list Type)
           {fCod : Type}
           {struct fDom}
    : ((funType fDom fCod -> Prop) -> Prop) -> funType fDom fCod :=
    match fDom return
          ((funType fDom fCod -> Prop) -> Prop)
          -> funType fDom fCod with
    | nil => fun LFP_P v => (LFP_P (fun cv => computes_to cv v))
    | cons T fDom' =>
      fun LFP_P =>
        fun (t : T) => refineFun_lift fDom' (fun cv => LFP_P (fun cv' => cv (cv' t)))
    end.

  Definition refineFun_sup
             {fDom : list Type}
             {fCod : Type}
             (f : funType fDom fCod -> Prop)
    : funType fDom fCod :=
    refineFun_lift fDom (fun z => (forall s, f s -> z s)).

  Lemma refineEquivFun_lift
        {fDom : list Type}
        {fCod : Type}
    : forall (f : (funType fDom fCod -> Prop) -> Prop),
      refineEquivFun
        (refineFun_lift fDom f)
        (Curry _ (refineFun_lift _ (fun p : funType (cons (unCurry_funType fDom) nil) fCod -> Prop => f (fun f' => p (unCurry _ f' ))))).
  Proof.
    induction fDom; simpl.
    - intros; split; reflexivity.
    - simpl; split; simpl; intros.
      destruct (IHfDom (fun f' => f (fun a' => f' (a' t)))); simpl in *.
      eapply H.
      destruct (IHfDom (fun f' => f (fun a' => f' (a' t)))); simpl in *.
      eapply H0.
  Qed.

#[global]
  Instance refineFun_Proper'
           {fDom : list Type}
           {fCod : Type}
    : Proper (refineEquivFun ==> refineEquivFun ==> Basics.flip Basics.impl)
             (@refineFun fDom fCod).
  Proof.
    unfold Proper, respectful, refineEquivFun, Basics.flip,
    Basics.impl; intros; simpl; intuition.
    rewrite H3, H1; eauto.
  Qed.

#[global]
  Instance refineFun_Proper''
           {fDom : list Type}
           {fCod : Type}
           a
    : Proper (refineEquivFun
                ==> Basics.flip Basics.impl)
             (@refineFun fDom fCod a).
  Proof.
    unfold Proper, respectful, refineEquivFun, Basics.flip,
    Basics.impl; intros; simpl; intuition.
    rewrite H0; eauto.
  Qed.

  Lemma lub_refineFun_sup
        (fDom : list Type)
        {fCod : Type}
        (f : funType fDom fCod -> Prop)
    : lub f (refineFun_sup f).
  Proof.
    unfold refineFun_sup.
    unfold lub; split.
    - simpl; intros.
      rewrite refineEquivFun_lift; simpl.
      etransitivity.
      eapply refineFunEquiv_unCurry.
      eapply refineFun_Curry'.
      simpl; unfold refine, computes_to; intros; eauto.
    - simpl; intros.
      etransitivity; [ eapply refineEquivFun_lift |
                       eapply refineFun_unCurry' ].
      simpl; intros.
      etransitivity.
      eapply (proj1 (refineFunEquiv_Curry  _ _)).
      simpl.
      unfold refine, computes_to; intros.
      eapply H in H1.
      eapply (refineFun_unCurry _ _ _ H1); eauto.
  Qed.

  Definition refineFun_inf
             {fDom : list Type}
             {fCod : Type}
             (f : funType fDom fCod -> Prop)
    : funType fDom fCod :=
    refineFun_lift fDom (fun z => exists s, f s /\ z s).

  Definition glb_refineFun_inf
             (fDom : list Type)
             {fCod : Type}
             (f : funType fDom fCod -> Prop)
    : glb f (refineFun_inf f).
  Proof.
    unfold refineFun_inf.
    unfold glb; split.
    - simpl; intros.
      etransitivity; [ eapply refineEquivFun_lift | ].
      etransitivity; [eapply refineFun_Curry' | ].
      simpl; unfold refine, computes_to.
      intros; eauto.
      eapply refineFunEquiv_unCurry.
    - simpl; intros.
      etransitivity; [ | eapply refineEquivFun_lift ].
      eapply refineFun_unCurry'.
      simpl; intros.
      unfold refine, computes_to; intros.
      pose proof (proj2 (refineFunEquiv_Curry _ _) t _ H0).
      simpl in H1; unfold computes_to in H1; destruct H1;
        intuition.
      apply H in H2.
      eapply refineFun_unCurry in H2; apply H2; eauto.
  Qed.

#[global]
  Instance CompleteLattice_funDef
           {fDom : list Type}
           {fCod : Type}
    :  CompleteLattice (O := @funDefOps fDom fCod).
  Proof.
  refine
    {| cl_sup := refineFun_sup;
      cl_inf := refineFun_inf
    |}.
    eapply glb_refineFun_inf.
    eapply lub_refineFun_sup.
  Defined.

  (* The use of refineFun as the relation on our lattice makes  *)
  (* this definition counterintuitive: the 'standard' definition *)
  (* of least fixed point of f as the intersection of all f-closed *)
  (* sets, is in fact, the supremum (defined above as the intersection *)
  (* operator of the postfixed sets (as refineFun is pointwise *)
  (* superset relation. *)

  Definition LeastFixedPoint
             {fDom : list Type}
             {fCod : Type}
             (fDef : funType fDom fCod -> funType fDom fCod)
    : funType fDom fCod :=
    (cl_sup (postfixed_point fDef)).

  (* [unroll_LeastFixedPoint] is for unrolling one layer of *)
  (* recursion in an assumption about the result of a Fixpoint *)
  (* computation. *)

  Lemma unroll_LeastFixedPoint
        {fDom : list Type}
        {fCod : Type}
        (fDef : funType fDom fCod -> funType fDom fCod)
        (fDef_monotone : monotonic_function fDef)
    : refineFun (fDef (LeastFixedPoint fDef)) (LeastFixedPoint fDef).
  Proof.
    eapply (Is_GreatestFixedPoint fDef fDef_monotone).
  Qed.

  (* [unroll_LeastFixedPoint'] is for unrolling one layer of *)
  (* recursion in the conclusion about a Fixpoint computation. *)

  Lemma unroll_LeastFixedPoint'
        {fDom : list Type}
        {fCod : Type}
        (fDef : funType fDom fCod -> funType fDom fCod)
        (fDef_monotone : monotonic_function fDef)
    : refineFun (LeastFixedPoint fDef) (fDef (LeastFixedPoint fDef)).
  Proof.
    eapply (Is_GreatestFixedPoint fDef fDef_monotone).
  Qed.

  Lemma refine_LeastFixedPoint
        {fDom : list Type}
        {fCod : Type}
        (fDef fDef' : funType fDom fCod -> funType fDom fCod)
    : respectful (@refineFun fDom fCod)
                 (@refineFun fDom fCod)
                 fDef fDef'
      ->
      forall (fDef_monotone : forall rec rec',
                 refineFun rec rec'
                 -> refineFun (fDef rec) (fDef rec'))
             (fDef'_monotone : forall rec rec',
                 refineFun rec rec'
                 -> refineFun (fDef' rec) (fDef' rec')),
        refineFun (LeastFixedPoint fDef)
                  (LeastFixedPoint fDef').
  Proof.
    unfold LeastFixedPoint, respectful; intros.
    destruct (sup_lub (postfixed_point fDef)) as [? ?];
      destruct (sup_lub (postfixed_point fDef')) as [? ?];
      simpl in *.
    etransitivity.
    - pose proof (proj1 (Is_GreatestFixedPoint (O := @funDefOps fDom fCod) _ (fDef_monotone))); etransitivity.
      apply H4.
      eapply H; reflexivity.
    - eapply (H2 (fDef' (refineFun_sup (postfixed_point fDef)))).
      eapply fDef'_monotone.
      etransitivity.
      pose proof (proj1 (Is_GreatestFixedPoint (O := @funDefOps fDom fCod) _ (fDef_monotone))); eapply H4.
      eapply H; reflexivity.
  Qed.

  Lemma LeastFixedPoint_ind
        {fDom : list Type}
        {fCod : Type}
        (fDef : funType fDom fCod -> funType fDom fCod)
        (Inv Post : funType fDom fCod)
    : refineFun Inv (fDef Inv)
      -> (refineFun Post Inv)
      -> refineFun Post (LeastFixedPoint fDef).
  Proof.
    intros; rewrite H0; simpl in *.
    destruct (sup_lub (postfixed_point fDef)) as [? ?].
    simpl in H1; eapply H1.
    eapply H.
  Qed.

  Lemma GreatestFixedPoint_ind
        {fDom : list Type}
        {fCod : Type}
        (fDef : funType fDom fCod -> funType fDom fCod)
        (Inv Post : funType fDom fCod)
    : refineFun (fDef Inv) Inv
      -> (refineFun Inv Post)
      -> refineFun (cl_inf (prefixed_point fDef)) Post.
  Proof.
    intros; rewrite <- H0; simpl in *.
    destruct (inf_glb (prefixed_point fDef)) as [? ?].
    simpl in H1; eapply H1.
    eapply H.
  Qed.

  Fixpoint cfunType
           (fDom : list Type)
           (fCod : Type)
           {struct fDom}
    : Type :=
    match fDom with
    | nil => fCod
    | cons T fDom' => T -> cfunType fDom' fCod
    end.

  Fixpoint Lift_cfunType
           (fDom : list Type)
           (fCod : Type)
           (fDef : cfunType fDom fCod)
           {struct fDom}
    : funType fDom fCod :=
    match fDom return cfunType fDom fCod
                      -> funType fDom fCod with
    | nil => fun f => ret f
    | cons T fDom' => fun f' (t : T) => Lift_cfunType fDom' fCod (f' t)
    end fDef.

  Lemma Finish_refining_LeastFixedPoint
        {fDom : list Type}
        {recT fCod : Type}
        {P : recT -> recT -> Prop}
        (wf_P : well_founded P)
        (fDef : funType (recT :: fDom) fCod -> funType (recT :: fDom) fCod)
        (fDef_monotone : forall rec rec',
            refineFun rec rec'
            -> refineFun (fDef rec) (fDef rec'))
        (fDef' : forall r,
            (forall r', P r' r -> cfunType fDom fCod)
            -> cfunType fDom fCod)
    : (forall r,
          respectful_hetero (funType (recT :: fDom) fCod)
                            (forall r', P r' r -> cfunType fDom fCod)
                            (fun _ => funType fDom fCod)
                            (fun _ => cfunType fDom fCod)
                            (fun f f' => forall r' wf_r,
                                 @refineFun fDom fCod (f r') ((Lift_cfunType _ _ (f' r' wf_r))))
                            (fun rec rec' f f' =>
                               @refineFun fDom fCod f
                                          (Lift_cfunType _ _ f'))
                            (fun rec => fDef rec r) (fDef' r))
      ->
      refineFun (LeastFixedPoint fDef )
                (Lift_cfunType (recT :: fDom) fCod (Fix wf_P _ fDef' )).
  Proof.
    unfold LeastFixedPoint, respectful_hetero; intros.
    simpl in H.
    simpl.
    simpl in H.
    intros; pattern t; eapply (well_founded_ind wf_P).
    simpl; intros; rewrite Fix_eq.
    pose proof (proj1 (Is_GreatestFixedPoint (O := @funDefOps (recT :: fDom) fCod) _ (fDef_monotone))); etransitivity.
    eapply H1; eauto.
    eapply H; eauto.
    intros; f_equal.
    repeat (eapply functional_extensionality_dep; intros); eauto.
  Qed.

  Definition FibonacciSpec
    : funType ((nat : Type) :: @nil Type)%list nat :=
    LeastFixedPoint (fDom := (nat : Type) :: @nil Type)%list
                    (fun rec (n : nat) =>
                       match n with
                       | 0 => { x | x < 1}
                       | 1 => ret 1
                       | S (S n') =>
                         n1 <- rec n';
                         n2 <- rec (S n');
                         ret (n1 + n2)
                       end).

  Lemma refine_match_nat {A}
        {P : nat -> nat -> Prop}
        {Q : forall n,  (forall n', P n' n -> A) -> Prop}
    : forall (cO : Comp A) cS n cO'
             cS'
             (y : forall n', P n' n -> A),
      (refine cO (ret cO'))
      -> (forall n (y : forall n', P n' (S n) -> A),
             Q (S n) y
             -> refine (cS n) (ret (cS' n y)))
      ->
      Q n y
      -> refine (match n with
                 | 0 => cO
                 | S n' => cS n'
                 end)
                (ret (match n return
                            (forall n', P n' n -> A)
                            -> A
                      with
                      | 0 => fun _ => cO'
                      | S n' => fun y => cS' n' y
                      end y)).
  Proof.
    destruct n; eauto.
  Qed.

  Import Fiat.Common.

  Ltac solve_rec_obligation x solveTac idm :=
    lazymatch goal with
    | H : forall r' (wf_r : @?P r'), refine (x r') _
                                     |- context [x ?r] =>
      let idm' := fresh idm in
      let wf_sub' := fresh in
      let wf_subP' := (eval pattern r in (P r)) in
      let wf_subP := match wf_subP' with ?P' _ => constr:(P') end in
      assert (forall r'', wf_subP r'') as wf_sub';
      [clear; abstract solveTac using idm'
      | clear wf_sub' ]
    end.

  Definition FibonacciImpl'
    : {Impl : _ & refineFun FibonacciSpec (Lift_cfunType _ _ Impl)}.
  Proof.
    eexists.
    etransitivity.
    - eapply Finish_refining_LeastFixedPoint with (wf_P := Wf_nat.lt_wf);
        simpl; intros.
      + destruct t; try reflexivity.
        destruct t; try reflexivity.
        repeat setoid_rewrite H; reflexivity.
      + unfold respectful_hetero; simpl; intros.
        revert H.
        eapply (@refine_match_nat
                  _ lt
                  (fun r y => forall (r' : nat) (wf_r : r' < r), refine (x r') (ret (y r' wf_r))) _ _ r _ _ y).
        * refine pick val 0; auto with arith; reflexivity.
        * intros; simpl in *.
          revert H.
          eapply (@refine_match_nat _ (fun n' n => n' < S n)
                                    (fun r y => forall (r' : nat) (wf_r : r' < S r), refine (x r') (ret (y r' wf_r))) _ _ n _ _ y0).
          reflexivity.
          intros; subst; set_evars.
          simpl in *.

          (* Having to provide new, unique identifiers is not ideal. *)
          (* Have to go to ML for a better solution. *)
          solve_rec_obligation x ltac:(intros; omega) foo;
            rewrite (H _ (foo _)); simplify with monad laws.

          solve_rec_obligation x ltac:(intros; omega) foo2;
            rewrite (H _ (foo2 _)); simplify with monad laws.
          subst H0; higher_order_reflexivity.
    - simpl; intros; higher_order_reflexivity.
  Defined.

  Definition FibonacciImpl :=
    Eval simpl in (projT1 FibonacciImpl').

  Print FibonacciImpl.
End LeastFixedPointFun.