From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype div ssralg finalg
  zmodp bigop tuple finfun binomial ssrint intdiv ssrnum.

From extructures Require Import ord.

Require Import hseq nominal.

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

(* Some of the Ssreflect constructions require 1 != 0 (e.g. the
zmodType structure). To go around this limitation while allowing for
the maximum flexibility, we add a type of non-zero natural numbers. *)

Structure non_zero : Type := NonZero {
  nat_of_non_zero :> nat;
  _ : nat_of_non_zero != 0
}.

Canonical non_zero_subType := [subType for nat_of_non_zero].
Definition non_zero_eqMixin := [eqMixin of non_zero by <:].
Canonical non_zero_eqType := Eval hnf in EqType non_zero non_zero_eqMixin.
Definition non_zero_choiceMixin := [choiceMixin of non_zero by <:].
Canonical non_zero_choiceType :=
  Eval hnf in ChoiceType non_zero non_zero_choiceMixin.
Definition non_zero_countMixin := [countMixin of non_zero by <:].
Canonical non_zero_countType :=
  Eval hnf in CountType non_zero non_zero_countMixin.
Canonical non_zero_subCountType :=
  Eval hnf in [subCountType of non_zero].
Definition non_zero_ordMixin := [ordMixin of non_zero by <:].
Canonical non_zero_ordType :=
  Eval hnf in OrdType non_zero non_zero_ordMixin.

Canonical non_zero_succn n := @NonZero n.+1 erefl.

Section Def.

Variable k : nat.

CoInductive word : predArgType := Word of 'I_(2 ^ k).

Definition ord_of_word (w : word) := let: Word i := w in i.

Coercion ord_of_word : word >-> ordinal.

Canonical word_subType := [newType for ord_of_word].
Definition word_eqMixin := [eqMixin of word by <:].
Canonical word_eqType := Eval hnf in EqType word word_eqMixin.
Definition word_choiceMixin := [choiceMixin of word by <:].
Canonical word_choiceType := Eval hnf in ChoiceType word word_choiceMixin.
Definition word_countMixin := [countMixin of word by <:].
Canonical word_countType := Eval hnf in CountType word word_countMixin.
Canonical word_subCountType := Eval hnf in [subCountType of word].
Definition word_finMixin := [finMixin of word by <:].
Canonical word_finType := Eval hnf in FinType word word_finMixin.
Canonical word_subFinType := Eval hnf in [subFinType of word].
Definition word_ordMixin := [ordMixin of word by <:].
Canonical word_ordType := Eval hnf in OrdType word word_ordMixin.
Canonical word_nominalType := Eval hnf in [nominalType for word by //].
Canonical word_trivialNominalType := Eval hnf in [trivialNominalType for word].

Lemma card_word : #|{: word}| = 2 ^ k.
Proof. by rewrite card_sub eq_cardT // -cardT card_ord. Qed.

Lemma exp2_gt0 : 0 < 2 ^ k.
Proof. by rewrite expn_gt0. Qed.

Definition as_word (n : int) :=
  Word (Ordinal (ltn_pmod `|modz n (2 ^ k)%N| exp2_gt0)).

Lemma as_wordK (n : nat) : n < 2 ^ k -> val (as_word n) = n :> nat.
Proof. by move=> ub; rewrite /= modz_nat absz_nat modn_mod modn_small //. Qed.

(* Signed conversion to integers *)
Definition int_of_word (w : word) : int :=
  if w < 2 ^ k.-1 then w : int
  else (w%:Z - (2 ^ k)%N%:Z)%R.

Definition addw (w1 w2 : word) := as_word (w1 + w2)%N.
Definition oppw (w : word) := as_word (2 ^ k - w)%N.
Definition mulw (w1 w2 : word) := as_word (w1 * w2)%N.
Definition subw (w1 w2 : word) := addw w1 (oppw w2).
Definition shlw (w1 w2 : word) := as_word (w1 * 2 ^ w2)%N.

Definition zerow := as_word 0.
Definition onew := as_word 1.
Definition monew := oppw onew.

Lemma onew_zero : (onew == zerow) = (k == 0).
Proof.
rewrite -!val_eqE /=; case: k => [|k'] //=.
rewrite expnS !modz_nat !absz_nat !mod0n modn_mod modn_small //.
by rewrite -{1}[2]/(2 * 2 ^ 0) leq_pmul2l // leq_exp2l.
Qed.

Lemma valwK (w : word) : as_word w = w.
Proof.
by do 2!apply: val_inj; rewrite /= modz_nat absz_nat modn_mod modn_small.
Qed.

Lemma int_of_wordK : cancel int_of_word as_word.
Proof.
rewrite /cancel /int_of_word /as_word => - [[w w_lt]] /=.
do 2! apply: val_inj => /=.
by case: ifP => _; last rewrite GRing.addrC -GRing.mulN1r modzMDl;
rewrite modz_nat absz_nat modn_mod modn_small.
Qed.

Lemma add0w : left_id zerow addw.
Proof. by move=> w; rewrite /addw /= !mod0z mod0n valwK. Qed.

Lemma addNw : left_inverse zerow oppw addw.
Proof.
move=> w; do 2!apply: val_inj.
by rewrite /= !modz_nat !absz_nat /= !modnDml subnK ?modnn ?mod0n // ltnW.
Qed.

Lemma addwA : associative addw.
Proof.
move=> x y z; do 2!apply: val_inj.
by rewrite /= !modz_nat !absz_nat /= !modn_mod !modnDml modnDmr addnA.
Qed.

Lemma addwC : commutative addw.
Proof. by move=> x y; do 2!apply: val_inj; rewrite /= addnC. Qed.

Definition word_zmodMixin := ZmodMixin addwA addwC add0w addNw.
Canonical word_zmodType := ZmodType word word_zmodMixin.
Canonical word_finZmodType := Eval hnf in [finZmodType of word].
Canonical word_baseFinGroupType :=
  Eval hnf in [baseFinGroupType of word for +%R].
Canonical word_finGroupType := Eval hnf in [finGroupType of word for +%R].

Lemma addw0 : right_id zerow addw. Proof. exact: GRing.addr0. Qed.
Lemma addwN : right_inverse zerow oppw addw. Proof. exact: GRing.addrN. Qed.

Lemma as_word_add : {morph as_word : n m / (n + m)%R >-> (n + m)%R}.
Proof.
have absz_pos: forall m : int, (0 <= m)%R -> `|m| = m :> int by case.
have modz_pos: forall n m : int, (0 < m)%R -> (0 <= (n %% m)%Z)%R.
  move=> n m; case: (intP m) => {m} [|m|m] //= _.
  by rewrite /modz Num.Theory.subr_ge0 lez_floor.
move=> n m /=; do 2!apply: val_inj => /=.
rewrite modz_nat modnDm.
set z1 := ((n + m) %% _)%Z.
set z2 := (`|_| + `|_|) %% _.
rewrite (_ : z1 = z2) // {}/z1 {}/z2 -modz_nat PoszD.
by rewrite !absz_pos ?modz_pos ?ltez_natE ?exp2_gt0 ?modzDm.
Qed.

Lemma valw_zero : zerow = 0 :> nat.
Proof. by rewrite /= modz_nat mod0n /= mod0n. Qed.

Lemma valw_add w1 w2 :
  addw w1 w2 =
  w1 + w2 - (2 ^ k <= w1 + w2) * 2 ^ k :> nat.
Proof.
case: w1 w2 => [[w1 hw1]] [[w2 hw2]] /=.
rewrite modz_nat absz_nat modn_mod.
case: (ltnP (w1 + w2) (2 ^ k)) => [ubould|lbound] //=.
  by rewrite mul0n subn0 modn_small.
apply: (can_inj (addnK (2 ^ k))).
rewrite mul1n subnK // addnC [in RHS](divn_eq (w1 + w2) (2 ^ k)).
congr addn; suff ->: (w1 + w2) %/ 2 ^ k = 1 by rewrite mul1n.
have ubound: w1 + w2 < 2 * 2 ^ k.
  rewrite mul2n -addnn; apply (@ltn_trans (w1 + w2).+1) => //.
  by rewrite -addnS -addSn; apply: leq_add.
move: {hw1 hw2 w1 w2}(w1 + w2) lbound ubound=> n lbound ubound.
rewrite -ltn_divLR ?ltnS ?exp2_gt0 // in ubound.
apply/eqP; rewrite eqn_leq {}ubound /=.
by rewrite -{1}[1]/(true : nat) -(exp2_gt0) -divnn leq_div2r.
Qed.

(* FIXME: Find a better name for this *)
Lemma valw_add' (w1 w2 : word) :
  w1 + w2 < 2 ^ k -> addw w1 w2 = w1 + w2 :> nat.
Proof. by rewrite valw_add ltnNge => /negbTE ->; rewrite subn0. Qed.

Lemma valw_sub (w1 w2 : word) :
  w2 <= w1 ->
  subw w1 w2 = (w1 - w2)%N :> nat.
Proof.
rewrite /= !modz_nat !absz_nat !modn_mod.
case: w1 w2 => [[w1 pw1]] [[w2 pw2]] /=.
have [->{w2 pw2} _|w2_neq_0] := altP (w2 =P 0).
  by rewrite !subn0 modnn addn0 modn_small.
rewrite (@modn_small (2 ^ k - _)); last first.
  by rewrite -[X in _ < X]subn0 ltn_sub2l ?lt0n // expn_eq0.
move=> w2_leq_w1; rewrite addnBA 1?ltnW // addnC -addnBA // modnDl.
by rewrite modn_small // (leq_ltn_trans _ pw1) // leq_subr.
Qed.

Lemma mul1w : left_id onew mulw.
Proof.
move=> w; do 2!apply: val_inj.
by rewrite /= /mulw !modz_nat !absz_nat !modn_mod modnMml mul1n modn_small.
Qed.

Lemma mulwC : commutative mulw.
Proof. by move=> w1 w2; rewrite /mulw mulnC. Qed.

Lemma mulw1 : right_id onew mulw.
Proof. by move=> w; rewrite mulwC mul1w. Qed.

Lemma mulwA : associative mulw.
Proof.
move=> w1 w2 w3; do 2!apply: val_inj.
by rewrite /= /mulw !modz_nat !absz_nat !modn_mod modnMml modnMmr mulnA.
Qed.

Lemma mulw_addr : right_distributive mulw addw.
Proof.
move=> w1 w2 w3; do 2!apply: val_inj.
by rewrite /= /mulw !modz_nat !absz_nat !modn_mod modnMmr modnDm mulnDr.
Qed.

Lemma mulw_addl : left_distributive mulw addw.
Proof.
by move=> w1 w2 w3; rewrite -!(mulwC w3) mulw_addr.
Qed.

Definition bits_of_word (w : word) :=
  locked [ffun i : 'I_k => odd (val w %/ 2 ^ i)].

Definition word_of_bits (bs : {ffun pred 'I_k}) :=
  as_word (\sum_(i < k) bs i * 2 ^ i)%N.

Lemma word_of_bitsK : cancel word_of_bits bits_of_word.
Proof.
have Hsum2 : forall N (f : pred 'I_N), \sum_(i < N) f i * 2 ^ i < 2 ^ N.
  move=> N f.
  rewrite -[2 ^ N]prednK ?expn_gt0 // predn_exp mul1n ltnS leq_sum // => i _.
  by case: (f i); rewrite // ?mul1n ?mul0n leqnn.
move=> bs; apply/ffunP=> - [i Hi].
rewrite /bits_of_word /word_of_bits -lock ffunE /= !modz_nat !absz_nat.
rewrite modn_mod modn_small; last first.
  by apply: Hsum2.
have Hl : k = i.+1 + (k - i.+1) by rewrite subnKC //.
rewrite {}Hl in bs Hi *.
rewrite big_split_ord big_ord_recr /=.
pose f i' := bs (rshift i.+1 i') * 2 ^ i' * 2 ^ i.+1.
rewrite [in X in _ + _ + X](eq_big_seq f); last first.
  by move=> i' _; rewrite /= expnD [in X in _ * X]mulnC mulnA.
rewrite -big_distrl /= expnS mulnA.
rewrite !divnDr ?mulnK ?dvdn_mull ?dvdnn ?expn_gt0 //.
rewrite divn_small; last by apply: Hsum2.
rewrite add0n odd_add odd_mul andbF addbF oddb.
by apply: f_equal; apply: val_inj.
Qed.

Lemma word_of_bits_inj : injective word_of_bits.
Proof. exact: can_inj word_of_bitsK. Qed.

Lemma bits_of_wordK : cancel bits_of_word word_of_bits.
Proof.
have Hbij : bijective word_of_bits.
  apply: inj_card_bij word_of_bits_inj _.
  by rewrite card_word card_ffun card_bool card_ord.
have [inv Hinv Hinv'] := Hbij.
move: (bij_can_eq Hbij word_of_bitsK Hinv) => H w.
by rewrite H Hinv'.
Qed.

Lemma bits_of_word_inj : injective bits_of_word.
Proof. exact: can_inj bits_of_wordK. Qed.

Definition negw w := word_of_bits [ffun i => ~~ bits_of_word w i].

Lemma negwK : involutive negw.
Proof.
move=> w; rewrite /negw word_of_bitsK.
by apply: (canLR bits_of_wordK); apply/ffunP=> i; rewrite !ffunE negbK.
Qed.

Lemma bits_zero : bits_of_word zerow = [ffun _ => false].
Proof.
apply: (canLR word_of_bitsK); do 2!apply: val_inj=> /=.
rewrite (eq_big_seq (fun i : 'I_k => 0)); last by move=> i; rewrite /= ffunE.
by rewrite sum_nat_const muln0.
Qed.

Lemma bits_one : bits_of_word onew = [ffun i : 'I_k => 0 == i].
Proof.
apply: (canLR word_of_bitsK); do 2!apply: val_inj=> /=.
case: k=> [|k']; first by rewrite big_ord0 expn0 modn1.
rewrite big_ord_recl (eq_big_seq (fun i : 'I_(k') => 0)).
  by rewrite sum_nat_const muln0 addn0 ffunE.
by move=> i _; rewrite /= ffunE.
Qed.

Lemma bits_mone : bits_of_word monew = [ffun _ => true].
Proof.
apply: (canLR word_of_bitsK).
rewrite -(GRing.add0r monew) /monew; apply: (canLR (GRing.subrK (oppw onew))).
rewrite GRing.opprK.
do 2!apply: val_inj=> /=.
rewrite !modz_nat !absz_nat !modn_mod.
rewrite (eq_big_seq (fun i : 'I_k => 2 ^ i)); last first.
  by move=> i _; rewrite /= ffunE mul1n.
have -> : (\sum_(i < k) 2 ^ i) = (2 ^ k).-1 by rewrite predn_exp /= mul1n.
rewrite [in _ + _]modn_small ?prednK ?expn_gt0 //.
have [->|Hn0] := altP (k =P 0); first by rewrite !expn0 /= modn1.
rewrite [in _ + _]modn_small -1?[in X in X < _](expn0 2) ?ltn_exp2l ?lt0n //.
by rewrite addn1 prednK ?expn_gt0 // modnn mod0n.
Qed.

Lemma negw_zero : negw zerow = monew.
Proof.
rewrite /negw; apply: (canLR bits_of_wordK).
rewrite bits_mone bits_zero.
by apply/ffunP=> i; rewrite !ffunE.
Qed.

Section Bitwise2.

Variable op : bool -> bool -> bool.

Definition bitwise2 w1 w2 :=
  word_of_bits [ffun i => op (bits_of_word w1 i) (bits_of_word w2 i)].

Lemma bitwise2C : commutative op -> commutative bitwise2.
Proof.
move=> opC w1 w2; congr word_of_bits; apply/ffunP=> i.
by rewrite 2!ffunE opC.
Qed.

Lemma bitwise2A : associative op -> associative bitwise2.
Proof.
move=> opA w1 w2 w3; congr word_of_bits; apply/ffunP=> i.
by rewrite /bitwise2 !word_of_bitsK !ffunE /= opA.
Qed.

Lemma idem_bitwise2 : idempotent op -> idempotent bitwise2.
Proof.
move=> opbb w; apply: bits_of_word_inj; apply/ffunP=> i.
by rewrite /bitwise2 /= word_of_bitsK ffunE opbb.
Qed.

Lemma id_bitwise2 b w :
  left_id b op ->
  bits_of_word w = [ffun=> b] ->
  left_id w bitwise2.
Proof.
move=> Hid /(canRL bits_of_wordK) -> {} w; rewrite /bitwise2 word_of_bitsK.
by apply: (canLR bits_of_wordK); apply/ffunP=> i; rewrite /= !ffunE Hid.
Qed.

End Bitwise2.

Definition andw := bitwise2 andb.
Definition orw := bitwise2 orb.
Definition xorw := bitwise2 addb.

Lemma andwC : commutative andw.
Proof. exact: bitwise2C andbC. Qed.

Lemma andwA : associative andw.
Proof. exact: bitwise2A andbA. Qed.

Lemma andww : idempotent andw.
Proof. exact: idem_bitwise2 andbb. Qed.

Lemma andN1w : left_id monew andw.
Proof. exact: id_bitwise2 andTb bits_mone. Qed.

Lemma andwN1 : right_id monew andw.
Proof. by move=> w; rewrite andwC andN1w. Qed.

Lemma orwC : commutative orw.
Proof. exact: bitwise2C orbC. Qed.

Lemma orwA : associative orw.
Proof. exact: bitwise2A orbA. Qed.

Lemma orww : idempotent orw.
Proof. exact: idem_bitwise2 orbb. Qed.

Lemma or0w : left_id zerow orw.
Proof. exact: id_bitwise2 orFb bits_zero. Qed.

Lemma orw0 : right_id zerow orw.
Proof. by move=> w; rewrite orwC or0w. Qed.

Lemma xorwC : commutative xorw.
Proof. exact: bitwise2C addbC. Qed.

Lemma xorwA : associative xorw.
Proof. exact: bitwise2A addbA. Qed.

Lemma xor0w : left_id zerow xorw.
Proof. exact: id_bitwise2 addFb bits_zero. Qed.

Lemma xorw0 : right_id zerow xorw.
Proof. by move=> w; rewrite xorwC xor0w. Qed.

Section Order.

Local Open Scope ord_scope.

Lemma leqw_mone w : w <= monew.
Proof.
case: w=> [] /=; do 3!rewrite /Ord.leq /=.
case: k=> [|k' n].
  by rewrite expn0=> n; rewrite ord1.
rewrite !modz_nat !absz_nat !modn_mod.
rewrite !modn_small; try by rewrite -{1}(expn1 2) leq_exp2l.
  have := (leq_sub2r 1 (valP n)); rewrite subn1 //=.
by rewrite subn1 prednK ?leqnn // expn_gt0.
Qed.

Lemma leqw_zero w : zerow <= w.
Proof.
do 3!rewrite /Ord.leq /=.
by rewrite !modz_nat !absz_nat !modn_mod mod0n.
Qed.

End Order.

End Def.

Arguments onew {_}.
Arguments zerow {_}.
Arguments monew {_}.
Arguments as_word {_} _.
Arguments addw {_} _ _.
Arguments subw {_} _ _.
Arguments mulw {_} _ _.
Arguments oppw {_} _.
Arguments shlw {_} _ _.
Arguments andw {_} _ _.
Arguments orw {_} _ _.
Arguments xorw {_} _ _.

Declare Scope word_scope.

Delimit Scope word_scope with w.
Notation "+%w" := addw.
Notation "-%w" := oppw.
Notation "x + y" := (addw x y) : word_scope.
Notation "x - y" := (subw x y) : word_scope.
Notation "x * y" := (mulw x y) : word_scope.
Notation "- x" := (oppw x) : word_scope.
Notation "0" := (zerow) : word_scope.
Notation "1" := (onew) : word_scope.

Section NonZero.

Variable k : non_zero.

Lemma onewN0 : 1%w != 0%w :> word k.
Proof. by rewrite onew_zero (valP k). Qed.

Definition word_ringMixin :=
  RingMixin (@mulwA k) (@mul1w k) (@mulw1 k)
            (@mulw_addl k) (@mulw_addr k) onewN0.

Canonical word_ringType :=
  Eval hnf in RingType (word k) word_ringMixin.

End NonZero.

Definition swcast {k k'} (w : word k) : word k' :=
  as_word (val w).

Section Splitting.

Section FixLength.

Variable ks : seq nat.

Definition wunpack (w : word (sumn ks)) : hseq word ks :=
  let word_of_tuple k (t' : k.-tuple bool) :=
      word_of_bits [ffun i : 'I_k => tnth t' (rev_ord i)] in
  let t := [tuple bits_of_word w (rev_ord i) | i < sumn ks] in
  hmap word_of_tuple (split_tuple t).

Definition wpack (ws : hseq word ks) : word (sumn ks) :=
  let tuple_of_word k w := [tuple bits_of_word w (rev_ord i) | i < k] in
  let t := merge_tuple (hmap tuple_of_word ws) in
  word_of_bits [ffun i => tnth t (rev_ord i)].

Lemma wpackK : cancel wpack wunpack.
Proof.
move=> ws; rewrite /wunpack /wpack /= word_of_bitsK /=.
set t := merge_tuple _; set t' := [tuple _ | i < sumn ks].
have ->: t' = t.
  rewrite {}/t'; apply: eq_from_tnth=> i.
  by rewrite tnth_map ffunE tnth_ord_tuple rev_ordK.
rewrite {}/t' {}/t merge_tupleK hmapK // => k w {ws}.
apply: (canLR (@bits_of_wordK k)); apply/ffunP => i; rewrite ffunE.
by rewrite tnth_map tnth_ord_tuple rev_ordK.
Qed.

Lemma wunpackK : cancel wunpack wpack.
Proof.
move=> w; rewrite /wunpack /wpack /= hmapK.
  apply: (canLR (@bits_of_wordK _)); apply/ffunP=> i; rewrite ffunE.
  by rewrite split_tupleK tnth_map tnth_ord_tuple rev_ordK.
move=> k w'; rewrite word_of_bitsK /=; apply/eq_from_tnth=> i.
by rewrite tnth_map tnth_ord_tuple ffunE rev_ordK.
Qed.

End FixLength.

Lemma wunpackS k ks (w : word (sumn (k :: ks))) :
  wunpack w = (as_word (w %/ 2 ^ sumn ks) :: wunpack (as_word w))%hseq.
Proof.
rewrite /wunpack /=.
set ff := [ffun i => tnth _ _].
pose pi (i : 'I_k) := rev_ord (lshift (sumn ks) (rev_ord i)).
have piE : forall i, val (pi i) = sumn ks + i.
  move=> i /=; rewrite subnSK // subnBA; last by rewrite ltnW.
  by rewrite -addnA addnC addnK.
pose ff' := [ffun i : 'I_k => bits_of_word w (pi i)].
have {ff} -> : ff = ff'.
  rewrite {}/ff {}/ff'; move: {w}(bits_of_word w)=> bs.
  apply/ffunP => i; rewrite /= !ffunE /=.
  rewrite tcastE (tnth_nth false) nth_take ?rev_ord_proof //.
  have kmi : k - i.+1 < k + sumn ks.
    rewrite (leq_trans (rev_ord_proof i)) //=; exact: leq_addr.
  rewrite (nth_map (pi i)); last by rewrite /= -cardT card_ord kmi.
  congr fun_of_fin; apply/val_inj.
  by rewrite /= -[k - i.+1]/(val (Ordinal kmi)) nth_enum_ord //=.
congr HSeqCons.
  apply/(canLR (@bits_of_wordK k))/ffunP => i /=; rewrite !ffunE.
  rewrite /bits_of_word -!lock !ffunE piE /= !modz_nat !absz_nat modn_mod.
  rewrite modn_small; last first.
    by rewrite ltn_divLR ?exp2_gt0 // -expnD.
  by rewrite (expnD _ _ i) divnMA.
congr hmap; congr split_tuple; apply/val_inj => /=.
have -> /= : forall p t, val (tcast p t) = val t.
  by move=> n m T p; move: (p); rewrite {}p => p; rewrite eq_axiomK.
rewrite -map_drop; apply/(@eq_from_nth _ false).
  by rewrite 2!size_map size_drop -!cardE !card_ord addnC addnK.
move=> i; rewrite size_map size_drop -cardE card_ord {1}addnC addnK=> hi.
rewrite -[i]/(val (Ordinal hi)); move: {i hi} (Ordinal hi) => i /=.
have nthE : forall n (i j : 'I_n), nth i (enum 'I_n) j = j.
  by move=> {i} n i j; apply/val_inj; rewrite /= nth_enum_ord.
rewrite (nth_map i); last by rewrite -cardE card_ord.
rewrite (nth_map (rshift k i)); last first.
  by rewrite size_drop -cardE card_ord addnC addnK.
rewrite nth_drop -[k + i]/(val (rshift k i)) !nthE.
rewrite /bits_of_word -!lock !ffunE /= !modz_nat !absz_nat modn_mod.
rewrite subnS subnDl -subnS.
rewrite {1}(divn_eq w (2 ^ sumn ks)) -[in X in _ %/ _ * X](subnK (valP i)) /=.
rewrite [in X in _ %/ _ * X]expnD -(mulnC (2 ^ i.+1)) mulnA.
by rewrite divnMDl ?exp2_gt0 // odd_add expnS !odd_mul !andbF.
Qed.

End Splitting.

Definition wcast k1 k2 (p : k1 = k2) (w : word k1) : word k2 :=
  eq_rect k1 word w k2 p.

Lemma wcast_id k (eq_kk : k = k) w : wcast eq_kk w = w.
Proof. by rewrite eq_axiomK. Qed.

Lemma wcastK k1 k2 (eq_k1k2 : k1 = k2) :
  cancel (wcast eq_k1k2) (wcast (esym eq_k1k2)).
Proof.
move: (eq_k1k2) (esym _); rewrite -{}eq_k1k2 {k2}=> eq_kk eq_kk'.
by rewrite !eq_axiomK.
Qed.

Lemma wcastKV k1 k2 (eq_k1k2 : k1 = k2) :
  cancel (wcast (esym eq_k1k2)) (wcast eq_k1k2).
Proof.
move: (eq_k1k2) (esym _); rewrite -{}eq_k1k2 {k2}=> eq_kk eq_kk'.
by rewrite !eq_axiomK.
Qed.

Lemma wcast_trans k1 k2 k3 (eq_k1k2 : k1 = k2) (eq_k2k3 : k2 = k3) :
  wcast (etrans eq_k1k2 eq_k2k3) =1 wcast eq_k2k3 \o wcast eq_k1k2.
Proof.
move: (eq_k1k2) (eq_k2k3) (etrans _ _); rewrite -{}eq_k2k3 -{}eq_k1k2 {k2 k3}.
by move=> ???; rewrite !eq_axiomK.
Qed.


Require Import Util Containers.OrderedTypeEx OrderedTypeComputable.
Require Import Setoid Coq.Classes.Morphisms Computable Coq.Classes.RelationClasses.

Definition _le X `{OrderedType X} (x y : X) := _lt x y \/ _eq x y.

Arguments _le {X H} x y : simpl never.

Lemma OT_le_refl X `{OrderedType X} x y : _eq x y -> _le x y.
Proof.
  firstorder.
Qed.

Instance OT_le_refl' X `{OrderedType X} : Reflexive _le.
Proof.
  hnf; intros.
  eapply OT_le_refl. reflexivity.
Qed.

Instance OT_le_trans X `{OrderedType X} : Transitive _le.
Proof.
  unfold _le; hnf; intros; destruct H0, H1; eauto.
  - left; etransitivity; eauto.
  - rewrite <- H1; eauto.
  - rewrite H0; eauto.
  - right; etransitivity; eauto.
Qed.

Instance OT_le_antisymmetric X `{OrderedType X} : Antisymmetric X _eq _le.
Proof.
  hnf; intros. destruct H0, H1; eauto.
  exfalso.
  assert (_lt x x) by (etransitivity; eauto).
  eapply (@OrderedType.StrictOrder_Irreflexive X _ _ _ (@OT_StrictOrder _ H)); eauto.
Qed.

Instance OT_le_morph X `{OrderedType X}
  : Proper (@_eq X _ ==> @_eq X _ ==> iff) (@_le X _).
Proof.
  unfold Proper, respectful; intros.
  split; eauto; intros; destruct H2; hnf;
    rewrite H0 in *; rewrite H1 in *; eauto.
Qed.

Instance OT_le_lt_morph X `{OrderedType X}
  : Proper (_eq ==> flip _lt ==> flip impl) (@_le X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H2; eauto.
  - rewrite H0. left. etransitivity; eauto.
  - rewrite H0. rewrite H2 in *. left; eauto.
Qed.

Instance OT_le_lt_morph_eq X `{OrderedType X}
  : Proper (@_lt X _ ==> _eq ==> flip impl) (@_le X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H2; eauto.
  - left. rewrite H1. rewrite H0. eauto.
  - rewrite H2 in *. rewrite H1 in *. left; eauto.
Qed.

Instance OT_le_lt_morph' X `{OrderedType X}
  : Proper (flip _lt ==> _eq ==> impl) (@_le X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H2; eauto.
  - left. rewrite <- H1. rewrite H0. eauto.
  - rewrite <- H1. rewrite <- H2. left; eauto.
Qed.

Instance OT_le_lt_morph'' X `{OrderedType X}
  : Proper (_eq ==> _lt ==> impl) (@_le X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H2; eauto.
  - left. rewrite H0 in *. etransitivity; eauto.
  - rewrite H0 in *. rewrite H2 in *. left. eauto.
Qed.

Lemma OT_lt_le X `{OrderedType X} x y
  : _lt x y -> _le x y.
Proof.
  left; eauto.
Qed.

Hint Resolve OT_lt_le | 100 .

Instance OT_le_impl_morph X `{OrderedType X}
  : Proper (@_le X _ ==> flip _le ==> flip impl) (@_le X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H0, H1, H2;
    try rewrite H0 in *; try rewrite H1 in *; try rewrite H2 in *; eauto using OT_lt_le;
      try solve [
            etransitivity; eauto using OT_lt_le
          | reflexivity
          ].
Qed.

Instance OT_le_impl_morph' X `{OrderedType X}
  : Proper (flip _le ==> _le ==> impl) (@_le X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  rewrite H0, <- H1, H2. reflexivity.
Qed.

Instance OT_lt_le_morph X `{OrderedType X}
  : Proper (flip _le ==> _le ==> impl) (@_lt X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H0, H1; eauto.
  - rewrite H0, H2; eauto.
  - rewrite H0, <- H1; eauto.
  - rewrite H0, <- H1; eauto.
  - rewrite H0, <- H1; eauto.
Qed.

Instance OT_lt_le_morph' X `{OrderedType X}
  : Proper (_le ==> flip _le ==> flip impl) (@_lt X _).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  destruct H0, H1; eauto.
  - rewrite H0, H2; eauto.
  - rewrite H0, <- H1; eauto.
  - rewrite H0, <- H1; eauto.
  - rewrite H0, <- H1; eauto.
Qed.

Hint Extern 20 (_le ?a ?a') => progress (first [ has_evar a | has_evar a' | reflexivity ]).

Hint Extern 20 =>
  match goal with
  | [ H : _lt ?x ?y, H' : _lt ?y ?x |- _ ] =>
    exfalso;
      rewrite H' in H;
      eapply OrderedType.StrictOrder_Irreflexive in H; eauto
  | [ H : _lt ?x ?y, H' : _eq ?y ?x |- _ ] =>
    exfalso;
      rewrite H' in H;
      eapply OrderedType.StrictOrder_Irreflexive in H; eauto
  | [ H : _lt ?x ?y, H' : _eq ?x ?y |- _ ] =>
    exfalso;
      rewrite H' in H;
      eapply OrderedType.StrictOrder_Irreflexive in H; eauto
  end.

Lemma OT_le_lt_contra X `{OrderedType X} x y
  : _le y x
    -> _lt x y -> False.
Proof.
  destruct 1; intros; eauto.
Qed.

Hint Extern 20 =>
match goal with
| [ H : _le ?y ?x, H' : _lt ?x ?y |- _ ] => exfalso; eapply (@OT_le_lt_contra _ _ _ _ H H')
end.


(* 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                                                     *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*                               Oct 1st 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                                 Monoid.v                                 *)
(****************************************************************************)

Require Export Map2.

Set Implicit Arguments.
Unset Strict Implicit.

SubClass BinOp (A : Setoid) := Map2 A A A.

Section monoid_laws.

Variables (A : Setoid) (op : BinOp A) (e : A).

Let Ap_op (x y : A) := op x y.

Infix "+_M" := Ap_op (at level 40, left associativity).

Definition Monoid_ass := forall x y z : A, x +_M (y +_M z) =_S x +_M y +_M z.

Definition Monoid_idl := forall x : A, e +_M x =_S x.

Definition Monoid_idr := forall x : A, x =_S x +_M e.

End monoid_laws.

Structure Monoid : Type :=
  {Mcarrier :> Setoid;
   Mop : BinOp Mcarrier;
   Munit : Mcarrier;
   Prf_monoid_ass : Monoid_ass Mop;
   Prf_monoid_idl : Monoid_idl Mop Munit;
   Prf_monoid_idr : Monoid_idr Mop Munit}.

Definition ApMop (m : Monoid) (x y : m) := Mop m x y.

Infix "+_M" := ApMop (at level 40, left associativity).

(*** rewrite rules ***)

Lemma Mass :
 forall (M : Monoid) (x y z : M), x +_M (y +_M z) =_S x +_M y +_M z.
Proof.
exact Prf_monoid_ass.
Qed.

Lemma Mass1 :
 forall (M : Monoid) (x y z : M), x +_M y +_M z =_S x +_M (y +_M z).
Proof.
intros; apply Sym; apply Mass.
Qed.

Lemma Midl : forall (M : Monoid) (x : M), Munit M +_M x =_S x.
Proof.
exact Prf_monoid_idl.
Qed.

Lemma Midl1 : forall (M : Monoid) (x : M), x =_S Munit M +_M x.
Proof.
intros; apply Sym; apply Midl.
Qed.

Lemma Midr : forall (M : Monoid) (x : M), x =_S x +_M Munit M.
Proof.
exact Prf_monoid_idr.
Qed.

Lemma Midr1 : forall (M : Monoid) (x : M), x +_M Munit M =_S x.
Proof.
intros; apply Sym; apply Midr.
Qed.

(* *)

(* Monoid Morphism *)

Section mon_mors.

Variable m1 m2 : Monoid.

Definition MonUnit_law (f : Map m1 m2) := f (Munit m1) =_S Munit m2.

Definition MonOp_law (f : Map m1 m2) :=
  forall a b : m1, f (a +_M b) =_S f a +_M f b.

Structure MonMor : Type :=
  {MonMap :> Map m1 m2;
   Prf_MonUnit_law : MonUnit_law MonMap;
   Prf_MonOp_law : MonOp_law MonMap}.

(*** rewrite rules ***)

Lemma MMon_unit : forall f : MonMor, f (Munit m1) =_S Munit m2.
Proof.
exact Prf_MonUnit_law.
Qed.

Lemma MMon_op : forall (f : MonMor) (a b : m1), f (a +_M b) =_S f a +_M f b.
Proof.
exact Prf_MonOp_law.
Qed.

(* *)

(* equality of two monoid morphisms *)

Definition Equal_MonMor (f g : MonMor) := f =_M g.

Lemma Equal_MonMor_equiv : Equivalence Equal_MonMor.
Proof.
apply Build_Equivalence.
unfold Reflexive, Equal_MonMor in |- *; intro f.
unfold Ext in |- *; intros x; apply Refl.
apply Build_Partial_equivalence.
unfold Transitive, Equal_MonMor in |- *; intros f g h H1 H2.
unfold Ext in |- *; intros x.
apply Trans with (g x).
apply (H1 x).
apply (H2 x).
unfold Symmetric, Equal_MonMor in |- *; intros f g H1.
unfold Ext in |- *; intros x.
apply Sym.
apply (H1 x).
Qed.

Canonical Structure MonMor_setoid : Setoid := Equal_MonMor_equiv.

End mon_mors.


Require Import Coq.omega.Omega.
Require Import Bedrock.Reflection.
Require Import Coq.Bool.Bool.

Ltac think' ext solver :=
  repeat (match goal with
            | [ H : Some _ = Some _ |- _ ] => inversion H ; clear H ; subst
            | [ H : inl _ = inr _ |- _ ] => inversion H ; clear H ; subst
            | [ H : inr _ = inr _ |- _ ] => inversion H ; clear H ; subst
            | [ H : _ |- _ ] => erewrite H in * |- by solver
            | [ H : _ |- _ ] => erewrite H by solver
            | [ H : andb _ _ = true |- _ ] =>
              apply andb_true_iff in H ; destruct H
            | [ H : orb _ _ = false |- _ ] =>
              apply orb_false_iff in H ; destruct H
            | [ H : Equivalence.equiv _ _ |- _ ] =>
              unfold Equivalence.equiv in H ; subst
            | [ H : _ /\ _ |- _ ] => destruct H
            | [ H : exists x, _ |- _ ] => destruct H
            | [ H : context [ match ?X with _ => _ end ] |- _ ] =>
              ((consider X ; try congruence); [ intros ]) ||
                (consider X ; solve [ congruence | solver ])
          end || (progress ext)).

Ltac think := think' idtac ltac:(eauto).

(** Lemmas About Lists **)
Require Import Coq.Lists.List.
Lemma nth_error_None_length : forall (T : Type) (ls : list T) (n : nat),
  nth_error ls n = None -> length ls <= n.
Proof.
  induction ls; destruct n; simpl; intros; think; try omega. inversion H.
  eapply IHls in H. omega.
Qed.

Lemma map_nth_error_full : forall T U (F : T -> U) ls n,
  nth_error (map F ls) n = match nth_error ls n with
                             | None => None
                             | Some v => Some (F v)
                           end.
Proof.
  induction ls; destruct n; simpl; intros; think; auto.
Qed.


Require Import Iron.Language.SystemF.KiJudge.

(* Substitution of types in types preserves kinding. *)
Theorem subst_type_type_ix
 :  forall ix ke t1 k1 t2 k2
 ,  get ix ke = Some k2
 -> KIND ke t1 k1
 -> KIND (delete ix ke) t2 k2
 -> KIND (delete ix ke) (substTT ix t2 t1) k1.
Proof.
 intros. gen ix ke t2 k1 k2.
 induction t1; intros; simpl; inverts H0; eauto.

 Case "TVar".
  destruct k1. destruct k2.
  fbreak_nat_compare.
  SCase "n = ix".
   auto.

  SCase "n < ix".
   apply KIVar. rewrite <- H4.
   apply get_delete_above; auto.

  SCase "n > ix".
   apply KIVar. rewrite <- H4.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below. omega.

 Case "TForall".
  apply KIForall.
  rewrite delete_rewind.
  eapply IHt1; eauto.
   apply liftTT_weaken. auto.
Qed.

Theorem subst_type_type
 :  forall ke t1 k1 t2 k2
 ,  KIND (ke :> k2) t1 k1
 -> KIND ke         t2 k2
 -> KIND ke (substTT 0 t2 t1) k1.
Proof.
 intros.
 unfold substTT.
 assert (ke = delete 0 (ke :> k2)). auto. rewrite H1.
 eapply subst_type_type_ix; simpl; eauto.
Qed.


From Cat Require Import Cat.

Set Implicit Arguments.

Class SliceOb (C : Cat) (Y : Ob C) : Type :=
{
  dom : Ob C;
  mor : Hom dom Y
}.

Arguments dom [C Y] _.
Arguments mor [C Y] _.

Coercion dom : SliceOb >-> Ob.

Definition SliceHom {C : Cat} {Y : Ob C} (A B : SliceOb C Y) : Type :=
  {f : Hom A B | mor A == f .> mor B}.

#[refine]
#[export]
Instance SliceHomSetoid {C : Cat} {Y : Ob C} (A B : SliceOb C Y) : Setoid (SliceHom A B) :=
{
  equiv := fun f g : SliceHom A B => proj1_sig f == proj1_sig g
}.
Proof. now solve_equiv. Defined.

Definition SliceComp
  {C : Cat} {A : Ob C} (X Y Z : SliceOb C A) (f : SliceHom X Y) (g : SliceHom Y Z) : SliceHom X Z.
Proof.
  destruct f as [f Hf], g as [g Hg]; red.
  exists (f .> g).
  now rewrite comp_assoc, <- Hg.
Defined.

Definition SliceId {C : Cat} {Y : Ob C} (X : SliceOb C Y) : SliceHom X X.
Proof.
  exists (id X).
  now rewrite comp_id_l.
Defined.

#[refine]
#[export]
Instance Slice (C : Cat) (T : Ob C) : Cat :=
{
  Ob := SliceOb C T;
  Hom := @SliceHom C T;
  HomSetoid := @SliceHomSetoid C T;
  comp := @SliceComp C T;
  id := @SliceId C T;
}.
Proof.
  - intros [X x] [Y y] [Z z] [f1 Hf1] [f2 Hf2] Hf [g1 Hg1] [g2 Hg2] Hg; cbn in *.
    now rewrite Hf, Hg.
  - intros [X x] [Y y] [Z z] [W w] [f Hf] [g Hg] [h Hh]; cbn in *.
    now rewrite comp_assoc.
  - intros [X x] [Y y] [f Hf]; cbn in *.
    now rewrite comp_id_l.
  - intros [X x] [Y y] [f Hf]; cbn in *.
    now rewrite comp_id_r.
Defined.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Axiom set : forall (a:Type), Type.
Parameter set_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (set a).
Existing Instance set_WhyType.

Parameter mem: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> Prop.

(* Why3 assumption *)
Definition infix_eqeq {a:Type} {a_WT:WhyType a} (s1:set a) (s2:set a) : Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).

Axiom extensionality :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a), (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset {a:Type} {a_WT:WhyType a} (s1:set a) (s2:set a) : Prop :=
  forall (x:a), (mem x s1) -> mem x s2.

Axiom subset_refl :
  forall {a:Type} {a_WT:WhyType a}, forall (s:set a), subset s s.

Axiom subset_trans :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a) (s3:set a), (subset s1 s2) ->
  (subset s2 s3) -> subset s1 s3.

Parameter empty: forall {a:Type} {a_WT:WhyType a}, set a.

(* Why3 assumption *)
Definition is_empty {a:Type} {a_WT:WhyType a} (s:set a) : Prop :=
  forall (x:a), ~ (mem x s).

Axiom empty_def1 :
  forall {a:Type} {a_WT:WhyType a}, is_empty (empty : set a).

Parameter add: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> set a.

Axiom add_def1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a) (y:a), forall (s:set a),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> set a.

Axiom remove_def1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a) (y:a) (s:set a),
  (mem x (remove y s)) <-> (~ (x = y) /\ (mem x s)).

Axiom subset_remove :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a) (s:set a), subset (remove x s) s.

Parameter union:
  forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> set a.

Axiom union_def1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter:
  forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> set a.

Axiom inter_def1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff:
  forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> set a.

Axiom diff_def1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a), subset (diff s1 s2) s1.

Parameter choose: forall {a:Type} {a_WT:WhyType a}, (set a) -> a.

Axiom choose_def :
  forall {a:Type} {a_WT:WhyType a},
  forall (s:set a), ~ (is_empty s) -> mem (choose s) s.

Parameter cardinal: forall {a:Type} {a_WT:WhyType a}, (set a) -> Z.

Axiom cardinal_nonneg :
  forall {a:Type} {a_WT:WhyType a},
  forall (s:set a), (0%Z <= (cardinal s))%Z.

Axiom cardinal_empty :
  forall {a:Type} {a_WT:WhyType a},
  forall (s:set a), ((cardinal s) = 0%Z) <-> (is_empty s).

Axiom cardinal_add :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a), forall (s:set a), ~ (mem x s) ->
  ((cardinal (add x s)) = (1%Z + (cardinal s))%Z).

Axiom cardinal_remove :
  forall {a:Type} {a_WT:WhyType a},
  forall (x:a), forall (s:set a), (mem x s) ->
  ((cardinal s) = (1%Z + (cardinal (remove x s)))%Z).

Axiom cardinal_subset :
  forall {a:Type} {a_WT:WhyType a},
  forall (s1:set a) (s2:set a), (subset s1 s2) ->
  ((cardinal s1) <= (cardinal s2))%Z.

Axiom cardinal1 :
  forall {a:Type} {a_WT:WhyType a},
  forall (s:set a), ((cardinal s) = 1%Z) -> forall (x:a), (mem x s) ->
  (x = (choose s)).

Axiom param : Type.
Parameter param_WhyType : WhyType param.
Existing Instance param_WhyType.

Axiom elt : Type.
Parameter elt_WhyType : WhyType elt.
Existing Instance elt_WhyType.

Parameter cost: param -> elt -> Z.

Parameter min: param -> (set elt) -> Z.

Axiom min_is_a_lower_bound :
  forall (p:param) (s:set elt) (x:elt), (mem x s) ->
  ((min p s) <= (cost p x))%Z.

Axiom min_appears_in_set :
  forall (p:param) (s:set elt), ~ (is_empty s) ->
  exists x:elt, (mem x s) /\ ((cost p x) = (min p s)).


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.arrival_sequence prosa.classic.model.priority
               prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.uni.schedule prosa.classic.model.schedule.uni.schedulability prosa.classic.model.schedule.uni.response_time.
Require Import prosa.classic.model.schedule.uni.basic.platform.
Require Import prosa.classic.analysis.uni.basic.workload_bound_fp prosa.classic.analysis.uni.basic.fp_rta_theory.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop path ssrfun.

Module ResponseTimeIterationFP.

  Import Job SporadicTaskset UniprocessorSchedule WorkloadBoundFP Priority
         ResponseTime Schedulability Platform TaskArrival ResponseTimeAnalysisFP.

  (* In this section, we define the response-time analysis for uniprocessor FP scheduling. *)
  Section Analysis.

    Context {SporadicTask: eqType}.
    Variable task_cost: SporadicTask -> time.
    Variable task_period: SporadicTask -> time.
    Variable task_deadline: SporadicTask -> time.

    (* In the algorithm, we consider pairs of tasks and computed response-time bounds. *)
    Let task_with_response_time := (SporadicTask * time)%type.

    (* Assume a fixed-priority policy. *)
    Variable higher_eq_priority: FP_policy SporadicTask.

    (* We begin by defining the fixed-point iteration for computing the
       response-time bound of each task. *)

    (* First, to ensure that the algorithm converges, we will run the iteration
       on each task for at most (task_deadline tsk - task_cost tsk + 1) steps,
       i.e., the worst-case time complexity of the procedure. *)
    Definition max_steps (tsk: SporadicTask) :=
      task_deadline tsk - task_cost tsk + 1.

    (* Next, based on the workload bound for uniprocessor FP scheduling, ... *)
    Let W := total_workload_bound_fp task_cost task_period higher_eq_priority.

    (* ...we compute the response-time bound R of a single task as follows:

           R (step) =  task_cost tsk                if step = 0,
                       W (ts, tsk, R (step-1))      otherwise.       *)
    Definition per_task_rta ts tsk :=
      iter_fixpoint (W ts tsk) (max_steps tsk) (task_cost tsk).

    (* Then, to validate the computed response-time bound, we
       check (a) if the iteration returned some value and
       (b) if the value is no larger than the deadline of the task. *)
    Let is_valid_bound tsk_R :=
      if tsk_R is (tsk, Some R) then
        if R <= task_deadline tsk then
          Some (tsk, R)
        else None
      else None.

    (* At the end, the response-time bounds for the entire taskset
       can be computed using the fixed-point iteration on each task.
       If all values are no larger than the deadline, we return the
       pairs of tasks and response-time bounds, else we return None. *)
    Definition fp_claimed_bounds ts: option (seq task_with_response_time) :=
      let possible_bounds := [seq (tsk, per_task_rta ts tsk) | tsk <- ts] in
        if all is_valid_bound possible_bounds then
          Some (pmap is_valid_bound possible_bounds)
        else None.

    (* The schedulability test simply checks if we got a list of
       response-time bounds (i.e., if the computation did not fail). *)
    Definition fp_schedulable (ts: seq SporadicTask) :=
      fp_claimed_bounds ts != None.

    (* In this section, we prove some properties about the computed
       list of response-time bounds. *)
    Section Lemmas.

      (* Let ts be any taskset to be analyzed. *)
      Variable ts: seq SporadicTask.

      (* Assume that the response-time analysis does not fail.*)
      Variable rt_bounds: seq task_with_response_time.
      Hypothesis H_analysis_succeeds:
        fp_claimed_bounds ts = Some rt_bounds.

      (* First, we prove that a response-time bound exists for each task. *)
      Section BoundExists.

        (* Let tsk be any task in ts. *)
        Variable tsk: SporadicTask.
        Hypothesis H_tsk_in_ts: tsk \in ts.

        (* Since the analysis succeeded, there must be a corresponding
           response-time bound R for this task. *)
        Lemma fp_claimed_bounds_for_every_task:
          exists R, (tsk, R) \in rt_bounds.
        Proof.
          rename H_analysis_succeeds into SOME.
          move: SOME; rewrite /fp_claimed_bounds.
          case ALL: all; [case => SOME | by done].
          move: ALL => /allP ALL.
          have IN: (tsk, per_task_rta ts tsk) \in
                   [seq (tsk, per_task_rta ts tsk) | tsk <- ts];
            first by apply/mapP; exists tsk.
          specialize (ALL _ IN); move: ALL.
          rewrite /is_valid_bound; case RTA: per_task_rta => [R|] //.
          case DL: (R <= _); last by done.
          move => _; exists R; rewrite -SOME.
          rewrite mem_pmap; apply/mapP.
          exists (tsk, Some R); first by rewrite -RTA.
          by rewrite /is_valid_bound DL.
        Qed.

      End BoundExists.

      (* Next, assuming that a bound exists, we prove some of its properties. *)
      Section PropertiesOfBound.

        (* Let tsk and R be any pair of task and response-time bound
           returned by the analysis. *)
        Variable tsk: SporadicTask.
        Variable R: time.
        Hypothesis H_tsk_R_computed: (tsk, R) \in rt_bounds.

        (* First, we show that tsk comes from task set ts. *)
        Lemma fp_claimed_bounds_from_taskset:
          tsk \in ts.
        Proof.
          rename H_analysis_succeeds into SOME, H_tsk_R_computed into IN.
          move: SOME; rewrite /fp_claimed_bounds.
          case: all; [case => SOME | by done].
          move: IN; rewrite -SOME mem_pmap.
          move => /mapP [[tsk' someR]].
          rewrite /is_valid_bound; case: someR; last by done.
          move => R'; case: (R' <= _); last by done.
          move => IN; case => EQ1 EQ2; subst tsk' R'.
          by move: IN => /mapP [tsk' IN]; case; move => EQ1; subst tsk'.
        Qed.

        (* Next, we prove that R is computed using the per-task
           fixed-point iteration, ... *)
        Lemma fp_claimed_bounds_computes_iteration:
          per_task_rta ts tsk = Some R.
        Proof.
          rename H_analysis_succeeds into SOME, H_tsk_R_computed into IN.
          move: SOME; rewrite /fp_claimed_bounds.
          case: all; [case => SOME | by done].
          move: IN; rewrite -SOME mem_pmap.
          move => /mapP [[tsk' someR]].
          rewrite /is_valid_bound; case: someR; last by done.
          move => R'; case: (R' <= _); last by done.
          move => IN; case => EQ1 EQ2; subst tsk' R'.
          by move: IN => /mapP [tsk' IN]; case; move => EQ1 ->; subst tsk'.
        Qed.

        (* ...which implies that R is also a fixed point of the recurrence. *)
        Lemma fp_claimed_bounds_yields_fixed_point :
          R = W ts tsk R.
        Proof.
          rename H_analysis_succeeds into SOME, H_tsk_R_computed into IN.
          move: SOME; rewrite /fp_claimed_bounds.
          case: all; [case => SOME | by done].
          move: IN; rewrite -SOME mem_pmap.
          move => /mapP [[tsk' someR]].
          rewrite /is_valid_bound; case: someR; last by done.
          move => R'; case: (R' <= _); last by done.
          move => IN; case => EQ1 EQ2; subst tsk' R'.
          move: IN => /mapP [tsk' IN]; case; move => EQ1; subst tsk'.
          move => RESP; symmetry in RESP; move: RESP.
          rewrite /per_task_rta.
          set f := W _ _; set s := max_steps _; set x0 := task_cost _.
          case (iter_fixpoint_cases f s x0) => [NONE | [R' [SOME' EQ]]];
            first by rewrite NONE.
          by rewrite SOME'; case => H; subst.
        Qed.

        (* Since the analysis validates the computed values, it follows
           that R is no larger than the deadline of tsk. *)
        Lemma fp_claimed_bounds_le_deadline:
          R <= task_deadline tsk.
        Proof.
          rename H_analysis_succeeds into SOME, H_tsk_R_computed into IN.
          move: SOME; rewrite /fp_claimed_bounds.
          case: all; [case => SOME | by done].
          move: IN; rewrite -SOME mem_pmap.
          move => /mapP [[tsk' someR]].
          rewrite /is_valid_bound; case: someR; last by done.
          move => R'; case LE: (R' <= _); last by done.
          by move => IN; case => EQ1 EQ2; subst tsk' R'.
        Qed.

        (* Using the monotonicity of the workload bound, we also prove that
           the computed response-time bound is positive. This ensures that
           the busy interval to be analyzed is not empty. *)
        Section BoundPositive.

          (* Assume that the priority relation is reflexive. *)
          Hypothesis H_priority_is_reflexive:
            FP_is_reflexive higher_eq_priority.

          (* Assume that tasks have positive costs and periods. *)
          Hypothesis H_cost_positive: task_cost tsk > 0.
          Hypothesis H_period_positive:
            forall tsk, tsk \in ts -> task_period tsk > 0.

          (* Then, we prove that the fixed-point R is positive. *)
          Lemma fp_claimed_bounds_gt_zero :
            R > 0.
          Proof.
            set f := W ts tsk; set s := max_steps tsk; set x0 := task_cost tsk.
            apply leq_trans with (n := task_cost tsk);
              first by apply H_cost_positive.
            have GE: task_cost tsk <= f (task_cost tsk).
            {
              apply total_workload_bound_fp_ge_cost; try (by done).
              - by apply fp_claimed_bounds_from_taskset.
              - by apply H_period_positive, fp_claimed_bounds_from_taskset.
            }
            have TRANS: transitive leq by rewrite /transitive;apply leq_trans.
            have MON: monotone f leq.
            {
              by intros x1 x2 LE;
                apply total_workload_bound_fp_non_decreasing.
            }
            apply leq_trans with (n := task_cost tsk); first by done.
            apply iter_fixpoint_ge_bottom with (f0 := f) (max_steps := s);
              try (by done).
            by apply fp_claimed_bounds_computes_iteration.
          Qed.

        End BoundPositive.

      End PropertiesOfBound.

    End Lemmas.

  End Analysis.

  (* In this section, we prove the correctness of the RTA. *)
  Section ProvingCorrectness.

    Context {SporadicTask: eqType}.
    Variable task_cost: SporadicTask -> time.
    Variable task_period: SporadicTask -> time.
    Variable task_deadline: SporadicTask -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> SporadicTask.

    (* Consider a task set ts... *)
    Variable ts: taskset_of SporadicTask.

    (* ...where tasks have valid parameters. *)
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Assume any job arrival sequence with consistent, duplicate-free arrivals... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

   (* ...such that all jobs come from task set ts, ...*)
    Hypothesis H_all_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* ...jobs have valid parameters...*)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* ... and jobs satisfy the sporadic task model.*)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* Assume any fixed-priority policy... *)
    Variable higher_eq_priority: FP_policy SporadicTask.

    (* ...that is reflexive and transitive, i.e., indicating higher-or-equal task priority. *)
    Hypothesis H_priority_reflexive: FP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_transitive: FP_is_transitive higher_eq_priority.

    (* Next, consider any uniprocessor schedule of this arrival sequence...*)
    Variable sched: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence: jobs_come_from_arrival_sequence sched arr_seq.

    (* ...where jobs do not execute before their arrival times nor after completion. *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Also assume that the scheduler is work-conserving and respects the FP policy. *)
    Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
    Hypothesis H_respects_FP_policy:
      respects_FP_policy job_arrival job_cost job_task arr_seq sched higher_eq_priority.

    (* For simplicity, let's define some local names. *)
    Let no_deadline_missed_by_task :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.
    Let no_deadline_missed_by_job :=
      job_misses_no_deadline job_arrival job_cost job_deadline sched.
    Let response_time_bounded_by :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched.

    (* Recall the iteration for the response-time analysis and the corresponding
       schedulability test. *)
    Let RTA_claimed_bounds :=
      fp_claimed_bounds task_cost task_period task_deadline higher_eq_priority ts.
    Let claimed_to_be_schedulable :=
      fp_schedulable task_cost task_period task_deadline higher_eq_priority ts.

    (* First, we prove that the RTA yields valid response-time bounds. *)
    Theorem fp_analysis_yields_response_time_bounds :
      forall tsk R,
        (tsk, R) \In RTA_claimed_bounds ->
        response_time_bounded_by tsk R.
    Proof.
      rename H_valid_task_parameters into PARAMS,
             H_valid_job_parameters into JOBPARAMS.
      unfold valid_sporadic_job, valid_realtime_job,
             valid_sporadic_taskset, is_valid_sporadic_task in *.
      unfold RTA_claimed_bounds; intros tsk R.
      case SOME: fp_claimed_bounds => [rt_bounds|] IN; last by done.
      apply uniprocessor_response_time_bound_fp with
            (task_cost0 := task_cost) (task_period0 := task_period)
            (ts0 := ts) (task_deadline0 := task_deadline)
            (job_deadline0 := job_deadline)
            (higher_eq_priority0 := higher_eq_priority); try (by done).
      {
        apply fp_claimed_bounds_gt_zero with (task_cost0 := task_cost)
          (task_period0 := task_period) (task_deadline0 := task_deadline)
          (higher_eq_priority0 := higher_eq_priority) (ts0 := ts)
          (rt_bounds0 := rt_bounds) (tsk0 := tsk); try (by done).
        {
          feed (PARAMS tsk); last by move: PARAMS => [P1 _].
          by apply fp_claimed_bounds_from_taskset with
            (task_cost0 := task_cost) (task_period0 := task_period)
            (task_deadline0 := task_deadline) (rt_bounds0 := rt_bounds)
            (higher_eq_priority0 := higher_eq_priority) (R0 := R).
        }
        by intros tsk0 IN0; specialize (PARAMS tsk0 IN0); des.
      }
      by apply fp_claimed_bounds_yields_fixed_point with
        (task_deadline0 := task_deadline) (rt_bounds0 := rt_bounds).
    Qed.

    (* Next, we show that the RTA is a sufficient schedulability analysis. *)
    Section AnalysisIsSufficient.

      (* If the schedulability test suceeds, ...*)
      Hypothesis H_test_succeeds: claimed_to_be_schedulable.

      (* ...then no task misses its deadline. *)
      Theorem taskset_schedulable_by_fp_rta :
        forall tsk, tsk \in ts -> no_deadline_missed_by_task tsk.
      Proof.
        have RTA := fp_analysis_yields_response_time_bounds.
        rename H_test_succeeds into TEST, H_valid_job_parameters into JOBPARAMS.
        unfold claimed_to_be_schedulable, fp_schedulable in *.
        have RESP := fp_claimed_bounds_for_every_task task_cost task_period task_deadline
                                                      higher_eq_priority ts.
        have DL := fp_claimed_bounds_le_deadline task_cost task_period task_deadline
                                                 higher_eq_priority ts.
        move:TEST; case TEST:(fp_claimed_bounds _ _ _ _ _) => [rt_bounds|] _//.
        intros tsk IN.
        move: (RESP rt_bounds TEST tsk IN) => [R INbounds].
        specialize (DL rt_bounds TEST tsk R INbounds).
        apply task_completes_before_deadline with
                (task_deadline0 := task_deadline) (R0 := R); try (by done);
          first by intros j ARRj; specialize (JOBPARAMS j ARRj); move: JOBPARAMS => [_ [_ EQ]].
        by apply RTA; rewrite /RTA_claimed_bounds TEST.
      Qed.

      (* Since all jobs of the arrival sequence are spawned by the task set,
         we also conclude that no job in the schedule misses its deadline. *)
      Theorem jobs_schedulable_by_fp_rta :
        forall j,
          arrives_in arr_seq j ->
          no_deadline_missed_by_job j.
      Proof.
        intros j ARRj.
        have SCHED := taskset_schedulable_by_fp_rta.
        unfold no_deadline_missed_by_task, task_misses_no_deadline in *.
        apply SCHED with (tsk := job_task j); try (by done).
        by apply H_all_jobs_from_taskset.
      Qed.

    End AnalysisIsSufficient.

  End ProvingCorrectness.

End ResponseTimeIterationFP.


Require Export PredMonad.Reflection2.OrderedType.
Require Export PredMonad.Reflection2.OrderedContext.
Require Export PredMonad.Reflection2.OExpr.

(***
 *** The monad typeclass
 ***)

Class MonadOps M `{OTypeF1 M} : Type :=
  { returnM : forall {A} `{OType A}, A -o> M A _;
    bindM : forall {A B} `{OType A} `{OType B},
        M A _ -o> (A -o> M B _) -o> M B _ }.

Class Monad M `{MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall A B `{OType A} `{OType B} (f: A -o> M B _) x,
        bindM @o@ (returnM @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall A `{OType A} m prp,
        bindM @o@ m @o@ (mk_ofun (fun x => returnM @o@ x) (prp:=prp)) =o= m;

    monad_assoc :
      forall A B C `{OType A} `{OType B} `{OType C}
             m (f: A -o> M B _) (g: B -o> M C _) prp,
        bindM @o@ (bindM @o@ m @o@ f) @o@ g
        =o=
        bindM @o@ m @o@ (mk_ofun (fun x => bindM @o@ (f @o@ x) @o@ g) (prp:=prp));
  }.

(* Helpful bind notation *)
Notation "'do' x <- m1 ; m2" :=
  (bindM @o@ m1 @o@ (mk_ofun (fun x => m2))) (at level 60, right associativity).

Notation "'edo' x <- m1 ; m2" :=
  (Embed bindM @e@ m1 @e@ (mkLam (fun x => m2)))
    (at level 60, right associativity).

(***
 *** The Monad Laws for OExprs
 ***)

(* Return-bind law for OExprs *)
Lemma monad_return_bind_OExpr
      `{Monad} {ctx A B} `{OType A} `{OType B}
      (f: OExpr ctx (A -o> M B _)) (x: OExpr ctx A) :
  App (App (Embed bindM) (App (Embed returnM) x)) f
  =e= (App f x).
Proof.
  apply unquote_eq. intro. apply monad_return_bind.
Qed.

(* Bind-return law for OExprs *)
Lemma monad_bind_return_OExpr
      `{Monad} {ctx A} `{OType A} (m: OExpr ctx (M A _)) :
  App (App (Embed bindM) m) (Lam (App (Embed returnM) (Var OVar_0))) =e= m.
Proof.
  apply unquote_eq. intro. apply monad_bind_return.
Qed.

(* Associativity law for OExprs *)
Lemma monad_assoc_OExpr
      `{Monad} {ctx A B C} {RA:OType A} {RB:OType B} {RC:OType C}
      (m:OExpr ctx (M A _))
      (f: OExpr ctx (A -o> M B _)) (g: OExpr ctx (B -o> M C _)) :
  App (App (Embed bindM) (App (App (Embed bindM) m) f)) g =e=
  App (App (Embed bindM) m)
      (Lam (App (App (Embed bindM)
                     (App (weakenOExpr 0 A f) (Var OVar_0)))
                (weakenOExpr 0 A g))).
Proof.
  apply unquote_eq. intro. simpl. apply monad_assoc.
Qed.

(* Add the monad laws to the OT rewrite set *)
Hint Rewrite @monad_return_bind_OExpr @monad_bind_return_OExpr
     @monad_assoc_OExpr : osimpl.

(***
 *** The Identity Monad
 ***)

Definition Identity A `{OType A} := A.

Instance OTypeF_Identity : OTypeF1 Identity :=
  fun _ ot => ot.

(* Instance FindOTypeF_Identity : FindOTypeF1 Identity (fun _ ot => ot) := I. *)

Instance IdMonad_MonadOps : MonadOps Identity :=
  { returnM := fun A _ => ofun x => x;
    bindM := fun A B _ _ =>
               ofun m => ofun (f : A -o> B ) => f @o@ m }.

Instance IdMonad : Monad Identity.
Proof.
  econstructor; intros; simpl; reflexivity.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (1%R / 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2; admit.
Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (1%R / (pow2 n))%R).
(* Why3 intros n h1. *)
intros n Hn.
generalize Hn.
pattern n; apply Z_lt_induction; auto.
clear n Hn.
intros n Hind Hn.
assert (h:n=0\/n>0) by omega; destruct h.
ae.
replace n with (n-1+1) by omega.
replace (- (n - 1 + 1)) with (-(n-1) -1)  by omega.
rewrite Power_p;auto with zarith.
rewrite Power_s;auto with zarith.
ae.
Admitted.


Section ml.
Variables A B:Prop.
Theorem Contp: (A -> B) -> (~ B -> ~A).
Proof.
intro hab.
intro nb.
intro a.
apply nb.
apply hab.
assumption.
Qed.
End ml.

Check Contp.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


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

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

Print Assumptions carry.