Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.object.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ tobject]
          PROP ()
          PARAMS (self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() RETURN () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ tobject, tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          PARAMS (self; Vint (Int.repr i))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          RETURN (Vint (Int.repr v))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
#[export] Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () RETURN (p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) RETURN (Vint (Int.repr i)) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP (mapsto _ _ _ _) (data_at _ _ _ _);
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.
assert_PROP (p<>Vundef) by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
assert_PROP (p<>Vundef) by entailer!.
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!.
simpl in H1.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!.
Qed.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat div prime.
Require Import fintype bigops ssralg finset.
Require Import groups morphisms automorphism normal action gprod.
Require Import commutators cyclic center pgroups sylow nilpotent maximal.

(* Require Import seq paths connect finfun perm. *)

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

Import GroupScope.

Theorem Gaschutz : forall (gT : finGroupType) (G H P : {group gT}),
  H <| G -> H \subset P -> P \subset G -> abelian H -> coprime #|H| #|G : P| ->
    [splits G, over H] = [splits P, over H]
 /\ {in [complements to H in G] &, forall K L : {group gT},
     K :&: P = L :&: P -> exists2 x, x \in H & L :=: K :^ x}.
Proof.
move=> gT G H P nsHG sHP sPG abelH coHiPG.
have [sHG nHG] := andP nsHG.
(* set up H as a ZG-module *)
have mulHC : @commutative (subg_of H) mulg.
  by case=> x Hx [y Hy]; apply: val_inj; rewrite /= (centsP abelH).
pose rTm := ZmodMixin (@mulgA _) mulHC (@mul1g _) (@mulVg _).
pose rT := ZmodType rTm; hnf in rT.
have valM: forall a b : rT, sgval (a + b)%R = sgval a * sgval b by [].
have valV: forall a : rT, sgval (- a)%R = (sgval a)^-1 by [].
have valX: forall (a : rT) n, sgval (a *+ n)%R = sgval a ^+ n.
  by move=> a [] //; elim=> // n IHn; congr (_ * _).
pose to (a : rT) y : rT := subg H (sgval a ^ y).
have valA: forall a y, y \in G -> sgval (to a y) = sgval a ^ y.
  by move=> a y Gy; rewrite subgK // memJ_norm ?subgP ?(subsetP nHG).
have to0: forall y, y \in G -> (to 0 y = 0)%R.
  by move=> y Gy; apply: val_inj; rewrite /= valA //= conj1g.
have toM: forall y, y \in G -> {morph to^~ y : a b / a + b}%R.
  by move=> a b y Gy; apply: val_inj; rewrite /= !valA //= conjMg.
have toX: forall a n y, y \in G -> (to (a *+ n) y = to a y *+ n)%R.
  by move=> a n y Gy; apply: val_inj; rewrite /= !(valX, valA) // conjXg.
pose toB y Gy := big_morph (to^~ y) (toM y Gy) (to0 y Gy).
(* Action on right cosets *)
have act_Cayley: forall K L : {group gT}, [acts (L | 'Msr) on rcosets K L].
  move=> K L; apply/subsetP=> x Lx; rewrite 2!inE; apply/subsetP=> X.
  case/rcosetsP=> y Ly ->{X}; rewrite inE /= rcosetE -rcosetM -rcosetE.
  by rewrite mem_imset ?groupM.
(* Get m == 1 / #|G : P| [mod #|H|] *)
have [m mK]: exists m, forall a : rT, (a *+ (#|G : P| * m) = a)%R.
  case: (bezoutl #|H| (indexg_gt0 G P))=> m' _; rewrite gcdnC (eqnP coHiPG).
  case/dvdnP=> m inv_m; exists m => a.
  rewrite mulnC -inv_m /= mulnC GRing.mulrS GRing.mulrnA /=.
  suff ->: (a *+ #|H| = 0)%R by rewrite GRing.mul0rn GRing.addr0.
  apply: val_inj; rewrite /= !valX /=; apply/eqP; rewrite -order_dvdn.
  by rewrite order_dvdG ?subgP.
split=> [|K L].
  apply/splitsP/splitsP=> [[K] | [Q]].
    case/complP=> trHK eqHK; exists (K :&: P)%G.
    rewrite inE setICA (setIidPl sHP) setIC trHK eqxx group_modl // eqHK.
    by rewrite (sameP eqP setIidPr).
  case/complP=> trHQ eqHQ.
  have sQP: Q \subset P by rewrite -eqHQ mulG_subr.
  pose rP x := repr (P :* x); pose pP x := x * (rP x)^-1.
  have PpP: pP _ \in P.
    by move=> x; rewrite -mem_rcoset rcoset_repr rcoset_refl.
  have rPmul : forall x y, x \in P -> rP (x * y) = rP y.
    by move=> x y Px; rewrite /rP rcosetM rcoset_id.
  pose pQ x := remgr H Q x; pose rH x := pQ (pP x) * rP x.
  have pQhq: {in H & Q, forall h q, pQ (h * q) = q} by exact: remgrMid.
  have pQmul: {in P &, {morph pQ : x y / x * y}}.
    apply: remgrM; [exact/complP | exact: normalS nsHG].
  have HrH: forall x, rH x \in H :* x.
    move=> x; rewrite rcoset_sym mem_rcoset invMg mulgA mem_divgr //.
    by rewrite eqHQ PpP.
  have GrH: forall x, x \in G -> rH x \in G.
    move=> x Gx; case/rcosetP: (HrH x) => y Hy ->.
    by rewrite groupM // (subsetP sHG).
  have rH_Pmul: forall x y, x \in P -> rH (x * y) = pQ x * rH y.
    by move=> *; rewrite /rH mulgA -pQmul; first by rewrite /pP rPmul ?mulgA.
  have rH_Hmul: forall h y, h \in H -> rH (h * y) = rH y.
    by move=> h y Hh; rewrite rH_Pmul ?(subsetP sHP) // -(mulg1 h) pQhq ?mul1g.
  pose mu x y : rT := subg H ((rH x * rH y)^-1 * rH (x * y)).
  pose nu y := (\sum_(Px \in rcosets P G) mu (repr Px) y)%R.
  have rHmul : {in G &, forall x y, rH (x * y) = rH x * rH y * sgval (mu x y)}.
    move=> x y Gx Gy; rewrite /= subgK ?mulKVg // -mem_lcoset lcoset_sym.
    rewrite -norm_rlcoset; last by rewrite (subsetP nHG) ?GrH ?groupM.
    rewrite (rcoset_transl (HrH _)) -rcoset_mul ?(subsetP nHG) ?GrH //.
    by rewrite mem_mulg.
  have to_rH : forall a x, x \in G -> to a (rH x) = to a x.
    move=> a x Gx; apply: val_inj; rewrite /= !valA ?GrH //.
    case/rcosetP: (HrH x) => b; move/subgK=> <- ->; rewrite conjgM.
    by congr (_ ^ _); rewrite conjgE -valV -!valM (GRing.addrC a) GRing.addKr.
  have mu_Pmul: forall x y z, x \in P -> mu (x * y) z = mu y z.
    move=> x y z Px; congr subg; rewrite -mulgA !(rH_Pmul x) ?rPmul //.
    by rewrite -mulgA invMg -mulgA mulKg.
  have mu_Hmul: forall x y z, x \in G -> y \in H -> mu x (y * z) = mu x z.
    move=> x y z Gx Hy; congr subg.
    rewrite (mulgA x) (conjgCV x) -mulgA 2?rH_Hmul //.
    by rewrite -mem_conjg (normP _) ?(subsetP nHG).
  have{mu_Hmul} nu_Hmul: forall y z, y \in H -> nu (y * z) = nu z.
    move=> y z Hy; apply: eq_bigr => Px; case/rcosetsP=> x Gx ->{Px}.
    apply: mu_Hmul y z _ Hy.
    by rewrite -(groupMl _ (subsetP sPG _ (PpP x))) mulgKV.
  have cocycle_mu: {in G & &, forall x y z,
    mu (x * y)%g z + to (mu x y) z = mu y z + mu x (y * z)%g}%R.
  - move=> x y z Gx Gy Gz; apply: val_inj.
    apply: (mulgI (rH x * rH y * rH z)).
    rewrite -(to_rH _ _ Gz) GRing.addrC /= valA ?GrH //.
    rewrite mulgA -(mulgA _ (rH z)) -conjgC mulgA -!rHmul ?groupM //.
    by rewrite mulgA -mulgA -2!(mulgA (rH x)) -!rHmul ?groupM.
  move: mu => mu in rHmul mu_Pmul cocycle_mu nu nu_Hmul.
  have{cocycle_mu} cocycle_nu : {in G &, forall y z,
     nu z + to (nu y) z = mu y z *+ #|G : P| + nu (y * z)%g}%R.
  - move=> y z Gy Gz; rewrite /= (toB z Gz).
    have ->: (nu z = \sum_(Px \in rcosets P G) mu (repr Px * y)%g z)%R.
      rewrite /nu (reindex ('Msr%act^~ y)); last first.
        by exists ('Msr%act^~ y^-1) => Px _; rewrite (actK, actKV).
      symmetry; apply: eq_big => Px; first by rewrite (actsP (act_Cayley P G)).
      case/rcosetsP=> x Gx /= ->{Px}; rewrite rcosetE -rcosetM.
      case: repr_rcosetP=> p1 Pp1; case: repr_rcosetP=> p2 Pp2.
      by rewrite -mulgA [x * y]lock !mu_Pmul.
    rewrite -GRing.sumr_const -!big_split /=; apply: eq_bigr => Px.
    case/rcosetsP=> x Gx ->{Px}; rewrite -cocycle_mu //.
    by case: repr_rcosetP=> p1 Pp1; rewrite groupMr // (subsetP sPG).
  move: nu => nu in nu_Hmul cocycle_nu.
  pose f x := rH x * sgval (nu x *+ m)%R.
  have{cocycle_nu} fM: {in G &, {morph f : x y / x * y}}.
    move=> x y Gx Gy; rewrite /f ?rHmul // -3!mulgA; congr (_ * _).
    rewrite (mulgA _ (rH y)) (conjgC _ (rH y)) -mulgA -valA ?GrH ?to_rH //.
    congr (_ * _); rewrite -!valM -(mK (mu x y)) toX //.
    by rewrite GRing.mulrnA -!GRing.mulrn_addl -cocycle_nu // GRing.addrC.
  exists (Morphism fM @* G)%G; apply/complP; split.
    apply/trivgP; apply/subsetP=> x; case/setIP=> Hx.
    case/morphimP=> y _ Gy eq_x.
    apply/set1P; move: Hx; rewrite {x}eq_x /= groupMr ?subgP //.
    rewrite -{1}(mulgKV y (rH y)) groupMl -?mem_rcoset // => Hy.
    rewrite -(mulg1 y) /f nu_Hmul // rH_Hmul //; exact: (morph1 (Morphism fM)).
  apply/setP=> x; apply/mulsgP/idP=> [[h y Hh fy ->{x}] | Gx].
    rewrite groupMl; last exact: (subsetP sHG).
    case/morphimP: fy => z _ Gz ->{x Hx y}.
    by rewrite /= /f groupMl ?GrH // (subsetP sHG) ?subgP.
  exists (x * (f x)^-1) (f x); last first; first by rewrite mulgKV.
    by apply/morphimP; exists x.
  rewrite -groupV invMg invgK -mulgA (conjgC (val _)) mulgA.
  by rewrite groupMl -(mem_rcoset, mem_conjg) // (normsP nHG) // subgP.
case/complP=> trHK eqHK cpHL; case/complP: (cpHL) => trHL eqHL KPeqLP.
pose nu x : rT := subg H (divgr H L x); pose Q := (K :&: P)%G.
have sKG: {subset K <= G} by apply/subsetP; rewrite -eqHK mulG_subr.
have sLG: {subset L <= G} by apply/subsetP; rewrite -eqHL mulG_subr.
have val_nu: forall x, x \in G -> sgval (nu x) = divgr H L x.
  by move=> x Gx; rewrite subgK // mem_divgr // eqHL.
have nu_cocycle: {in G &, forall x y, nu (x * y) = (to (nu y) x^-1%g + nu x)%R}.
  move=> x y Gx Gy; apply: val_inj => /=.
  rewrite valA ?groupV // !(val_nu, groupM, groupV) // /divgr (remgrM cpHL) //.
  by rewrite mulgA -conjgCV -!mulgA -invMg.
have nuL: forall x, x \in L -> nu x = 0%R.
  move=> x Lx; apply: val_inj; rewrite /= val_nu ?sLG //.
  by rewrite /divgr remgr_id ?mulgV.
exists (sgval ((\sum_(X \in rcosets Q K) nu (repr X)^-1%g) *+ m)%R).
  exact: subgP.
apply/eqP; rewrite eq_sym eqEcard; apply/andP.
split; last first.
  by rewrite cardJg -(leq_pmul2l (cardG_gt0 H)) -!TI_cardMg // eqHL eqHK.
apply/subsetP=> /= x_nu; case/imsetP=> x Kx ->{x_nu}.
rewrite conjgE mulgA (conjgC _ x).
have Gx: x \in G by rewrite sKG.
rewrite conjVg -mulgA -valA // -valV -valM (_ : _ + _ = nu x^-1%g)%R.
  rewrite /= val_nu ?groupV //.
  by rewrite mulKVg groupV mem_remgr // eqHL groupV.
rewrite toX // GRing.oppr_muln -GRing.mulrn_addl (toB x Gx).
rewrite GRing.addrC (reindex ('Msr%act^~ x)) /=; last first.
  by exists ('Msr%act^~ x^-1) => Px _; rewrite (actK, actKV).
rewrite (eq_bigl (mem (rcosets Q K))) => [/=|X]; last first.
  by rewrite (actsP (act_Cayley Q K)).
rewrite -GRing.sumr_sub /= (eq_bigr (fun _ => nu x^-1)) => [|X]; last first.
  case/imsetP=> y Ky ->{X}; rewrite !rcosetE.
  set yx1 := repr _; have: yx1 \in Q :* y :* x.
    by apply: (mem_repr (y * x)); rewrite -rcosetM rcoset_refl.
  case/rcosetP=> y1 Qyy1 ->{yx1}; move: (repr _) (mem_repr _ Qyy1) => y2 Qyy2.
  have Gy2: y2 \in G.
    by case/rcosetP: Qyy2 => z2; case/setIP=> Kz2 _ ->; rewrite sKG ?groupM.
  move: Qyy1; rewrite -(rcoset_transl Qyy2) /= KPeqLP; case/rcosetP=> z1.
  case/setIP=> Lz1 _ ->{y1}.
  rewrite !invMg 2?nu_cocycle ?groupM ?groupV // ?sLG // !invgK.
  rewrite (nuL z1^-1) ?groupV // to0 // GRing.add0r (GRing.addrC (to _ x)).
  by rewrite GRing.addrK.
rewrite GRing.sumr_const -GRing.mulrnA (_ : #|_| = #|G : P|) ?mK //.
rewrite -[#|_|]divgS ?subsetIl // -(divn_pmul2l (cardG_gt0 H)).
rewrite -!TI_cardMg //; last by rewrite setIA setIAC (setIidPl sHP).
by rewrite group_modl // eqHK (setIidPr sPG) divgS.
Qed.

Module AfterGaschutz.
End AfterGaschutz.

Theorem SchurZass_split : forall (gT : finGroupType) (G H : {group gT}),
  Hall G H -> H <| G -> [splits G, over H].
Proof.
move=> gT G; move: {2}_.+1 (ltnSn #|G|) => n.
elim: n gT G => // n IHn gT G; rewrite ltnS => Gn H hallH nsHG.
have [sHG nHG] := andP nsHG.
case: (trivgVpdiv H) => [H1 | [p pr_p pH]].
  by apply/splitsP; exists G; rewrite inE H1 -subG1 subsetIl mul1g eqxx.
have [P sylP] := Sylow_exists p H.
case nPG: (P <| G); last first.
  pose N := ('N_G(P))%G.
  have sNG: N \subset G by rewrite subsetIl.
  have eqHN_G: H * N = G by exact: Frattini_arg sylP.
  pose H' := (H :&: N)%G.
  have nH'N: H' <| N.
    rewrite /(_ <| N) subsetIr; apply/subsetP=> x Nx.
    rewrite inE; apply/subsetP=> y; rewrite conjIg (conjGid Nx) (normP _) //.
    by apply: (subsetP nHG); case/setIP: Nx.
  have eq_iH: #|G : H| = #|N| %/ #|H'|.
    rewrite -divgS // -(divn_pmul2l (cardG_gt0 H')) mulnC -eqHN_G.
    by rewrite -mul_cardG (mulnC #|H'|) divn_pmul2l // cardG_gt0.
    have hallH': Hall N H'.
    have sH'H: H' \subset H by exact: subsetIl.
    case/andP: hallH => _; rewrite eq_iH -(LaGrange sH'H) coprime_mull.
    by rewrite /Hall divgS subsetIr //; case/andP.
  have: [splits N, over H'].
    apply: IHn hallH' nH'N; apply: {n}leq_trans Gn.
    rewrite ltn_neqAle subset_leq_card // andbT; apply/eqP=> eqNG.
    case/andP: nPG; rewrite (subset_trans _ sHG); last by case/andP: sylP.
    suff <-: N :=: G by rewrite subsetIr.
    by apply/setP; exact/subset_cardP.
  case/splitsP=> K; case/complP=> trKN eqH'K.
  have sKN: K \subset N by rewrite -(mul1g K) -eqH'K mulSg ?sub1set.
  apply/splitsP; exists K; rewrite inE -subG1; apply/andP; split.
    apply/subsetP=> x; case/setIP=> Hx Kx.
    by rewrite -trKN 2!inE Hx (subsetP sKN) Kx.
  rewrite eqEsubset -eqHN_G mulgS // -eqH'K mulgA mulSg //.
  by rewrite mul_subG ?subsetIl.
pose Z := ('Z(P))%G; have iZ: 'Z(P) = Z by [].
have sZP: Z \subset P by exact: center_sub.
have sZH: Z \subset H by case/andP: sylP; move/(subset_trans sZP).
have sZG: Z \subset G by exact: subset_trans sHG.
have nZG: Z <| G by apply: char_normal_trans nPG; exact: center_char.
have nZH: Z <| H by exact: normalS nZG.
pose Gbar := (G / Z)%G; have iGbar: G / Z = Gbar by [].
pose Hbar := (H / Z)%G; have iHbar: H / Z = Hbar by [].
have nHGbar: Hbar <| Gbar by exact: morphim_normal.
have hallHbar: Hall Gbar Hbar.
  by apply: morphim_Hall; first case/andP: nZH.
have: [splits Gbar, over Hbar].
  apply: IHn => //; apply: {n}leq_trans Gn.
  rewrite card_quotient; last by case/andP: nZG.
  rewrite -(divgS sZG) ltn_Pdiv ?cardG_gt0 // ltnNge -trivg_card_le1.
  apply/eqP; move/(trivg_center_pgroup (pHall_pgroup sylP)); move/eqP.
  rewrite trivg_card1 (card_Hall sylP) p_part -(expn0 p).
  by rewrite eqn_exp2l ?prime_gt1 // lognE pH pr_p cardG_gt0.
case/splitsP=> Kbar; case/complP=> trHKbar eqHKbar.
have: Kbar \subset Gbar by rewrite -eqHKbar mulG_subr.
case/inv_quotientS=> //= ZK quoZK sZZK sZKG.
have nZZK: Z <| ZK by exact: normalS nZG.
have cardZK: #|ZK| = (#|Z| * #|G : H|)%N.
  rewrite -(LaGrange sZZK); congr (_ * _)%N.
  rewrite -card_quotient -?quoZK; last by case/andP: nZZK.
  rewrite -(divgS sHG) -(LaGrange sZG) -(LaGrange sZH) divn_pmul2l //.
  rewrite -!card_quotient; try by [case/andP: nZG | case/andP: nZH].
  by rewrite iGbar -eqHKbar (TI_cardMg trHKbar) mulKn.
have: [splits ZK, over Z].
  case: (Gaschutz nZZK _ sZZK) => // [||-> _].
  - apply: subset_trans (centS sZP); exact: subsetIr.
  - rewrite -divgS // cardZK mulKn //.
    by case/andP: hallH=> _; rewrite -(LaGrange sZH) coprime_mull; case/andP.
  by apply/splitsP; exists [1 gT]%G; rewrite inE -subG1 subsetIr mulg1 eqxx.
case/splitsP=> K; case/complP=> trZK eqZK.
have sKZK: K \subset ZK by rewrite -(mul1g K) -eqZK mulSg ?sub1set.
have trHK: H :&: K = 1.
  apply/trivgP; apply/subsetP=> x; case/setIP=> Hx Kx; rewrite -trZK.
  have Nx: x \in 'N(Z) by apply: subsetP (x) Hx; case/andP: nZH.
  rewrite inE Kx andbT coset_idr //; apply/set1gP.
  rewrite -trHKbar quoZK inE !mem_imset // inE Nx //; exact: (subsetP sKZK).
apply/splitsP; exists K; rewrite inE trHK ?eqEcard subxx leqnn /=.
rewrite mul_subG ?(subset_trans sKZK) //= TI_cardMg // -(@mulKn #|K| #|Z|) //.
by rewrite -TI_cardMg // eqZK cardZK mulKn // LaGrange.
Qed.

Module SchurZassCP1. End SchurZassCP1.

Theorem SchurZass_trans_sol : forall (gT : finGroupType) (H K K1 : {group gT}),
    solvable H -> K \subset 'N(H) -> K1 \subset H * K ->
    coprime #|H| #|K| -> #|K1| = #|K| ->
  exists2 x, x \in H & K1 :=: K :^ x.
Proof.
move=> gT H; move: {2}_.+1 (ltnSn #|H|) => n; elim: n => // n IHn in gT H *.
rewrite ltnS => leHn K K1 solH nHK; case: (eqsVneq H 1) => [H1 |].
  rewrite H1 mul1g => sK1K _ eqK1K.
  exists (1 : gT); first exact: set11.
  by apply/eqP; rewrite conjsg1 eqEcard sK1K eqK1K /=.
pose G := (H <*> K)%G.
have defG: G :=: H * K by rewrite -normC // -norm_mulgenEl // mulgenC.
have sHG: H \subset G by rewrite -gen_subG genS // subsetUl.
have sKG: K \subset G by rewrite -gen_subG genS // subsetUr.
have nHG: H <| G by rewrite /(H <| G) sHG gen_subG subUset nHK normG.
case/(solvable_norm_abelem solH nHG)=> M [sMH nMG ntM].
case/andP=> abelM _; rewrite -defG => sK1G coHK oK1K.
have nMsG: forall L : {set gT}, L \subset G -> L \subset 'N(M).
  by move=> L; move/subset_trans; apply; case/andP: nMG.
have [coKM coHMK]: coprime #|M| #|K| /\ coprime #|H / M| #|K|.
  by apply/andP; rewrite -coprime_mull card_quotient ?nMsG ?LaGrange.
have oKM: forall K' : {group gT},
  K' \subset G -> #|K'| = #|K| -> #|K' / M| = #|K|.
- move=> K' sK'G oK'.
  rewrite -quotient_mulg -?norm_mulgenEl ?card_quotient ?nMsG //; last first.
    by rewrite gen_subG subUset sK'G; case/andP: nMG.
  rewrite -divgS /=; last by rewrite -gen_subG genS ?subsetUr.
  rewrite norm_mulgenEl ?nMsG // coprime_cardMg ?mulnK //.
  by rewrite oK' coprime_sym.
have [xb]: exists2 xb, xb \in H / M & K1 / M = (K / M) :^ xb.
  apply: IHn; try by rewrite (quotient_sol, morphim_norms, oKM K) ?(oKM K1).
    apply: leq_trans leHn; rewrite card_quotient ?nMsG //.
    rewrite -(ltn_pmul2l (cardG_gt0 M)) LaGrange // -{1}(mul1n #|H|).
    by rewrite ltnNge leq_pmul2r // -trivg_card_le1.
  by rewrite -morphimMl ?nMsG // -defG morphimS.
case/morphimP=> x nMx Hx ->{xb} eqK1Kx; pose K2 := (K :^ x)%G.
have{eqK1Kx} eqK12: K1 / M = K2 / M by rewrite quotientJ.
suff [y My ->]: exists2 y, y \in M & K1 :=: K2 :^ y.
  exists (x * y); first by rewrite groupMl // (subsetP sMH).
  by rewrite conjsgM.
have nMK1: K1 \subset 'N(M) by case/andP: nMG => _; exact: subset_trans.
have defMK: M * K1 = M <*> K1 by rewrite -normC // -norm_mulgenEl // mulgenC.
have sMKM: M \subset M <*> K1 by rewrite -defMK mulG_subl.
have nMKM: M <| M <*> K1 by rewrite /(_ <| _) sMKM gen_subG subUset normG.
have trMK1: M :&: K1 = 1 by rewrite coprime_TIg ?oK1K.
have trMK2: M :&: K2 = 1 by rewrite coprime_TIg ?cardJg ?oK1K.
case: (Gaschutz nMKM _ sMKM) => //= [|_].
  by rewrite -divgS //= -defMK coprime_cardMg oK1K // mulKn.
apply; first 1 last; first by rewrite inE defMK trMK1 ?eqxx /=.
  by rewrite -!(setIC M) trMK1.
rewrite inE trMK2 eqxx eq_sym eqEcard /= -defMK andbC.
rewrite !coprime_cardMg ?cardJg ?oK1K // leqnn.
rewrite -{2}(mulGid M) -mulgA mulgS //.
by move/eqP: eqK12; rewrite eqEsubset morphimSK // ker_coset; case/andP.
Qed.


Require Import Thread0 Echo3 Bootstrap.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := (heapSize + 50) * 4.
  Definition globalSock : W := globalSched ^+ $4.
End M'.

Import M'.

Module E := Echo3.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 2.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 2.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSock =?> 1 * globalSched =?> 1 * mallocHeap 0];;

        Goto "test"!"main"
      end
    }}.

  Ltac t := unfold globalSched, localsInvariantMain, M'.globalSock, M'.globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract (unfold globalSched, localsInvariantMain, M'.globalSock, M'.globalSched; genesis).
  Qed.

  Definition m1 := link boot E.T.m.
  Definition m := link E.m m1.

  Lemma ok1 : moduleOk m1.
    link ok0 E.T.ok.
  Qed.

  Theorem ok : moduleOk m.
    link E.ok ok1.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $(size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


(* MLTT Lifting and substitution *)

From Coq Require Import Utf8 List Nat Lia.
Require Import Util TAst.

Import ListNotations.

Declare Scope t_scope.
Delimit Scope t_scope with t.

Fixpoint lift n k t : term :=
  match t with
  | var i => var (if Nat.leb k i then (n + i) else i)
  | lam A t => lam (lift n k A) (lift n (S k) t)
  | app u v => app (lift n k u) (lift n k v)
  | Prod A B => Prod (lift n k A) (lift n (S k) B)
  | zero => zero
  | succ t => succ (lift n k t)
  | elim_nat P z s t =>
    elim_nat (lift n k P) (lift n k z) (lift n k s) (lift n k t)
  | Nat => Nat
  | lnil A => lnil (lift n k A)
  | lcons A a l => lcons (lift n k A) (lift n k a) (lift n k l)
  | elim_list A P e c l =>
    elim_list (lift n k A) (lift n k P)
              (lift n k e) (lift n k c) (lift n k l)
  | List A => List (lift n k A)
  | refl A u => refl (lift n k A) (lift n k u)
  | coe A P u v e t =>
    coe
      (lift n k A) (lift n k P)
      (lift n k u) (lift n k v) (lift n k e)
      (lift n k t)
  | Eq A u v => Eq (lift n k A) (lift n k u) (lift n k v)
  | exfalso A p => exfalso (lift n k A) (lift n k p)
  | Empty => Empty
  | axiom n => axiom n
  | univ s => univ s
  end.

Notation lift0 n := (lift n 0).

Fixpoint subst s k u :=
  match u with
  | var n =>
    if Nat.leb k n then
      match nth_error s (n - k) with
      | Some b => lift0 k b
      | None => var (n - List.length s)
      end
    else var n
  | lam A t => lam (subst s k A) (subst s (S k) t)
  | app u v => app (subst s k u) (subst s k v)
  | Prod A B => Prod (subst s k A) (subst s (S k) B)
  | zero => zero
  | succ t => succ (subst s k t)
  | elim_nat P z sc t =>
    elim_nat (subst s k P) (subst s k z) (subst s k sc) (subst s k t)
  | Nat => Nat
  | lnil A => lnil (subst s k A)
  | lcons A a l => lcons (subst s k A) (subst s k a) (subst s k l)
  | elim_list A P e c l =>
    elim_list (subst s k A) (subst s k P)
              (subst s k e) (subst s k c) (subst s k l)
  | List A => List (subst s k A)
  | refl A u => refl (subst s k A) (subst s k u)
  | coe A P u v e t =>
    coe
      (subst s k A) (subst s k P)
      (subst s k u) (subst s k v) (subst s k e)
      (subst s k t)
  | Eq A u v => Eq (subst s k A) (subst s k u) (subst s k v)
  | exfalso A p => exfalso (subst s k A) (subst s k p)
  | Empty => Empty
  | axiom n => axiom n
  | univ s => univ s
  end.

(** Substitutes [t1 ; .. ; tn] in u for [Rel 0; .. Rel (n-1)] *in parallel* *)
Notation subst0 t := (subst t 0).
Definition subst1 t k u := subst [t] k u.
Notation subst10 t := (subst1 t 0).
Notation "M { j := N }" :=
  (subst1 N j M) (at level 10, right associativity) : t_scope.

Lemma subst_empty :
  ∀ k u,
    subst [] k u = u.
Proof.
  intros k u.
  induction u in k |- *.
  all: try solve [
    cbn ;
    rewrite ?IHu, ?IHu1, ?IHu2, ?IHu3, ?IHu4, ?IHu5, ?IHu6 ;
    reflexivity
  ].
  cbn. destruct (k <=? n).
  - rewrite nth_error_nil. f_equal. lia.
  - reflexivity.
Qed.

Lemma lift_0 :
  ∀ k t, lift 0 k t = t.
Proof.
  intros k t.
  induction t in k |- *.
  all: try reflexivity.
  all: try solve [ cbn ; f_equal ; intuition eauto ].
  cbn. destruct (k <=? n). all: reflexivity.
Qed.

Lemma lift_lift :
  ∀ k n m t,
    lift n k (lift m k t) = lift (n + m) k t.
Proof.
  intros k p m t.
  induction t in k, p, m |- *.
  all: try reflexivity.
  all: try solve [ cbn ; f_equal ; intuition eauto ].
  cbn. destruct (k <=? n) eqn:e.
  - destruct (k <=? m + n) eqn:e'.
    2:{
      eapply Compare_dec.leb_complete in e.
      eapply Compare_dec.leb_complete_conv in e'.
      lia.
    }
    f_equal. lia.
  - rewrite e. reflexivity.
Qed.


(*******************************************************************

 The comprehension bicategory of fibrations

 Contents
 1. The comprehension pseudofunctor
 2. Preservation of cartesian 1-cells
 3. Preservation of cartesian 2-cells
 4. The comprehension bicategory

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.FibrationCleaving.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.
Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Logic.ComprehensionBicat.

Local Open Scope cat.

(**
 1. The comprehension pseudofunctor
 *)
Definition cleaving_comprehension_data
  : disp_psfunctor_data
      disp_bicat_of_cleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats).
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _).
  - exact (λ C D, total_univalent_category (pr1 D) ,, pr1_category _).
  - intros C₁ C₂ F D₁ D₂ FF.
    use make_disp_1cell_cod.
    + exact (total_functor (pr1 FF)).
    + use nat_z_iso_to_invertible_2cell.
      exact (total_functor_commute_z_iso (pr1 FF)).
  - intros C₁ C₂ F G α D₁ D₂ FF GG αα.
    use make_disp_2cell_cod.
    + exact (total_nat_trans (pr1 αα)).
    + abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite id_left, id_right ;
         apply idpath).
  - intros C D.
    simple refine (_ ,, _).
    + use make_disp_2cell_cod.
      * exact (total_functor_identity (pr11 D)).
      * abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intros x ;
           cbn ;
           rewrite !id_left ;
           apply idpath).
    + use is_disp_invertible_2cell_cod.
      use is_nat_z_iso_to_is_invertible_2cell.
      intro x.
      apply identity_is_z_iso.
  - intros C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG.
    simple refine (_ ,, _).
    + use make_disp_2cell_cod.
      * exact (total_functor_comp (pr1 FF) (pr1 GG)).
      * abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intros x ;
           cbn ;
           rewrite !id_left, !id_right ;
           apply functor_id).
    + use is_disp_invertible_2cell_cod.
      use is_nat_z_iso_to_is_invertible_2cell.
      intro x.
      apply identity_is_z_iso.
Defined.

Definition cleaving_comprehension_is_disp_psfunctor
  : is_disp_psfunctor
      disp_bicat_of_cleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats)
      cleaving_comprehension_data.
Proof.
  repeat split ; intro ; intros ;
    (use subtypePath ; [ intro ; apply cellset_property | ]).
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    apply idpath.
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    apply idpath.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite functor_id, !id_right ;
         apply idpath).
    + rewrite !id_right_disp.
      rewrite disp_functor_id.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right ;
         apply idpath).
    + rewrite !id_right_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_lassociator _ _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite functor_id, !id_right ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      rewrite disp_functor_id.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_lwhisker _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right, !id_left ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_rwhisker _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right, !id_left ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
Qed.

Definition cleaving_comprehension
  : disp_psfunctor
      disp_bicat_of_cleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats).
Proof.
  simple refine (_ ,, _).
  - exact cleaving_comprehension_data.
  - exact cleaving_comprehension_is_disp_psfunctor.
Defined.

(**
 2. Preservation of cartesian 1-cells
 *)
Definition global_cartesian_cleaving_comprehension
  : global_cartesian_disp_psfunctor cleaving_comprehension.
Proof.
  use preserves_global_lifts_to_cartesian.
  - exact univalent_cat_is_univalent_2.
  - exact (cod_disp_univalent_2 _ univalent_cat_is_univalent_2).
  - exact cleaving_of_cleaving_global_cleaving.
  - intros C₁ C₂ F D₁.
    use is_pb_to_cartesian_1cell.
    apply reindexing_has_pb_ump.
    apply is_isofibration_from_is_fibration.
    exact (pr2 D₁).
Defined.

(**
 3. Preservation of cartesian 2-cells
 *)
Section LocalCartesianFibration.
  Context {C₁ C₂ : bicat_of_univ_cats}
          {F₁ F₂ : C₁ --> C₂}
          (α : F₁ ==> F₂)
          {D₁ : disp_bicat_of_cleaving C₁}
          {D₂ : disp_bicat_of_cleaving C₂}
          {FF₁ : D₁ -->[ F₁ ] D₂}
          {FF₂ : D₁ -->[ F₂ ] D₂}
          (αα : disp_2cells α FF₁ FF₂)
          (Hαα : ∏ (x : C₁ : univalent_category)
                   (xx : (pr1 D₁ : disp_univalent_category _) x),
                 is_cartesian ((pr11 αα) x xx))
          (G : bicat_of_univ_cats
                 ⟦ total_univalent_category (pr1 D₁)
                   ,
                   total_univalent_category (pr1 D₂) ⟧)
          (γ : G ==> total_functor (pr1 FF₂))
          (δp : (G ∙ pr1_category (pr11 D₂) : bicat_of_univ_cats ⟦ _ , _ ⟧)
                ==>
                total_functor (pr1 FF₁) ∙ pr1_category (pr11 D₂))
          (q : post_whisker γ (pr1_category (pr11 D₂))
               =
               nat_trans_comp
                 _ _ _
                 δp
                 (post_whisker (total_nat_trans (pr1 αα)) (pr1_category _))).

  Definition local_cartesian_cleaving_lift_data
    : nat_trans_data
        (pr1 G)
        (total_functor (pr1 FF₁)).
  Proof.
    refine (λ x, pr1 δp x ,, _) ; cbn.
    refine (cartesian_factorisation (Hαα (pr1 x) (pr2 x)) _ _).
    exact (transportf
             (λ z, _ -->[ z ] _)
             (nat_trans_eq_pointwise q x)
             (pr2 (pr1 γ x))).
  Defined.

  Definition local_cartesian_cleaving_lift_is_nat_trans
    : is_nat_trans _ _ local_cartesian_cleaving_lift_data.
  Proof.
    intros x y f ; cbn.
    use total2_paths_f.
    - exact (nat_trans_ax δp x y f).
    - use (cartesian_factorisation_unique (Hαα (pr1 y) (pr2 y))).
      cbn.
      rewrite assoc_disp_var.
      rewrite mor_disp_transportf_postwhisker.
      rewrite assoc_disp_var.
      rewrite transport_f_f.
      rewrite cartesian_factorisation_commutes.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpaths.
        apply disp_nat_trans_ax.
      }
      unfold transportb.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      rewrite assoc_disp.
      rewrite cartesian_factorisation_commutes.
      unfold transportb.
      rewrite mor_disp_transportf_postwhisker.
      rewrite !transport_f_f.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        exact (fiber_paths (nat_trans_ax γ _ _ f)).
      }
      rewrite transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  Qed.

  Definition local_cartesian_cleaving_lift
    : G ==> total_functor (pr1 FF₁).
  Proof.
    use make_nat_trans.
    - exact local_cartesian_cleaving_lift_data.
    - exact local_cartesian_cleaving_lift_is_nat_trans.
  Defined.

  Definition local_cartesian_cleaving_lift_over
    : local_cartesian_cleaving_lift ▹ _ = δp.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    apply idpath.
  Qed.

  Definition local_cartesian_cleaving_lift_comm
    : local_cartesian_cleaving_lift • total_nat_trans (pr1 αα)
      =
      γ.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    cbn.
    use total2_paths_f.
    - exact (!(nat_trans_eq_pointwise q x)).
    - cbn.
      rewrite cartesian_factorisation_commutes.
      rewrite transport_f_f.
      apply transportf_set.
      apply homset_property.
  Qed.

  Definition local_cartesian_cleaving_lift_unique
    : isaprop
        (∑ δ,
         δ ▹ _ = δp
         ×
         δ • total_nat_trans (pr1 αα) = γ).
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      apply isapropdirprod ; apply cellset_property.
    }
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use total2_paths_f.
    - exact (nat_trans_eq_pointwise (pr12 φ₁) x
             @ !(nat_trans_eq_pointwise (pr12 φ₂) x)).
    - use (cartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))).
      rewrite mor_disp_transportf_postwhisker.
      etrans.
      {
        apply maponpaths.
        exact (transportb_transpose_right
                 (fiber_paths (nat_trans_eq_pointwise (pr22 φ₁) x))).
      }
      refine (!_).
      etrans.
      {
        exact (transportb_transpose_right
                 (fiber_paths (nat_trans_eq_pointwise (pr22 φ₂) x))).
      }
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  Qed.
End LocalCartesianFibration.

Definition local_cartesian_cleaving_comprehension
  : local_cartesian_disp_psfunctor cleaving_comprehension.
Proof.
  intros C₁ C₂ F₁ F₂ α D₁ D₂ FF₁ FF₂ αα Hαα.
  apply is_cartesian_2cell_sfib_to_is_cartesian_2cell ; cbn.
  pose (cleaving_of_cleaving_cartesian_2cell_is_pointwise_cartesian _ Hαα) as p.
  intros G γ δp q.
  use iscontraprop1.
  - exact (local_cartesian_cleaving_lift_unique α αα p G γ δp).
  - simple refine (_ ,, _ ,, _).
    + exact (local_cartesian_cleaving_lift α αα p G γ δp q).
    + exact (local_cartesian_cleaving_lift_over α αα p G γ δp q).
    + exact (local_cartesian_cleaving_lift_comm α αα p G γ δp q).
Defined.

(**
 4. The comprehension bicategory
 *)
Definition cleaving_comprehension_bicat_structure
  : comprehension_bicat_structure bicat_of_univ_cats.
Proof.
  use make_comprehension_bicat_structure.
  - exact disp_bicat_of_cleaving.
  - exact cleaving_comprehension.
  - exact cleaving_of_cleaving_global_cleaving.
  - exact global_cartesian_cleaving_comprehension.
Defined.

Definition cleaving_comprehension_is_contravariant
  : is_contravariant cleaving_comprehension_bicat_structure.
Proof.
  repeat split.
  - exact cleaving_of_cleaving_local_cleaving.
  - exact cleaving_of_cleaving_lwhisker_cartesian.
  - exact cleaving_of_cleaving_rwhisker_cartesian.
  - exact local_cartesian_cleaving_comprehension.
Defined.

Definition cleaving_contravariant_comprehension_bicat
  : contravariant_comprehension_bicat
  := _ ,, _ ,, cleaving_comprehension_is_contravariant.


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 H K O L Hprime Kprime Oprime Lprime Kprimeprime Lprimeprime I Iprime : Universe, ((wd_ Oprime Kprimeprime /\ (wd_ Oprime Kprime /\ (wd_ Oprime Lprimeprime /\ (wd_ Oprime Lprime /\ (wd_ O H /\ (wd_ O I /\ (wd_ Oprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ O K /\ (wd_ O L /\ (col_ Oprime Kprime Kprimeprime /\ (col_ Oprime Lprime Lprimeprime /\ (col_ Oprime Iprime Hprime /\ (col_ O I H /\ col_ Oprime Kprimeprime Lprimeprime)))))))))))))) -> col_ Kprime Oprime Lprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^230 - 27
Base: 23
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 23;
    bitwidth := 32;
    s := 2^230;
    c := [(1, 27)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* A token-asset exchange contract based on Dexter
   https://gitlab.com/camlcase-dev/dexter/-/blob/f4ef07ea672a1397b58c2134b3437bb5ef69bcaa/dexter-contracts-ligo/dexter.ligo *)
From Coq Require Import ZArith_base.
From Coq Require Import List. Import ListNotations.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Examples.EIP20 Require EIP20Token.

(* A liquidity exchange contract inspired by the Dexter contract.
   Allows for exchanging tokens to money, and allows the owner to add tokens to the
   reserve held by this contract. *)
Section Dexter.
  Context {BaseTypes : ChainBase}.
  Set Primitive Projections.
  Set Nonrecursive Elimination Schemes.
  Open Scope N_scope.

  Record exchange_param :=
    build_exchange_param {
      exchange_owner : Address;
      tokens_sold : N;
    }.

  Inductive Msg :=
    | tokens_to_asset : exchange_param -> Msg
    | add_to_tokens_reserve : Msg.

  Record Setup :=
    build_setup {
      token_caddr_ : Address;
      token_pool_ : N;
    }.

  Record State :=
    build_state {
      token_pool : N;
      price_history : list Amount;
      token_caddr : Address;
    }.

  Definition Error : Type := nat.
  Definition default_error : Error := 1%nat.

  MetaCoq Run (make_setters State).
  MetaCoq Run (make_setters Setup).

  Section Serialization.

    Global Instance exchange_paramserializable : Serializable exchange_param :=
      Derive Serializable exchange_param_rect <build_exchange_param>.

    Global Instance DexterMsg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <tokens_to_asset, add_to_tokens_reserve>.

    Global Instance setup_serializable : Serializable Setup :=
      Derive Serializable Setup_rect <build_setup>.

    Global Instance state_serializable : Serializable State :=
      Derive Serializable State_rect <build_state>.

  End Serialization.

  (* calculates exchange rate *)
  Open Scope Z_scope.
  Definition getInputPrice (tokens_to_be_sold : Amount)
                           (tokens_reserve : Amount)
                           (asset_reserve : Amount) :=
    Z.div (tokens_to_be_sold * 997 * asset_reserve)
          (tokens_reserve * 1000 + tokens_to_be_sold * 997).

  Definition begin_exchange_tokens_to_assets (dexter_asset_reserve : Amount)
                                             (caller : Address)
                                             (params : exchange_param)
                                             (dexter_caddr : Address)
                                             (state : State)
                                             : result (State * (list ActionBody)) Error :=
    do _ <- throwIf (address_neqb caller params.(exchange_owner)) default_error;
    let tokens_to_sell := Z.of_N params.(tokens_sold) in
    let tokens_price := getInputPrice tokens_to_sell (Z.of_N state.(token_pool)) dexter_asset_reserve in
    (* send out asset transfer to transfer owner, and send a token transfer message to the FA2 token *)
    let asset_transfer_msg := act_transfer params.(exchange_owner) tokens_price in
    let token_transfer_param :=
      EIP20Token.transfer_from params.(exchange_owner) dexter_caddr params.(tokens_sold) in
    let token_transfer_msg := act_call state.(token_caddr) 0%Z (@serialize EIP20Token.Msg _ (token_transfer_param)) in
    let new_state := state<|token_pool := N.add state.(token_pool) params.(tokens_sold)|>
                          <| price_history := state.(price_history) ++ [tokens_price]|> in
    Ok (new_state, [asset_transfer_msg; token_transfer_msg]).

  Open Scope Z_scope.
  Definition receive (chain : Chain)
                     (ctx : ContractCallContext)
                     (state : State)
                     (maybe_msg : option Msg)
                     : result (State * list ActionBody) Error :=
    let sender := ctx.(ctx_from) in
    let caddr := ctx.(ctx_contract_address) in
    let dexter_balance := ctx.(ctx_contract_balance) in
    match maybe_msg with
    | Some (tokens_to_asset params) =>
        begin_exchange_tokens_to_assets dexter_balance sender params caddr state
    (* Ignore any other type of call to this contract *)
    | _ => Ok (state, [])
    end.

  Definition init (chain : Chain)
                  (ctx : ContractCallContext)
                  (setup : Setup)
                  : result State Error :=
    Ok {|
      token_pool := setup.(token_pool_);
      token_caddr := setup.(token_caddr_);
      price_history := []
    |}.

  Definition contract : Contract Setup Msg State Error :=
    build_contract init receive.

End Dexter.


(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of
   the License, or (at your option) any later version.
*)

(* This file provides abstract syntax definitions for the IA32 (x86) 32-bit
 * instruction set architecture. *)
Require Export Coq.ZArith.ZArith.
Require Export Coq.Lists.List.

Require Export Bits.
Set Implicit Arguments.
Local Open Scope Z_scope.

(********************************************)
(* Type definitions for x86 abstract syntax *)
(********************************************)

Definition zero_extend n1 n2 (w:Word.int n1): Word.int n2 :=
  Word.repr (Word.unsigned w).
Definition sign_extend n1 n2 (w:Word.int n1): Word.int n2 :=
  Word.repr (Word.signed w).
Definition zero_extend8_32 := @zero_extend 7 31.
Definition sign_extend8_32 := @sign_extend 7 31.
Definition zero_extend16_32 := @zero_extend 15 31.
Definition sign_extend16_32 := @sign_extend 15 31.

Definition port_number := int8.
Definition interrupt_type := int8.
Definition selector := int16.

Inductive register : Set := EAX | ECX | EDX | EBX | ESP | EBP | ESI | EDI.
Definition register_eq_dec : forall (x y:register), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Definition Z_to_register(n:Z) :=
  match n with
    | 0 => EAX
    | 1 => ECX
    | 2 => EDX
    | 3 => EBX
    | 4 => ESP
    | 5 => EBP
    | 6 => ESI
    | _ => EDI
  end.

Inductive scale : Set := Scale1 | Scale2 | Scale4 | Scale8.
Definition scale_eq_dec : forall (x y:scale), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Definition Z_to_scale n := match n with
                            | 0 => Scale1
                            | 1 => Scale2
                            | 2 => Scale4
                            | _ => Scale8
                          end.

Inductive segment_register : Set := ES | CS | SS | DS | FS | GS.
Definition segment_register_eq_dec :
  forall (x y:segment_register), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Inductive control_register : Set := CR0 | CR2 | CR3 | CR4.
Definition control_register_eq_dec :
  forall (x y:control_register), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Inductive debug_register   : Set := DR0 | DR1 | DR2 | DR3 | DR6 | DR7.
Definition debug_register_eq_dec :
  forall (x y:debug_register), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Record address : Set := mkAddress {
  addrDisp : int32 ;
  addrBase : option register ;
  addrIndex : option (scale * register)
}.

Inductive operand : Set :=
| Imm_op : int32 -> operand
| Reg_op : register -> operand
| Address_op : address -> operand
| Offset_op : int32 -> operand.

Inductive reg_or_immed : Set :=
| Reg_ri : register -> reg_or_immed
| Imm_ri : int8 -> reg_or_immed.

Inductive condition_type : Set :=
| O_ct (* overflow *)
| NO_ct (* not overflow *)
| B_ct (* below, not above or equal *)
| NB_ct (* not below, above or equal *)
| E_ct (* equal, zero *)
| NE_ct (* not equal, not zero *)
| BE_ct (* below or equal, not above *)
| NBE_ct (* not below or equal, above *)
| S_ct (* sign *)
| NS_ct (* not sign *)
| P_ct (* parity, parity even *)
| NP_ct (* not parity, parity odd *)
| L_ct  (* less than, not greater than or equal to *)
| NL_ct (* not less than, greater than or equal to *)
| LE_ct (* less than or equal to, not greater than *)
| NLE_ct (* not less than or equal to, greater than *).

Definition condition_type_eq_dec :
  forall (x y:condition_type), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Definition Z_to_condition_type(n:Z) : condition_type :=
  match n with
    | 0 => O_ct
    | 1 => NO_ct
    | 2 => B_ct
    | 3 => NB_ct
    | 4 => E_ct
    | 5 => NE_ct
    | 6 => BE_ct
    | 7 => NBE_ct
    | 8 => S_ct
    | 9 => NS_ct
    | 10 => P_ct
    | 11 => NP_ct
    | 12 => L_ct
    | 13 => NL_ct
    | 14 => LE_ct
    | _ => NLE_ct
  end.

(* Floating point instruction syntax *)

Inductive fp_debug_register : Set := eMF | eDB | eBP | eUD | eNM | eDF | eSS | eGP | ePF | eAC | eMC.
Definition fp_debug_register_eq_dec :
  forall (x y: fp_debug_register), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Inductive fp_operand : Set :=
| FPS_op : int3 -> fp_operand 	    (*an index from 0 to 7 relative to stack top *)
| FPM16_op : address -> fp_operand
| FPM32_op : address -> fp_operand
| FPM64_op : address -> fp_operand
| FPM80_op : address -> fp_operand.

(* floating-point condition tpe *)
Inductive fp_condition_type : Set :=
| B_fct (* below *)
| E_fct (* equal *)
| BE_fct (* below or equal *)
| U_fct (* unordered *)
| NB_fct (* not below *)
| NE_fct (* not equal *)
| NBE_fct (* not below or equal *)
| NU_fct (* not unordered *).

Definition Z_to_fp_condition_type(n:Z) : fp_condition_type :=
  match n with
    | 0 => B_fct
    | 1 => E_fct
    | 2 => BE_fct
    | 3 => U_fct
    | 4 => NB_fct
    | 5 => NE_fct
    | 6 => NBE_fct
    | _ => NU_fct
  end.

(*MMX syntax *)

(* Eight 64-bit mmx registers; mmx registers are syntactically
   different from fpu registers, but are semantically mapped
   to the same set of eight 80-bit registers as FPU registers *)
Definition mmx_register := int3.

(* Definition Z_to_mmx_register (n:Z) :=  *)
(*   match n with  *)
(*     | 0 => MM0 *)
(*     | 1 => MM1 *)
(*     | 2 => MM2 *)
(*     | 3 => MM3 *)
(*     | 4 => MM4 *)
(*     | 5 => MM5 *)
(*     | 6 => MM6 *)
(*     | _ => MM7 *)
(*   end. *)

Inductive mmx_granularity : Set :=
| MMX_8                         (* 8 bits *)
| MMX_16                        (* 16 bits *)
| MMX_32                        (* 32 bits *)
| MMX_64.                       (* 64 bits *)

Inductive mmx_operand : Set :=
| GP_Reg_op : register -> mmx_operand
| MMX_Addr_op : address -> mmx_operand
| MMX_Reg_op : mmx_register -> mmx_operand
| MMX_Imm_op : int32 -> mmx_operand.

(*SSE syntax *)
(* 8 128-bit registers (XMM0 - XMM7) introduced, along with MXCSR word for status and control of these registers *)
Definition sse_register := int3.
Definition sse_register_eq_dec : forall (x y: sse_register), {x=y} + {x<>y}.
  intros. apply Word.eq_dec.
Defined.

(* Definition Z_to_sse_register (n:Z) :=  *)
(*   match n with  *)
(*     | 0 => XMM0 *)
(*     | 1 => XMM1 *)
(*     | 2 => XMM2 *)
(*     | 3 => XMM3 *)
(*     | 4 => XMM4 *)
(*     | 5 => XMM5 *)
(*     | 6 => XMM6 *)
(*     | _ => XMM7 *)
(*   end. *)

(*mmreg means mmx register. *)
Inductive mxcsr: Set := FZ | Rpos | Rneg | RZ | RN | PM | UM | OM | ZM | DM | IM | DAZ | PE | UE |
			 OE | ZE | DE | IE.

Definition mxcsr_eq_dec : forall (x y: mxcsr), {x=y} + {x<>y}.
  intros ; decide equality.
Defined.

Inductive sse_operand : Set :=
| SSE_XMM_Reg_op : sse_register -> sse_operand
| SSE_MM_Reg_op : mmx_register -> sse_operand
| SSE_Addr_op : address -> sse_operand
| SSE_GP_Reg_op : register -> sse_operand (*r32 in manual*)
| SSE_Imm_op : int32 -> sse_operand.

(* The list of all instructions *)

Inductive instr : Set :=
(* two parts:  1-byte opcode instructions, followed by 2-byte in alphabetical order,
   following Table B-13 *)
| AAA
| AAD
| AAM
| AAS
(* w is the width bit;
   with no operand override prefix,
     when w is true, then it's a 32-bit operation;
     when w is false, then it's a 8-bit operation;
   with an operand override prefix,
     when w is true, it's a 16-bit operation;
     when w is false, it's a 8-bit operation;
   See load_op/set-op in X86Semantics.v *)
| ADC   : forall (w:bool)(op1 op2:operand), instr
| ADD   : forall (w:bool)(op1 op2:operand), instr
| AND   : forall (w:bool)(op1 op2:operand), instr
| ARPL  : forall (op1 op2:operand), instr
| BOUND : forall (op1 op2:operand), instr
| BSF   : forall (op1 op2:operand), instr
| BSR   : forall (op1 op2:operand), instr
| BSWAP : forall (r:register), instr
| BT    : forall (op1 op2:operand), instr
| BTC   : forall (op1 op2:operand), instr
| BTR   : forall (op1 op2:operand), instr
| BTS   : forall (op1 op2:operand), instr
| CALL  : forall (near:bool)(absolute: bool)(op1:operand)(sel:option selector), instr
| CDQ
| CLC
| CLD
| CLI
| CLTS
| CMC
| CMOVcc : forall (ct:condition_type)(op1 op2: operand), instr
| CMP    : forall (w:bool)(op1 op2:operand), instr
| CMPS   : forall (w:bool), instr
| CMPXCHG: forall (w:bool)(op1 op2:operand), instr
| CPUID
| CWDE
| DAA
| DAS
| DEC   : forall (w:bool)(op1:operand), instr
| DIV   : forall (w:bool)(op1:operand), instr

(*Floating-point syntax defined starting here. Table B-38 explains how to read instructions and B-39 has the
actual instruction details. Instructions can be found here:
http://download.intel.com/products/processor/manual/325383.pdf*)
| F2XM1 : instr
| FABS : instr
(* zerod is true iff st(0) is the destination;
   op1 is the destination when zerod=false *)
| FADD : forall (zerod: bool) (op1: fp_operand), instr
| FADDP : forall (op1: fp_operand), instr
| FBLD : forall (op1: fp_operand), instr
| FBSTP : forall (op1: fp_operand), instr
| FCHS : instr
(* FCLEX is the same as FWAIT followed FNCLEX
   | FCLEX : instr *)
| FCMOVcc : forall (ct:fp_condition_type)(op1: fp_operand), instr
| FCOM : forall (op1: fp_operand), instr
| FCOMP : forall (op1: fp_operand), instr
| FCOMPP : instr
| FCOMIP : forall (op1: fp_operand), instr
| FCOS : instr
| FDECSTP : instr
| FDIV : forall (zerod: bool) (op: fp_operand), instr
| FDIVP : forall (op1: fp_operand), instr
| FDIVR : forall (zerod: bool) (op: fp_operand), instr
| FDIVRP : forall (op1: fp_operand), instr
| FFREE : forall (op1: fp_operand), instr
| FIADD : forall (op1: fp_operand), instr
| FICOM : forall (op1: fp_operand), instr
| FICOMP : forall (op1: fp_operand), instr
| FIDIV : forall (op1: fp_operand), instr
| FIDIVR : forall (op1: fp_operand), instr
| FILD : forall (op1: fp_operand), instr
| FIMUL : forall (op1: fp_operand), instr
| FINCSTP : instr
(* FINIT is FWAIT followed by FNINIT;
   | FINIT : instr *)
| FIST : forall (op1: fp_operand), instr
| FISTP : forall (op1: fp_operand), instr
| FISUB : forall (op1: fp_operand), instr
| FISUBR : forall (op1: fp_operand), instr
| FLD : forall (op1: fp_operand), instr
| FLD1 : instr
| FLDCW : forall (op1: fp_operand), instr
| FLDENV : forall (op1: fp_operand), instr
| FLDL2E : instr
| FLDL2T : instr
| FLDLG2 : instr
| FLDLN2 : instr
| FLDPI : instr
| FLDZ : instr
| FMUL : forall (zerod: bool) (op1: fp_operand), instr
| FMULP : forall (op1: fp_operand), instr
| FNCLEX : instr
| FNINIT : instr
| FNOP : instr
| FNSAVE : forall (op1: fp_operand), instr
| FNSTCW : forall (op1 : fp_operand), instr
(* FNSTSW None means that storing the status word to AX *)
| FNSTSW : forall (op1 : option fp_operand), instr
| FPATAN : instr
| FPREM : instr
| FPREM1 : instr
| FPTAN : instr
| FRNDINT : instr
| FRSTOR : forall (op1: fp_operand), instr
(* FSAVE's encoding the same as FWAIT followed FNSAVE
   | FSAVE : forall (op1: fp_operand), instr *)
| FSCALE : instr
| FSIN : instr
| FSINCOS : instr
| FSQRT : instr
| FST : forall (op1: fp_operand), instr

(* FSTCW's is the same as FWAIT followed by FNSTCW
   | FSTCW : forall (op1: fp_operand), instr *)

| FSTENV : forall (op1: fp_operand), instr
| FSTP : forall (op1: fp_operand), instr

(* FSTSW is the same as FWAIT followed by FNSTSW
   | FSTSW : forall (op1: option fp_operand), instr *)

(* st(0) <- st(0) - op, when zerod is true;
   op <- op - st(0), when zerod is false and op can only be st(i) *)
| FSUB : forall (zerod: bool) (op: fp_operand), instr
| FSUBP : forall (op1: fp_operand), instr
(* reverse subtraction
   st(0) <- op - st(0), when zerod is true;
   op <- st(0) - op, when zerod is false and op can only be st(i) *)
| FSUBR : forall (zerod: bool) (op: fp_operand), instr
| FSUBRP : forall (op1: fp_operand), instr
| FTST : instr
| FUCOM : forall (op1: fp_operand), instr
| FUCOMP : forall (op1: fp_operand), instr
| FUCOMPP : instr
| FUCOMI : forall (op1: fp_operand), instr
| FUCOMIP : forall (op1: fp_operand), instr
| FXAM : instr
| FXCH : forall (op1: fp_operand), instr
| FXTRACT : instr
| FYL2X : instr
| FYL2XP1 : instr
| FWAIT : instr
(*Floating-Point syntax ends here for now*)
(*MMX syntax starting here (from table B.5.3) *)
| EMMS : instr
| MOVD : forall (op1 op2: mmx_operand), instr
| MOVQ : forall (op1 op2: mmx_operand), instr
| PACKSSDW : forall (op1 op2: mmx_operand), instr
| PACKSSWB : forall (op1 op2: mmx_operand), instr
| PACKUSWB : forall (op1 op2: mmx_operand), instr
| PADD : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PADDS : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PADDUS : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PAND : forall  (op1 op2 : mmx_operand), instr
| PANDN : forall  (op1 op2 : mmx_operand), instr
| PCMPEQ : forall  (gg:mmx_granularity) (op1 op2 : mmx_operand), instr
| PCMPGT : forall  (gg:mmx_granularity) (op1 op2 : mmx_operand), instr
| PMADDWD : forall  (op1 op2 : mmx_operand), instr
| PMULHUW : forall  (op1 op2 : mmx_operand), instr
| PMULHW : forall  (op1 op2 : mmx_operand), instr
| PMULLW : forall  (op1 op2 : mmx_operand), instr
| POR : forall  (op1 op2 : mmx_operand), instr
| PSLL : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PSRA : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PSRL : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PSUB : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PSUBS : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PSUBUS : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PUNPCKH : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PUNPCKL : forall (gg:mmx_granularity) (op1 op2: mmx_operand), instr
| PXOR : forall  (op1 op2 : mmx_operand), instr
(*End of MMX syntax *)

(*SSE Syntax (Table B.8 in manual) *)
| ADDPS : forall (op1 op2: sse_operand), instr
| ADDSS : forall (op1 op2: sse_operand), instr
| ANDNPS : forall (op1 op2: sse_operand), instr
| ANDPS : forall (op1 op2: sse_operand), instr
| CMPPS : forall (op1 op2:sse_operand) (imm:int8), instr
| CMPSS : forall (op1 op2: sse_operand) (imm:int8), instr
| COMISS : forall (op1 op2: sse_operand), instr
| CVTPI2PS : forall (op1 op2: sse_operand), instr
| CVTPS2PI : forall (op1 op2: sse_operand), instr
| CVTSI2SS : forall (op1 op2: sse_operand), instr
| CVTSS2SI : forall (op1 op2: sse_operand), instr
| CVTTPS2PI : forall (op1 op2: sse_operand), instr
| CVTTSS2SI : forall (op1 op2: sse_operand), instr
| DIVPS : forall (op1 op2: sse_operand), instr
| DIVSS : forall (op1 op2: sse_operand), instr
| LDMXCSR : forall (op1: sse_operand), instr
| MAXPS : forall (op1 op2: sse_operand), instr
| MAXSS : forall (op1 op2: sse_operand), instr
| MINPS : forall (op1 op2: sse_operand), instr
| MINSS : forall (op1 op2: sse_operand), instr
| MOVAPS : forall (op1 op2: sse_operand), instr
| MOVHLPS : forall (op1 op2: sse_operand), instr
| MOVHPS : forall (op1 op2: sse_operand), instr
| MOVLHPS : forall (op1 op2: sse_operand), instr
| MOVLPS : forall (op1 op2: sse_operand), instr
| MOVMSKPS : forall (op1 op2: sse_operand), instr
| MOVSS : forall (op1 op2: sse_operand), instr
| MOVUPS : forall (op1 op2: sse_operand), instr
| MULPS : forall (op1 op2: sse_operand), instr
| MULSS : forall (op1 op2: sse_operand), instr
| ORPS : forall (op1 op2: sse_operand), instr
| RCPPS : forall (op1 op2: sse_operand), instr
| RCPSS : forall (op1 op2: sse_operand), instr
| RSQRTPS : forall (op1 op2: sse_operand), instr
| RSQRTSS : forall (op1 op2: sse_operand), instr
| SHUFPS : forall (op1 op2: sse_operand) (imm:int8), instr
| SQRTPS : forall (op1 op2: sse_operand), instr
| SQRTSS : forall (op1 op2: sse_operand), instr
| STMXCSR : forall (op1 : sse_operand), instr
| SUBPS : forall (op1 op2: sse_operand), instr
| SUBSS : forall (op1 op2: sse_operand), instr
| UCOMISS : forall (op1 op2: sse_operand), instr
| UNPCKHPS : forall (op1 op2: sse_operand), instr
| UNPCKLPS : forall (op1 op2: sse_operand), instr
| XORPS : forall (op1 op2: sse_operand), instr
| PAVGB : forall (op1 op2: sse_operand), instr
| PEXTRW : forall (op1 op2: sse_operand) (imm:int8), instr
| PINSRW : forall (op1 op2: sse_operand) (imm:int8), instr
| PMAXSW : forall (op1 op2: sse_operand), instr
| PMAXUB : forall (op1 op2: sse_operand), instr
| PMINSW : forall (op1 op2: sse_operand), instr
| PMINUB : forall (op1 op2: sse_operand), instr
| PMOVMSKB : forall (op1 op2: sse_operand), instr
(*| PMULHUW : forall (op1 op2: sse_operand), instr *)
| PSADBW : forall (op1 op2: sse_operand), instr
| PSHUFW : forall (op1 op2: sse_operand) (imm:int8), instr
| MASKMOVQ : forall (op1 op2: sse_operand), instr
| MOVNTPS : forall (op1 op2: sse_operand), instr
| MOVNTQ : forall (op1 op2: sse_operand), instr
| PREFETCHT0 : forall (op1: sse_operand), instr
| PREFETCHT1 : forall (op1: sse_operand), instr
| PREFETCHT2 : forall (op1: sse_operand), instr
| PREFETCHNTA : forall (op1: sse_operand), instr
| SFENCE: instr
(*end SSE, start SSE2 *)

(*End of SSE Syntax *)
| HLT
| IDIV  : forall (w:bool)(op1:operand), instr
(* This one is kind of funny -- there are three cases:
   one operand, two operand, and three operand. The one operand
   form is precise and implicitly uses EAX; the other two variants
   can potentially lose some data due to overflow. *)
| IMUL  : forall (w:bool)(op1:operand) (opopt: option operand) (iopt:option int32), instr
| IN    : forall (w:bool)(p: option port_number), instr
| INC   : forall (w:bool)(op1:operand), instr
| INS   : forall (w:bool), instr
| INTn  : forall (it:interrupt_type),instr
| INT   : instr
| INTO  : instr
| INVD  : instr
| INVLPG : forall (op1:operand), instr
| IRET   : instr
| Jcc   : forall (ct:condition_type)(disp:int32), instr
| JCXZ  : forall (b:int8), instr
| JMP   : forall (near:bool)(absolute:bool)(op1: operand)(sel:option selector), instr
| LAHF
| LAR   : forall (op1 op2:operand), instr
| LDS   : forall (op1 op2:operand), instr
| LEA   : forall (op1 op2:operand), instr
| LEAVE
| LES   : forall (op1 op2:operand), instr
| LFS   : forall (op1 op2:operand), instr
| LGDT  : forall (op1:operand), instr
| LGS   : forall (op1 op2:operand), instr
| LIDT  : forall (op1:operand), instr
| LLDT  : forall (op1:operand), instr
| LMSW  : forall (op1:operand), instr
| LODS  : forall (w:bool), instr
| LOOP  : forall (disp:int8), instr
| LOOPZ : forall (disp:int8), instr
| LOOPNZ: forall (disp:int8), instr
| LSL   : forall (op1 op2:operand), instr
| LSS   : forall (op1 op2:operand), instr
| LTR   : forall (op1:operand), instr
| MOV   : forall (w:bool)(op1 op2:operand), instr
(* Note:  when direction is true, we move the first operand to the second.
 * When the direction is false, we move the second operand to the first. *)
| MOVCR : forall (direction:bool)(cr:control_register)(r:register), instr
| MOVDR : forall (direction:bool)(dr:debug_register)(r:register), instr
| MOVSR : forall (direction:bool)(sr:segment_register)(op1:operand), instr
| MOVBE : forall (op1 op2:operand), instr
| MOVS  : forall (w:bool), instr
| MOVSX : forall (w:bool)(op1 op2:operand), instr
| MOVZX : forall (w:bool)(op1 op2:operand), instr
| MUL   : forall (w:bool)(op1:operand), instr
| NEG   : forall (w:bool)(op:operand), instr
| NOP   : forall (op:operand), instr
| NOT   : forall (w:bool)(op:operand), instr
| OR    : forall (w:bool)(op1 op2:operand), instr
| OUT   : forall (w:bool)(p:option port_number), instr
| OUTS  : forall (w:bool), instr
| POP   : forall (op1:operand), instr
| POPSR : forall (sr:segment_register), instr
| POPA
| POPF
| PUSH  : forall (w:bool)(op1:operand), instr
| PUSHSR: forall (sr:segment_register), instr
| PUSHA
| PUSHF
| RCL   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| RCR   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| RDMSR     : instr
| RDPMC     : instr
| RDTSC     : instr
| RDTSCP    : instr
| RET   : forall (same_segment:bool)(disp:option int16), instr
| ROL   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| ROR   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| RSM
| SAHF
| SAR   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| SBB   : forall (w:bool)(op1 op2:operand), instr
| SCAS  : forall (w:bool), instr
| SETcc : forall (ct:condition_type)(op1:operand), instr
| SGDT  : forall (op1:operand), instr
| SHL   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| SHLD  : forall (op1:operand)(r:register)(ri:reg_or_immed), instr
| SHR   : forall (w:bool)(op1:operand)(ri:reg_or_immed), instr
| SHRD  : forall (op1:operand)(r:register)(ri:reg_or_immed), instr
| SIDT  : forall (op1:operand), instr
| SLDT  : forall (op1:operand), instr
| SMSW  : forall (op1:operand), instr
| STC
| STD
| STI
| STOS  : forall (w:bool), instr
| STR   : forall (op1:operand), instr
| SUB   : forall (w:bool)(op1 op2:operand), instr
| TEST  : forall (w:bool)(op1 op2:operand), instr
| UD2
| VERR  : forall (op1:operand), instr
| VERW  : forall (op1:operand), instr
(* | WAIT  removed because it's the same as FWAIT*)
| WBINVD
| WRMSR
| XADD  : forall (w:bool)(op1 op2:operand), instr
| XCHG  : forall (w:bool)(op1 op2:operand), instr
| XLAT
| XOR   : forall (w:bool)(op1 op2:operand), instr.

Definition fp_lastInstrPtr_register := instr.

Definition fp_opcode_register := instr.

Inductive lock_or_rep : Set := lock | rep | repn.

Record prefix : Set := mkPrefix {
   lock_rep : option lock_or_rep;
   seg_override : option segment_register;
   op_override : bool;
   addr_override : bool
}.

(* To add:
B.4.  Streaming SIMD instructions
*)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^480 - 2^240 - 1
Base: 60
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 60;
    bitwidth := 64;
    s := 2^480;
    c := [(1, 1); (2^240, 1)];
    carry_chains := Some [[3; 7]; [4; 0; 5; 1; 6; 2; 7; 3]; [4; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.