Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import sha.vst_lemmas.

Require Import sha.hmac_common_lemmas.
Require Import sha.spec_hmac.

Require Import sha.hkdf.
Require Import sha.spec_hkdf.
Require Import sha.hkdf_functional_prog.

Definition Done (i:Z): int := Int.repr (digest_len*i).
Definition OUTpred PrkCont InfoCont sh z r cont p: mpred:=
  data_at sh (tarray tuchar z) (sublist 0 z (map Vubyte (HKDF_expand PrkCont InfoCont cont))) p *
  memory_block sh r (offset_val z p).

Definition PREVcont PRK INFO (i: Z): reptype (Tarray tuchar 32 noattr) :=
     if zeq i 0 then list_repeat 32 Vundef
     else (map Vubyte (Ti (CONT PRK) (CONT INFO) (Z.to_nat i))).

Lemma PREV_len PRK INFO i: 0 <= i -> Zlength (PREVcont PRK INFO i) = 32.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). rewrite Zlength_list_repeat'; reflexivity.
assert (exists n, Z.to_nat i = S n).
{ specialize (Z2Nat_inj_0 i). intros.
  destruct (Z.to_nat i). omega. eexists; reflexivity. }
destruct H0; rewrite H0.
unfold Ti; simpl. repeat rewrite Zlength_map. apply HMAC_Zlength.
Qed.

Lemma PREVcont_Sn PRK INFO i p: 0 <= i <= Byte.max_unsigned -> PREVcont PRK INFO i = map Vubyte p ->
      PREVcont PRK INFO (i+1) = if zeq i 0 then map Vubyte (HMAC256_functional_prog.HMAC256 (CONT INFO ++ [Byte.one]) (CONT PRK))
                                else map Vubyte (HMAC256_functional_prog.HMAC256 (p ++ CONT INFO ++ [Byte.add (Byte.repr i) Byte.one]) (CONT PRK)).
Proof. intros. unfold PREVcont.
destruct (zeq (i+1) 0). omega.
change (i+1) with (Z.succ i). rewrite Z2Nat.inj_succ; try omega. simpl.
unfold PREVcont in H0.
destruct (zeq i 0).
+ subst i. simpl; trivial.
+ apply map_Vubyte_injective in H0. (* apply map_IntReprOfBytes_injective in H0; trivial.*)
  rewrite H0, Zpos_P_of_succ_nat, Z2Nat.id; trivial; try omega. repeat f_equal.
  unfold Z.succ, Byte.add, Byte.one. f_equal. rewrite 2 Byte.unsigned_repr; trivial; rep_omega.
Qed.

Lemma PREV_listbyte PRK INFO i: 0 < i -> exists l, PREVcont PRK INFO i = map Vubyte l.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). omega. eexists; reflexivity.
Qed.

Lemma sublist_HKDF_expand4 PRK INFO i rest l (REST : 0 <= rest < 32)
      (g : 255 >= i + 1) (OLEN : 32 * i + rest + 32 <= Int.max_unsigned)
      (Hl : if zeq i 0 then l = [] else PREVcont PRK INFO i = map Vubyte l)
      (Hi: 0 <= i):
sublist 0 rest
  (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [Byte.add (Byte.repr i) Byte.one]) (CONT PRK)) =
sublist (32 * i) (32 * i + rest) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold PREVcont in Hl. destruct (zeq i 0).
  + subst i l; simpl. rewrite Z.add_0_l. unfold HKDF_expand; simpl.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r. rewrite Byte.add_zero_l. reflexivity.
  + apply map_Vubyte_injective in Hl. subst.
    unfold HKDF_expand; simpl.
    destruct (zle (32 * (i + 1)) 0); try omega.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r.
    rewrite (Zmod_unique _ _ (i+1) 0); try omega. simpl.
    rewrite (Zdiv_unique _ _ (i+1) 0); try omega.
    replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
    simpl. rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
    rewrite Zminus_diag, <- app_assoc, Zpos_P_of_succ_nat, Z2Nat.id; try omega.
    replace ((32 * i + rest - 32 * i)%Z) with rest%Z by omega. repeat f_equal.
  unfold Z.succ, Byte.add, Byte.one. f_equal. rewrite 2 Byte.unsigned_repr; trivial; rep_omega.
Qed.

Lemma sublist_HKDF_expand5 PRK INFO l i
         (Hl : if zeq i 0 then l = []
               else PREVcont PRK INFO i = map Vubyte l)
         (Hi : 0 <= i <= Byte.max_unsigned):
      sublist 0 32 (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [Byte.add (Byte.repr i) Byte.one]) (CONT PRK)) =
      sublist (32 * i) (32 * i + 32) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold HKDF_expand. destruct (zle (32*(i + 1)) 0); try omega. simpl.
  rewrite (Zmod_unique _ _ (i+1) 0) by omega. simpl.
  rewrite (Zdiv_unique _ _(i+1) 0) by omega.
  rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
  simpl.
  rewrite Zpos_P_of_succ_nat, Z2Nat.id; try omega.
  rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
  rewrite Zminus_diag. replace ((32 * i + 32 - 32 * i)%Z) with 32%Z by omega.
  unfold PREVcont in Hl.
  destruct (zeq i 0). { simpl in *; subst i l; simpl; trivial. }
  apply map_Vubyte_injective in Hl.
  rewrite Hl, <- app_assoc. repeat f_equal.
  unfold Z.succ, Byte.add, Byte.one. f_equal. rewrite 2 Byte.unsigned_repr; trivial. rep_omega.
Qed.

Lemma body_hkdf_expand: semax_body Hkdf_VarSpecs Hkdf_FunSpecs
       f_HKDF_expand HKDF_expand_spec.
Proof.
start_function.
rename H into LenPRK. rename H0 into LEN_INFO1.
destruct H1 as [LEN_INFO2 LEN_INFO3]. rename H2 into OLEN.

freeze FR1 := - .
forward. forward. forward. forward.
{ entailer!. inv H. }
unfold Int.divu, Int.add, Int.sub.
assert (OLEN2: 0 <= (olen + 32 - 1) / 32 <= Int.max_unsigned).
{ split. apply Z_div_pos; omega.
  apply Zdiv_le_upper_bound; omega. }
rewrite (Int.unsigned_repr 32); [| rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr olen); [| omega].
rewrite (Int.unsigned_repr 1); [| rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr (Int.unsigned (Int.repr (olen + 32)) - 1));
  [| rewrite Int.unsigned_repr; omega].
rewrite Int.unsigned_repr; [| omega].
forward_if
  (EX v:_,
   PROP (if zlt (olen + 32) olen then v = Vint (Int.repr 1)
         else v = Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))) )
   LOCAL (temp _t'1 v;
   temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvars gv)  SEP (FRZL FR1)).
{ forward. Exists (Vint (Int.repr 1)). erewrite zlt_true; try eapply H.
  entailer!. }
{ forward.
  Exists (Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32)))).
  rewrite if_false; trivial.
  entailer!. unfold sem_cast, sem_cast_i2bool, Val.of_bool; simpl.
  destruct (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))); simpl; reflexivity. }
apply extract_exists_pre. intros v. Intros. rename H into HV.
unfold Int.ltu in HV.
rewrite Int.unsigned_repr in HV; [| rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega].
rewrite Int.unsigned_repr in HV; [| omega].
unfold Val.of_bool in HV.
forward_if
  (PROP (v=Vint (Int.repr 0))
   LOCAL (temp _t'1 v; temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   (*gvar sha._K256 kv*)gvars gv)  SEP (FRZL FR1)).
{ unfold typed_true in H.
  rewrite if_false in HV; try omega.
  subst v.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); [clear H | inv H].
  forward. normalize.
  Exists (expand_out_post shmd (CONT PRK) (CONT INFO) olen out).
  entailer!.
  + unfold expand_out_post, digest_len; simpl.
    rewrite if_false; try omega.
    rewrite if_true; trivial.
  + thaw FR1.
    unfold expand_out_post, digest_len; simpl.
    rewrite if_false; try omega.
    rewrite if_true; trivial. simpl. cancel. }
{ forward. entailer!. unfold typed_false in H; simpl in H; inv H.
  destruct (zlt (olen + 32) olen). inv HV; simpl in *; try discriminate.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); inv HV; simpl in *; try discriminate; trivial. }
Intros. subst v. rewrite if_false in HV; try omega.
destruct (zlt 255 ((olen + 32 - 1) / 32)); [inv HV | clear HV].
drop_LOCAL 0%nat.
thaw FR1.
Time assert_PROP (isptr prk) as isPtrPrk by entailer!.

freeze FR1 := - (data_at_ _ _ v_hmac) (data_block _ _ prk) (spec_sha.K_vector _).
assert_PROP (field_compatible t_struct_hmac_ctx_st [] v_hmac) as FC_hmac by entailer!.
replace_SEP 1 (HMAC_SPEC.EMPTY Tsh v_hmac).
{ entailer!. eapply HMAC_SPEC.mkEmpty; trivial. }
idtac "Timing the call to _HMAC_Init".
Time forward_call (@inr (share * val * Z * list byte * globals) _ (Tsh,v_hmac, spec_hmac.LEN PRK, CONT PRK, (*kv*)gv, prk)).
(*Finished transaction in 1.717 secs (1.371u,0.017s) (successful)*)

remember ((olen + 32 - 1) / 32) as bnd.
thaw FR1.
assert_PROP (isptr v_previous /\ field_compatible (tarray tuchar 64) [] v_previous) as prevPtr by entailer!.
destruct prevPtr as [prevPtr prevFC].

unfold data_at_ at 2. unfold field_at_.
rewrite field_at_data_at. simpl. unfold tarray.
assert (JM: default_val (Tarray tuchar 64 noattr) = sublist 0 64 (list_repeat 64 Vundef)).
{ (*subst vv.*) rewrite sublist_list_repeat with (k:=64); try omega; reflexivity. }
erewrite  split2_data_at_Tarray with (n1:=32); [ | omega | | apply JM | reflexivity | reflexivity].
 2: rewrite Zlength_list_repeat'; simpl; omega.
normalize.
rewrite field_address_offset by auto with field_compatible. simpl.
rewrite isptr_offset_val_zero; trivial.
rewrite field_address0_offset by auto with field_compatible. simpl.
rewrite memory_block_field_compatible_tarraytuchar by rep_omega.
Intros. rename H into FCout.

freeze FR0 := (data_at _ _ _ (offset_val 32 v_previous)) (data_block _ _ prk).

assert_PROP (isptr out) as isPTRout by entailer!.
assert (Arith: 32 > 0) by omega.
specialize (Z_div_mod_eq olen 32 Arith); intros OLEN1.
assert (REST:= Z_mod_lt olen 32 Arith). remember (olen / 32) as rounds. remember (olen mod 32) as rest.
assert (BND: bnd = if zeq rest 0 then rounds else rounds + 1).
{ subst bnd olen. clear Heqrounds Heqrest.
  destruct (zeq rest 0).
  + subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega. rewrite X; clear X.
    symmetry. eapply Zdiv.Zdiv_unique. 2: reflexivity. omega.
  + assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega. rewrite X; clear X.
    rewrite Z.div_add_l. f_equal. apply Zdiv_unique with (b:=rest -1); omega. omega. }
clear Heqbnd Heqrounds Heqrest.

forward_for_simple_bound bnd
       (EX ii:Z, PROP (0 <= olen - Int.unsigned(if zlt ii bnd then Done ii else Int.repr olen))
             LOCAL (temp _n (Vint (Int.repr bnd));
                    temp _ret (Vint (Int.repr 0));
                    temp _done (Vint (if zlt ii bnd then Done ii else Int.repr olen));
                    temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
                    lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac; lvar _previous (tarray tuchar 64) v_previous;
                    temp _out_key out; temp _out_len (Vint (Int.repr olen)); temp _prk prk;
                    temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK))); temp _info info;
                    temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO))); gvars gv)
             SEP (FRZL FR0; spec_sha.K_vector gv; data_at_ Tsh tuchar v_ctr;
            data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO ii) v_previous;
            data_block Tsh (CONT INFO) info;
            if zeq ii 0 then HMAC_SPEC.REP Tsh (HMAC_SPEC.hABS (CONT PRK) []) v_hmac
            else HMAC_SPEC.FULL Tsh (CONT PRK) v_hmac;
            OUTpred (CONT PRK) (CONT INFO) shmd (Z.min (digest_len * ii) olen)
                    (olen - Z.min (digest_len * ii) olen) (ii*32) out)).
{ destruct (zeq 0 0); try solve [omega]. clear e; entailer!.
  + unfold Done; simpl.
    destruct (zeq rest 0); simpl.
    - subst rest.
      destruct (zlt 0 rounds); simpl.
      * split; trivial. rewrite Int.unsigned_repr; omega.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. split; trivial; omega.
    - rewrite if_true. 2: omega. split; trivial. rewrite Int.unsigned_repr; omega.
  + unfold OUTpred. destruct (zeq rest 0).
    - subst rest; simpl.
      destruct (zlt 0 rounds); simpl.
      * rewrite Zplus_0_r, Z.min_l, Zminus_0_r, data_at_tuchar_zero_array_eq, isptr_offset_val_zero; trivial; try omega.
        cancel.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. unfold tarray.
        rewrite isptr_offset_val_zero, data_at_tuchar_zero_array_eq; trivial. cancel.
    - rewrite Z.min_l by omega. rewrite Zminus_0_r, data_at_tuchar_zero_array_eq; trivial.
      rewrite isptr_offset_val_zero; trivial. cancel.
}

{ (*loop body*)
  rename H into Hi1. Intros. rename i into i1. rename H into olenBounded. unfold Done, digest_len in olenBounded.
   rewrite if_true in olenBounded; try omega.
   rewrite Int.unsigned_repr in olenBounded. 2: rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega.

  forward. rewrite Z.min_l by (unfold digest_len; omega).

  forward_if (EX l:_,
  PROP ( if zeq i1 0 then l=@nil byte  else PREVcont PRK INFO i1 = map Vubyte l)
   LOCAL (temp _i (Vint (Int.repr i1)); temp _n (Vint (Int.repr bnd));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (if zlt i1 bnd then Done i1 else Int.repr olen));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (LEN PRK))); temp _info info;
   temp _info_len (Vint (Int.repr (LEN INFO))); gvars gv)
   SEP (FRZL FR0; spec_sha.K_vector gv;
   field_at Tsh tuchar []
     (Vint (cast_int_int I8 Unsigned (Int.add (Int.repr i1) (Int.repr 1)))) v_ctr;
   data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO i1) v_previous;
   data_block Tsh (CONT INFO) info;
   OUTpred (CONT PRK) (CONT INFO) shmd (digest_len * i1) (olen - digest_len * i1) (i1*32) out;
   HMAC_SPEC.REP Tsh (HMAC_SPEC.hABS (CONT PRK) l) v_hmac)).

   { destruct (zlt i1 bnd); try omega. rewrite if_false; trivial.
     freeze FR1 := - (spec_sha.K_vector _) (data_at _ _ _ v_previous) (HMAC_SPEC.FULL _ _ v_hmac).
     idtac "Timing the call to _HMAC_Init".
     Time forward_call (@inl _ (share * val * Z * list byte * globals * val) (Tsh, v_hmac,0,CONT PRK, gv)).
     (* Finished transaction in 1.73 secs (1.472u,0.011s) (successful)*)
     destruct (PREV_listbyte PRK INFO i1) as [prev Hprev]; [ omega | rewrite Hprev ].
     assert (Zlength_prev: Zlength prev = 32).
     { specialize (PREV_len PRK INFO i1). rewrite Hprev.
       rewrite Zlength_map. intros X; rewrite X; trivial. omega. }

     idtac "Timing the first call to _HMAC_Update".
     Time forward_call (CONT PRK, v_hmac, Tsh, v_previous, Tsh, @nil byte, prev, gv).
     (*Finished transaction in 2.55 secs (2.048u,0.005s) (successful)*)
     * rewrite Zlength_prev. (*, sem_cast_neutral_ptr; trivial. *)
       apply prop_right; split; trivial.
     * assert (Frame = [FRZL FR1]). subst Frame; reflexivity. simpl; cancel.
       unfold data_block, tarray. rewrite Zlength_prev; trivial.
     * rewrite Zlength_prev, Zlength_nil.
       split. apply writable_share_top. split. apply readable_share_top.
       rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega.
     * Exists prev. rewrite if_false; trivial. entailer!. thaw FR1. cancel.
       unfold data_block. normalize. rewrite Hprev, Zlength_prev. simpl app; cancel. }
   { subst i1. forward. Exists (@nil byte). rewrite ! if_true; try omega.
     entailer!. }

   apply extract_exists_pre. intros l. Intros. rename H into Hl. rewrite if_true by omega.

   idtac "Timing the second call to _HMAC_Update".
   Time forward_call (CONT PRK, v_hmac, Tsh, info, Tsh, l, CONT INFO, gv).
   (* Finished transaction in 2.659 secs (2.094u,0.014s) (successful)*)
   { rewrite LEN_INFO1.
     apply prop_right. split; reflexivity. }
   { split. apply writable_share_top. split. apply readable_share_top. split. omega.
     destruct (zeq i1 0).
     + subst i1 l. rewrite Zlength_nil, Zplus_0_r. omega.
     + assert (Arith1: 0<= i1) by omega. specialize (PREV_len PRK INFO i1 Arith1); intros HZ.
       rewrite Hl, Zlength_map in HZ; rewrite HZ, <- Zplus_assoc; simpl. omega. }

   freeze FR3 := - (HMAC_SPEC.REP _ _ _) (spec_sha.K_vector _)
            (field_at _ _ _ _ v_ctr).
   assert_PROP (field_compatible (tarray tuchar 1) [] v_ctr /\ isptr v_ctr) as HH by entailer!.
   destruct HH as [FC_cptr isptrCtr].

   replace_SEP 3 (data_at Tsh (tarray tuchar 1) [Vint (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))] v_ctr).
   { entailer!. apply data_at_tuchar_singleton_array. }
   assert (LENB: Zlength [Byte.add (Byte.repr i1) Byte.one]= 1) by reflexivity.

   idtac "Timing the third call to _HMAC_Update".
   Time forward_call (CONT PRK, v_hmac, Tsh, v_ctr, Tsh, l++CONT INFO, [Byte.add (Byte.repr i1) Byte.one], gv).
   (* Finished transaction in 2.64 secs (2.057u,0.004s) (successful)*)
   { assert (Frame = [FRZL FR3]). subst Frame; reflexivity. subst Frame. simpl. cancel. apply data_at_ext_derives; trivial.
     simpl. unfold Vubyte, Int.add. rewrite <- verif_hmac_init_part2.isbyte_zeroExt8. f_equal. f_equal.
     unfold Byte.add.
     rewrite 2 Int.unsigned_repr; try (rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega).
     unfold Byte.one; rewrite ! Byte.unsigned_repr; trivial; try rep_omega.
     rewrite ! Byte.unsigned_repr; trivial; try rep_omega.
     rewrite ! Int.unsigned_repr; trivial; try rep_omega. }
   { split. apply writable_share_top. split. apply readable_share_top.
     rewrite LENB. rewrite hmac_pure_lemmas.int_max_unsigned_eq, Zlength_app. split. omega.
     destruct (zeq i1 0).
     + subst l; rewrite Zlength_nil. rewrite Z.add_0_l. omega.
     + specialize (PREV_len PRK INFO i1). rewrite Hl, Zlength_map.
       intros HH; rewrite HH; omega. }

   normalize. thaw FR3.
   freeze FR4 := - (HMAC_SPEC.REP _ _ v_hmac) (spec_sha.K_vector _)
                     (data_at _ _ _ v_previous).
   replace_SEP 3 (memory_block Tsh 32 v_previous).
   { entailer!. eapply derives_trans. apply data_at_memory_block. simpl; trivial. }
   idtac "Timing the call to _HMAC_Final".
   Time forward_call (((l ++ CONT INFO) ++ [Byte.add (Byte.repr i1) Byte.one]),
                 CONT PRK, v_hmac, Tsh, v_previous, Tsh, gv).
   (* Finished transaction in 2.64 secs (2.057u,0.004s) (successful)*)
   unfold data_block.
   rewrite HMAC_Zlength.
   remember (HMAC256_functional_prog.HMAC256
                   ((l ++ CONT INFO) ++
                    [Byte.add (Byte.repr i1) Byte.one])
                   (CONT PRK)) as CONTRIB.
   forward.
   forward_if
  (PROP ( )
   LOCAL (temp _todo (if zlt olen
                             (Int.unsigned (Int.add (Done i1) (Int.repr 32)))
                      then Vint (Int.sub (Int.repr olen) (Done i1))
                      else Vint (Int.repr 32));
   temp _i (Vint (Int.repr i1));
   temp _n (Vint (Int.repr bnd)); temp _ret (Vint (Int.repr 0));
   temp _done (Vint (Done i1)); temp _digest_len (Vint (Int.repr 32));
   lvar _ctr tuchar v_ctr; lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous;
   temp _out_key out; temp _out_len (Vint (Int.repr olen));
   temp _prk prk; temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvars gv)
   SEP (data_at Tsh (tarray tuchar 32) (map Vubyte CONTRIB) v_previous;
   spec_sha.K_vector gv; HMAC_SPEC.FULL Tsh (CONT PRK) v_hmac; FRZL FR4)).
   { forward. entailer!. rewrite if_true; trivial; omega. }
   { forward. entailer!. rewrite if_false; trivial; omega. }

   thaw FR4.
   unfold OUTpred, Done, digest_len. normalize.
   freeze FR5 := - (memory_block _ _ (offset_val (32*i1) out))
                       (data_at _ _ _ v_previous).
   idtac "Timing the call to _memcpy".
   Time forward_call ((Tsh, shmd),
                 offset_val (32*i1) out, v_previous,
                 olen - (32* i1), 32,
             if zlt olen (32 * i1 + 32)
             then olen - 32 * i1
             else 32, CONTRIB).
   (* Finished transaction in 4.255 secs (3.485u,0.006s) (successful)*)
   { destruct (zlt olen (32 * i1 + 32)); simpl; entailer!. }
   { split. apply readable_share_top. split. trivial.
     destruct (zlt olen (32 * i1 + 32)); omega. }
   forward.

   (* establish loop invariant*)
   destruct (zeq (i1 + 1) 0); try omega.
   destruct (zlt olen (32 * i1 + 32)).
   + entailer!.
     * clear - OLEN2 olenBounded OLEN Hi1 REST l0. unfold Done, digest_len in *. simpl.
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds); rewrite Int.unsigned_repr; omega.
       - destruct (zlt (i1 + 1) (rounds+1)). rewrite Int.unsigned_repr; omega.
         rewrite Int.unsigned_repr; try omega. split. omega. f_equal. f_equal. omega.
     * thaw FR5. destruct out; try contradiction. simpl. rewrite Zminus_diag, memory_block_zero_Vptr. cancel.
       clear H1 H2 H (*AC SC*) H4 H5.
       unfold data_block. simpl. rewrite LENB, data_at_tuchar_singleton_array_eq. cancel.
       rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont; simpl; trivial.
         ++ erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. rep_omega.
       - unfold OUTpred, digest_len. simpl.
         destruct (zeq rest 0).
         ++ subst rest; simpl. rewrite Zplus_0_r in *. omega.
         ++ destruct (zlt (i1 + 1) (rounds + 1)); try solve [omega].
            assert (i1 = rounds) by omega. subst i1.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite Z.min_r; [| omega].
            rewrite Zminus_diag, memory_block_zero_Vptr; try solve [omega].
            replace (((rounds + 1)*32)%Z) with ((32 * (rounds + 1) + 0)%Z) by omega.
            rewrite (split2_data_at_Tarray_tuchar shmd (32 * rounds + rest) (32 * rounds)); simpl; trivial; try omega.

            2: { rewrite Zlength_sublist; try omega.
                     rewrite Zlength_map.
                     rewrite Zlength_HKDF_expand; simpl; omega. }
            unfold tarray; cancel.
               rewrite field_address0_offset; simpl.
               2: eapply field_compatible0_cons_Tarray; [ reflexivity | trivial | omega].
            entailer!. rewrite sublist_sublist; try omega.
            rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite ! sublist_map.

            replace (rounds * 32)%Z with (32*rounds)%Z by omega.
            rewrite sublist_HKDF_expand4, <- sublist_HKDF_expand2; trivial; try omega.
            cancel.

   + entailer!.
     * clear H H0 H1 H2 H3 H4 H5. unfold Done, digest_len in *. simpl.
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
       - destruct (zlt (i1 + 1) (rounds+1)).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
     * thaw FR5. cancel.
       unfold data_block, digest_len. normalize. rewrite LENB, data_at_tuchar_singleton_array_eq. cancel.
       rewrite Z.min_l by omega.
       repeat rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont. simpl; trivial.
         ++ clear - Hl n0 Hi1 g. erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. rep_omega.
       - unfold OUTpred, digest_len. simpl. rewrite Z.mul_add_distr_l, Z.mul_1_r.
         destruct (zeq rest 0).
         ++ subst rest; simpl in *. rewrite Zplus_0_r in *.
            destruct (zlt (i1+1) rounds).
            ** replace (32 * rounds - (32 * i1 + 32)) with (32 * rounds - 32 * i1 - 32) by omega. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1+32) (32 * i1)); simpl; trivial; try omega.
               -- unfold tarray.
                  replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                  rewrite field_address0_offset; simpl.
                  2: { eapply field_compatible0_cons_Tarray. reflexivity.
                           eapply field_compatible_array_smaller0. apply FCout. omega. omega. }
                  rewrite sublist_sublist; try omega.
                  rewrite sublist_sublist; try omega.
                  rewrite ! sublist_map, !  Z.mul_1_l, ! Z.add_0_r, ! Z.add_0_l.
                  clear - Hl Hi1 g.
                  replace ((i1 + 1) * 32)%Z with (32*(i1 + 1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite <- sublist_HKDF_expand2; try omega.
                  erewrite <- sublist_HKDF_expand5; try rep_omega; try eassumption. cancel.
              -- rewrite Zlength_sublist; try omega. rewrite ! Zlength_map.
                 replace ((i1 + 1) * 32)%Z with ((32 * (i1 + 1))+0) by omega.
                 rewrite Zlength_HKDF_expand; omega.
            ** assert (rounds = i1+1) by omega. subst rounds; simpl in *.
               replace (32 * (i1 + 1))%Z with ((32 * i1 + 32)%Z) by omega.
               replace (32 * i1 + 32 - 32 * i1 - 32)%Z with 0%Z by omega.
               rewrite Zminus_diag, memory_block_zero. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1 + 32) (32 * i1)); simpl; trivial; try omega.
               -- replace ((32 * i1 + 32 - 32 * i1)%Z) with 32%Z by omega.
                  rewrite field_address0_offset by auto with field_compatible. simpl.
                  repeat rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r, ! Z.add_0_l, ! Z.mul_1_l.
                  unfold tarray; rewrite sepcon_comm.
                  replace ((i1 + 1) * 32)%Z with (32*(i1+1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite ! sublist_map, <- (sublist_HKDF_expand5 PRK INFO l i1 Hl),
                    <- sublist_HKDF_expand2; try rep_omega; cancel.
               -- rewrite Zlength_sublist; try omega. rewrite Zlength_map.
                  replace (((i1 + 1)*32)%Z) with ((32 * (i1 + 1) + 0)%Z) by omega.
                  rewrite Zlength_HKDF_expand; omega.
          ++ replace (32 * rounds + rest - 32 * i1 - 32)%Z with (32 * rounds + rest - (32 * i1 + 32))%Z by omega.
             cancel.

             rewrite (split2_data_at_Tarray_tuchar shmd (32*i1 + 32) (32*i1)); simpl; trivial; try omega.
                ** rewrite field_address0_offset; simpl. rewrite Z.mul_1_l, Z.add_0_l.
                   rewrite ! sublist_map, ! sublist_sublist, ! Z.add_0_r; try omega.
                   replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                   replace ((i1 + 1)*32)%Z with (32*(i1+1))%Z by omega.
                   replace (i1*32)%Z with (32*i1)%Z by omega.
                   rewrite <- (sublist_HKDF_expand5 PRK INFO l i1 Hl), <- sublist_HKDF_expand2; try rep_omega. cancel.
                   eapply field_compatible0_cons_Tarray; [ reflexivity | | omega].
                   eapply field_compatible_array_smaller0; [ apply FCout | omega].
                ** rewrite ! sublist_map, ! Zlength_map, Zlength_sublist; try omega.
                   replace ((i1 + 1) * 32)%Z with (32 * (i1+1) + 0)%Z by omega.
                   rewrite Zlength_HKDF_expand; omega. }
(*Continuation after loop*)
  normalize. rewrite if_false in H. 2: omega. clear H. (*eliminate this PROP in loop invariant entirely?*)

  forward.
  freeze FR6 := - (if zeq bnd 0 then _ else _).

  idtac "Timing the call to _HMAC_cleanup".
  Time forward_call (CONT PRK, v_hmac, Tsh).
  (* Finished transaction in 1.589 secs (1.371u,0.004s) (successful)*)
    { assert (Frame = [FRZL FR6]). subst Frame; reflexivity.
      subst Frame; simpl. cancel.
      destruct (zeq bnd 0); trivial. apply HMAC_SPEC.REP_FULL. }
  forward. forward.
     Exists (expand_out_post shmd (CONT PRK) (CONT INFO) (32 * rounds + rest) out).
     Time entailer!.
     + unfold expand_out_post, digest_len.
       rewrite if_false. 2: omega.
       rewrite if_false. simpl; trivial.
       destruct (zeq rest 0); simpl in *.
       - subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega.
         rewrite X; clear X. erewrite <- Zdiv.Zdiv_unique. 3: reflexivity. omega. omega.
       - assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega.
         rewrite X; clear X.
         rewrite Z.div_add_l; try omega.
         erewrite Zdiv_unique with (b:=rest -1)(a:=1); omega.
     + thaw FR6. thaw FR0. cancel. unfold expand_out_post, digest_len.
        rewrite 2 sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives; [| apply HMAC_SPEC.EmptyDissolve].
        rewrite <- sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives.
        - destruct (zlt (32 * rounds + rest + 32) (32 * rounds + rest)); try omega.
          destruct (zlt (if zeq rest 0 then rounds else rounds + 1) (if zeq rest 0 then rounds else rounds + 1)); try omega.
          unfold OUTpred, data_block.
          rewrite Z.min_r by (destruct (zeq rest 0); omega).
          rewrite Zminus_diag, memory_block_zero, Zlength_HKDF_expand; try omega. normalize.
          destruct (zlt 255 ((32 * rounds + rest + 32 - 1) / 32)).
          { exfalso. destruct (zeq rest 0).
            + subst rest; simpl in *. replace (32 * rounds + 0 + 32 - 1)%Z with (rounds * 32 + 31) in l by omega.
              rewrite Z_div_plus_full_l, Zdiv_small in l; omega.
            + replace (32 * rounds + rest + 32 - 1)%Z with (rounds * 32 + (rest + 31))%Z in l by omega.
              rewrite Z_div_plus_full_l in l; try omega. erewrite (Zdiv_unique _ _ 1 ((rest + 31)-32)) in l; omega. }
          simpl.
          apply data_at_ext_derives; trivial.
          destruct (zeq rest 0).
          * subst rest; simpl. rewrite Z.add_0_r, sublist_same, Z.mul_comm; trivial.
            rewrite ! Zlength_map. replace ((rounds*32)%Z) with ((32 * rounds + 0)%Z) by omega.
            rewrite Zlength_HKDF_expand; omega.
          * replace ((rounds + 1)*32)%Z with (32 * rounds + 32)%Z by omega.
            rewrite sublist_map. f_equal.
            apply sublist_HKDF_expand3; omega.
        - rewrite (split2_data_at__Tarray_tuchar Tsh 64 32); simpl; trivial; try omega.
          rewrite field_address0_offset. cancel.
          eapply field_compatible0_cons_Tarray; [reflexivity | trivial | omega].
Time Qed.
  (*Finished transaction in 8.645 secs (8.647u,0.s) (successful)*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Monoid_cat.
(** Title "The monoid of maps of a set into itself." *)
Section Def.
Variable E : SET.

Definition endo_comp : law_of_composition (Hom E E).
unfold law_of_composition in |- *.
apply
 (Build_Map
    (Ap:=fun x : cart (Hom E E) (Hom E E) => comp_map_map (proj1 x) (proj2 x))).
red in |- *.
auto with algebra.
Defined.

Definition Endo_SET_sgroup : SGROUP.
apply (Build_sgroup (sgroup_set:=Hom E E)).
apply (Build_sgroup_on (E:=Hom E E) (sgroup_law_map:=endo_comp)).
red in |- *.
simpl in |- *.
unfold Map_eq in |- *; auto with algebra.
Defined.

Definition Endo_SET : MONOID.
apply (Build_monoid (monoid_sgroup:=Endo_SET_sgroup)).
apply (Build_monoid_on (A:=Endo_SET_sgroup) (monoid_unit:=Id E)).
red in |- *.
simpl in |- *.
unfold Map_eq in |- *; auto with algebra.
red in |- *.
simpl in |- *.
unfold Map_eq in |- *; auto with algebra.
Defined.
End Def.


(***************************************************************************
* Safety for STLC with Exceptions - Definitions                            *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(** Grammar of types. *)

Parameter atm : Set.

Inductive typ : Set :=
  | typ_exn : typ
  | typ_var : atm -> typ
  | typ_arrow  : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_raise : trm -> trm
  | trm_catch : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_raise t1  => trm_raise (open_rec k u t1)
  | trm_catch t1 t2 => trm_catch (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_raise : forall t1,
      term t1 ->
      term (trm_raise t1)
  | term_catch : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_catch t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L -> (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) -> E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T
  | typing_raise : forall E t1 T,
      E |= t1 ~: typ_exn ->
      E |= (trm_raise t1) ~: T
  | typing_catch : forall E t1 t2 T,
      E |= t1 ~: (typ_arrow typ_exn T) ->
      E |= t2 ~: T ->
      E |= (trm_catch t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Exception generation *)

Inductive fails : trm -> trm -> Prop :=
  | fails_raise_val : forall t1,
      value t1 ->
      fails (trm_raise t1) t1
  | fails_raise_1 : forall t1 e,
      fails t1 e ->
      fails (trm_raise t1) e
  | fails_app_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_app t1 t2) e
  | fails_app_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_app t1 t2) e.

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2')
  | red_catch_2 : forall t1 t2 t2',
      term t1 ->
      red t2 t2' ->
      red (trm_catch t1 t2) (trm_catch t1 t2')
  | red_catch_val : forall t1 t2,
      term t1 ->
      value t2 ->
      red (trm_catch t1 t2) t2
  | red_catch_exn : forall t1 t2 e,
      term t1 ->
      fails t2 e ->
      red (trm_catch t1 t2) (trm_app t1 e)
  | red_raise_1 : forall t1 t1',
      red t1 t1' ->
      red (trm_raise t1) (trm_raise t1').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ (exists e, fails t e)
  \/ (exists t', t --> t').


(******************************************************************************)
(* Properties of the LLVM IR semantics.                                       *)
(******************************************************************************)

Require ndopsem.
Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Zdiv.
Require Import Tvc.base_tactics.

Lemma repr_unsigned_inverse :
  forall (w : nat) (n : Integers.Int.int w), eq n (Integers.Int.repr w (Integers.Int.unsigned w n)).
Proof.
  intros.
  unfold Integers.Int.repr, Integers.Int.unsigned.
  destruct n.
  simpl.

  pose proof intrange as H2.
  pose proof (Zmod_small intval (Integers.Int.modulus w)) as H4.
  apply H4 in H2.
  clear H4.

  remember (Z_mod_lt intval (Integers.Int.modulus w) (Integers.Int.modulus_pos w)) as intrange2.
  clear Heqintrange2.

  remember ((intval mod (Integers.Int.modulus w))%Z) as intval2.
  clear Heqintval2.

  destruct H2.
  replace intrange with intrange2 by (apply Axioms.proof_irr).
  reflexivity.
Qed.

Lemma unsigned_repr_inverse :
  forall (w : nat) (z : Z), eq (z mod Integers.Int.modulus w)%Z (Integers.Int.unsigned w (Integers.Int.repr w z)).
Proof.
  reflexivity.
Qed.

Lemma repr_signed_inverse :
  forall (w : nat) (n : Integers.Int.int w), eq n (Integers.Int.repr w (Integers.Int.signed w n)).
Proof.
  intros.
  unfold Integers.Int.repr, Integers.Int.signed.
  destruct n.
  simpl.

  destruct (Coqlib.zlt intval (Integers.Int.half_modulus w)).

  (* case 1: intval < half_modulus *)
  pose proof intrange as H2.
  pose proof (Zmod_small intval (Integers.Int.modulus w)) as H4.
  apply H4 in H2.
  clear H4.

  remember (Z_mod_lt intval (Integers.Int.modulus w) (Integers.Int.modulus_pos w)) as intrange2.
  clear Heqintrange2.

  remember ((intval mod (Integers.Int.modulus w))%Z) as intval2.
  clear Heqintval2.

  destruct H2.
  replace intrange with intrange2 by (apply Axioms.proof_irr).
  reflexivity.

  (* case 2: intval >= half_modulus *)
  assert (eq ((intval - Integers.Int.modulus w) mod (Integers.Int.modulus w))%Z intval) as H2.
  rewrite Zminus_mod.
  rewrite Z_mod_same; [ | omega ].
  rewrite Zminus_0_r.
  rewrite Zmod_mod.
  pose proof intrange as H2.
  pose proof (Zmod_small intval (Integers.Int.modulus w)) as H4.
  apply H4 in H2.
  assumption.

  remember (Z_mod_lt (intval - Integers.Int.modulus w) (Integers.Int.modulus w) (Integers.Int.modulus_pos w)) as intrange2.
  clear Heqintrange2.

  remember (((intval - Integers.Int.modulus w) mod (Integers.Int.modulus w))%Z) as intval2.
  clear Heqintval2.

  destruct H2.
  replace intrange with intrange2 by (apply Axioms.proof_irr).
  reflexivity.
Qed.

Lemma ltb_false_geb_true n m : (n <? m)%Z = false <-> (n >=? m)%Z = true.
Proof.
  unfold Z.ltb, Z.geb.
  split; intro; destruct (n ?= m)%Z eqn:?; auto.
Qed.

Lemma leb_false_gtb_true n m : (n <=? m)%Z = false <-> (n >? m)%Z = true.
Proof.
  unfold Z.leb, Z.gtb.
  split; intro; destruct (n ?= m)%Z eqn:?; auto.
Qed.

Lemma technical_1 :
  forall z m : Z,
    (m > 0)%Z ->
    (- (m / 2) <= z)%Z ->
    (z < 0)%Z ->
    eq (z mod m)%Z (z + m)%Z.
Proof.
  intros.

  rewrite Zmod_eq; [ | omega ].
  apply Zplus_eq_compat; [ reflexivity | ].

  assert (eq (z / m) (-1))%Z as H'.

  assert (eq ((z + m) / m) 0)%Z.
  apply Z.div_small.
  split.

  rewrite Z.add_comm.
  apply (Zplus_le_compat_l (-(m/2)) z m) in H0.
  rewrite Z.add_opp_r in H0.
  assert (m - m/2 >= 0)%Z.

  apply Z.le_ge.
  apply (Zplus_le_reg_l _ _ (m/2)).
  rewrite Z.add_0_r.
  rewrite Zplus_minus.

  assert (0 <= m)%Z as H2 by omega.
  assert (0 < 1 < 2)%Z as H3 by omega.
  pose proof (Zdiv_le_compat_l _ _ _ H2 H3) as H4.
  rewrite Z.div_1_r in H4.
  assumption.

  omega.

  omega.

  rewrite <- (Z.mul_1_l m) in H2 at 1.
  rewrite (Z.div_add z 1%Z m) in H2.
  omega.
  omega.

  rewrite H'.
  rewrite Z.mul_comm.
  rewrite <- Z.opp_eq_mul_m1.
  rewrite Z.opp_involutive.
  reflexivity.
Qed.

Lemma technical_2 :
  forall z m : Z,
  (- (m / 2) <= z)%Z ->
  (z + m >= m / 2)%Z.
Proof.
  intros.

  apply Z.le_ge.

  pose proof (Z.add_le_mono_r (-(m/2))%Z z m) as H0.
  apply H0 in H.
  clear H0.

  pose proof (Z.add_opp_l m (m/2)%Z) as H0.
  rewrite H0 in H.
  clear H0.

  assert ((m - (m / 2)) >= (m / 2))%Z.
  apply Z.le_ge.
  pose proof (Z.add_le_mono_r (m/2) (m - (m/2)) (m/2)) as H0.
  apply <- H0.
  clear H0.

  rewrite Z.sub_add.

  Lemma x_plus_x :
    forall x : Z, eq (x + x)%Z (2 * x)%Z.
  Proof.
    intro.
    omega.
  Qed.

  rewrite x_plus_x.
  rewrite (Z.mul_div_le m 2) by omega.
  omega.

  apply Z.ge_le in H0.
  apply (Z.le_trans _ _ _ H0 H).
Qed.

Lemma signed_repr_inverse :
  forall (w : nat) (z : Z), ((- Integers.Int.half_modulus w) <= z < (Integers.Int.half_modulus w))%Z -> eq z (Integers.Int.signed w (Integers.Int.repr w z)).
Proof.
  intros.
  unfold Integers.Int.repr, Integers.Int.signed, Integers.Int.half_modulus in *.
  simpl.
  pose proof (Integers.Int.modulus_pos w) as H99.
  remember (Integers.Int.modulus w) as m in *.
  decompose [and] H. clear H.
  destruct (Z.ltb z 0) eqn:Heqb.

  (* case 1: z < 0 *)
  clear H1.
  apply Z.ltb_lt in Heqb.
  assert (eq (z mod m)%Z (z + m)%Z) by (apply technical_1; assumption).
  rewrite H.
  assert ((z + m) >= (m / 2))%Z by (apply technical_2; assumption).
  destruct Coqlib.zlt.
  contradiction.
  omega.

  (* case 2: z >= 0 *)
  clear H0.
  apply ltb_false_geb_true in Heqb.
  apply Z.geb_le in Heqb.

  assert (Z.lt z m).
  assert (m / 2 < m)%Z by (apply Z_div_lt; omega).
  eauto using Z.lt_trans.

  pose proof (Zmod_small z m) as H4.
  pose proof (conj Heqb H) as H2.
  apply H4 in H2.
  rewrite H2.

  destruct Coqlib.zlt.
  trivial.
  contradiction.
Qed.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-require" "coqharness" "-impredicative-set" "-R" "." "Tvc" "-R" "../../csem/_coq" "Csem" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/ott" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/monads" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/compcert" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/GraphBasics" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/Dominators" "-I" "../../vellvm-coq84pl2/release/vol/extralibs/metatheory_8.4" "-I" "../../vellvm-coq84pl2/release/vol/extralibs/Coq-Equations/src" "-R" "../../vellvm-coq84pl2/release/vol/extralibs/Coq-Equations/theories" "Equations" "-I" "~/lem/coq-lib") ***
*** End: ***
*)


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

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

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

Import GroupScope.

Section Section11.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End Section11.


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

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

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

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

Class bedrock2_unsaturated_solinas_scmul_func :=
  { carry_scmul_const : func }.

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

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

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

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

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

(*** Helpers ***)

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

(*** Synthesis Tactics ***)

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

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

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

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

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

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

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

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

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

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

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

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.