(** * Modularity in a fibration setting

The main result of this file is described here.

Let D be a fibration (ie, a cleaving in the displayed category setting)
over a category C such that the projection functor is faithful.

Then the projection functor lifts equalizers.

We also prove the dual statement (opfibration and coequalizers)

 *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.limits.pushouts.
Require Import UniMath.CategoryTheory.limits.initial.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.equalizers.
Require Import UniMath.CategoryTheory.limits.graphs.coequalizers.

Require Import Modules.Prelims.Opfibration.

Open Scope cat.

Section pr.
  Context {C : category} (D : disp_cat C).

  (** This is a fibration *)
  Context   (cl : cleaving D).
  (** The fibration is faithful
This can be reformulated as [faithful pr1_category) as in [faithful_pr1_category]
   *)
  Hypothesis (faithful_fibration : faithful (pr1_category D)).
  (** Yet another formulation *)
  Lemma faithful_reformulated {x y} (f g : total_category D ⟦ x, y ⟧) : pr1 f = pr1 g -> f = g.
  Proof.
    eapply invmaponpathsincl.
    eapply faithful_fibration.
  Qed.

  Lemma faithful_fibration_equalizer {a b} (f g : total_category D⟦a, b⟧)
        ( eq  : Equalizer _ (# (pr1_category D) f)%cat (# (pr1_category D) g))
        : Equalizer _ f g.
  Proof.
    use make_Equalizer.
    - refine (EqualizerObject _ eq ,, _).
      eapply (cleaving_ob cl ).
      + apply EqualizerArrow.
      + exact (pr2 a).
    - refine (EqualizerArrow _ _ ,, _).
      apply cleaving_mor.
    - apply faithful_reformulated.
      cbn.
      apply EqualizerArrowEq.
    - use make_isEqualizer.
      + intros e h' eqh'.
        assert (h := EqualizerArrowComm _ eq _ _ (base_paths _ _ eqh')).
        set (ar_base := EqualizerIn  _ eq _ _ (base_paths _ _ eqh')) in h.
        use unique_exists.
        * refine (ar_base ,, _).
          cbn.
          eapply cartesian_factorisation.
          -- use cartesian_lift_is_cartesian.
          -- generalize (pr2 h').
             apply transportb.
             exact h.
        * cbn.
          apply subtypePairEquality'.
          --  exact h.
          --  apply invproofirrelevance.
              intros u v.
              apply pair_inj.
              ++ apply homset_property.
              ++ apply faithful_reformulated.
                 apply idpath.
        * cbn -[isaprop].
          intro y.
          apply (homset_property (total_category D)).
        *
          intros h'2 eqh'2.
          apply faithful_reformulated.
          cbn.
          apply EqualizerInUnique.
          apply base_paths in  eqh'2.
          exact eqh'2.
  Defined.
End pr.

Section oppr.
  Context {C : category} (D : disp_cat C).

  (** This is a opfibration *)
  Context   (cl : opcleaving D).
  (** The opfibration is faithful
This can be reformulated as [faithful pr1_category) as in [faithful_pr1_category]
   *)
  Hypothesis (faithful_opfibration : faithful (pr1_category D)).

  Local Notation faithful_reformulated := (faithful_reformulated  D  faithful_opfibration).

  Lemma faithful_opfibration_coequalizer {a b} (f g : total_category D⟦a, b⟧)
        ( eq  : Coequalizer _ (# (pr1_category D) f)%cat (# (pr1_category D) g))
        : Coequalizer _ f g.
  Proof.
    use make_Coequalizer.
    - refine (CoequalizerObject _ eq ,, _).
      eapply (opcleaving_ob cl ).
      + apply CoequalizerArrow.
      + exact (pr2 b).
    - refine (CoequalizerArrow _ _ ,, _).
      apply opcleaving_mor.
    - apply faithful_reformulated.
      cbn.
      apply CoequalizerArrowEq.
    - use make_isCoequalizer.
      + intros e h' eqh'.
        assert (h := CoequalizerArrowComm _ eq _ _ (base_paths _ _ eqh')).
        set (ar_base := CoequalizerOut  _ eq _ _ (base_paths _ _ eqh')) in h.
        use unique_exists.
        * refine (ar_base ,, _).
          cbn.
          eapply cocartesian_factorisation.
          -- use cocartesian_lift_is_cocartesian.
          -- generalize (pr2 h').
             apply transportb.
             exact h.
        * cbn.
          apply subtypePairEquality'.
          --  exact h.
          --  apply invproofirrelevance.
              intros u v.
              apply pair_inj.
              ++ apply homset_property.
              ++ apply faithful_reformulated.
                 apply idpath.
        * cbn -[isaprop].
          intro y.
          apply (homset_property (total_category D)).
        *
          intros h'2 eqh'2.
          apply faithful_reformulated.
          cbn.
          apply CoequalizerOutUnique.
          apply base_paths in  eqh'2.
          exact eqh'2.
  Defined.
End oppr.


(** * Bicolano: Number axiomatisation *)
(* Hendra : added ``not'' *)

Require Export ZArith.
Require Export Bool.

(** Common interface for numerics domains *)
Open Local Scope Z_scope.
(** Taken form CompCert project *)

 Module Type NUMERIC.
  Parameter t : Set.
  Parameter power : nat.
  Parameter toZ : t -> Z.

  Parameter add : t -> t -> t.
  Parameter sub : t -> t -> t.
  Parameter mul : t -> t -> t.
  Parameter div : t -> t -> t.
  Parameter rem : t -> t -> t.
  Parameter shr : t -> t -> t.
  Parameter shl : t -> t -> t.
  Parameter ushr : t -> t -> t.
  Parameter and : t -> t -> t.
  Parameter or : t -> t -> t.
  Parameter xor : t -> t -> t.
  Parameter neg : t -> t.
  Parameter not : t -> t.
  Parameter const : Z -> t.

 End NUMERIC.

 Module Type NUMSIZE.
  Parameter power : nat.
 End NUMSIZE.

 Module Make (S:NUMSIZE) <: NUMERIC.

  Definition modulus : Z := two_power_nat S.power.
  Definition half_modulus : Z := modulus / 2.

  Record t_: Set := mkint { intval: Z; intrange: 0 <= intval < modulus }.
  Definition t : Set := t_.

  Definition power := S.power.

  Definition unsigned (n: t) : Z := intval n.

  Definition signed (n: t) : Z :=
    if Zlt_bool (unsigned n) half_modulus
      then unsigned n
      else unsigned n - modulus.

  Definition toZ : t -> Z := signed.

  Lemma two_power_nat_O : two_power_nat O = 1.
  Proof. reflexivity. Qed.

  Lemma two_power_nat_pos : forall n : nat, two_power_nat n > 0.
  Proof.
    induction n. rewrite two_power_nat_O. omega.
    rewrite two_power_nat_S. omega.
  Qed.

  Lemma mod_in_range:
    forall x, 0 <= Zmod x modulus < modulus.
  Proof.
    intro.
    exact (Z_mod_lt x modulus (two_power_nat_pos power)).
  Qed.

  Definition repr (x: Z) : t :=
    mkint (Zmod x modulus) (mod_in_range x).

  Definition add (x y: t) : t :=
    repr (unsigned x + unsigned y).
  Definition sub (x y: t) : t :=
    repr (unsigned x - unsigned y).
  Definition mul (x y: t) : t :=
    repr (unsigned x * unsigned y).

  Definition Zdiv_round (x y: Z) : Z :=
    if Zlt_bool x 0 then
      if Zlt_bool y 0 then (-x) / (-y) else - ((-x) / y)
      else
        if Zlt_bool y 0 then -(x / (-y)) else x / y.
  Definition Zmod_round (x y: Z) : Z :=
    x - (Zdiv_round x y) * y.

  Definition div (x y: t) : t :=
    repr (Zdiv_round (signed x) (signed y)).
  Definition rem (x y: t) : t :=
    repr (Zmod_round (signed x) (signed y)).

  Definition Z_bin_decomp (x: Z) : bool * Z :=
    match x with
      | Z0 => (false, 0)
      | Zpos p =>
        match p with
          | xI q => (true, Zpos q)
          | xO q => (false, Zpos q)
          | xH => (true, 0)
        end
      | Zneg p =>
        match p with
          | xI q => (true, Zneg q - 1)
          | xO q => (false, Zneg q)
          | xH => (true, -1)
        end
    end.
  Fixpoint bits_of_Z (n: nat) (x: Z) {struct n}: Z -> bool :=
    match n with
      | O =>
        (fun i: Z => false)
      | S m =>
        let (b, y) := Z_bin_decomp x in
          let f := bits_of_Z m y in
            (fun i: Z => if Zeq_bool i 0 then b else f (i - 1))
    end.

  Definition Z_shift_add (b: bool) (x: Z) :=
    if b then 2 * x + 1 else 2 * x.

  Fixpoint Z_of_bits (n: nat) (f: Z -> bool) {struct n}: Z :=
    match n with
      | O => 0
      | S m => Z_shift_add (f 0) (Z_of_bits m (fun i => f (i + 1)))
    end.

  Definition shr (x y: t): t :=
    repr (signed x / two_p (unsigned y)).

  Definition shl (x y: t): t :=
    let fx := bits_of_Z power (unsigned x) in
      let vy := unsigned y in
        repr (Z_of_bits power (fun i => fx (i - vy))).

  Definition ushr (x y: t): t :=
    let fx := bits_of_Z power (unsigned x) in
      let vy := unsigned y in
        repr (Z_of_bits power (fun i => fx (i + vy))).

  Definition bitwise_binop (f: bool -> bool -> bool) (x y: t) :=
    let fx := bits_of_Z power (unsigned x) in
      let fy := bits_of_Z power (unsigned y) in
        repr (Z_of_bits power (fun i => f (fx i) (fy i))).

  Definition and (x y: t): t := bitwise_binop andb x y.
  Definition or (x y: t): t := bitwise_binop orb x y.
  Definition xor (x y: t) : t := bitwise_binop xorb x y.

  Definition neg (x: t) := repr (- unsigned x).
  Definition not (x: t) := repr ((- unsigned x) - 1).
    (* assuming that neg is two's complement and not is one's complement *)

  Definition const : Z -> t := repr.

 End Make.


Require Import michelson.

Require Import List.
Import ListNotations.

Hint Constructors BigStep.

(* Quick math *)
Fact failed_fails : (forall i, (BigStep i (SE_Failed) (SE_Failed))).
Proof. induction i; eauto. Qed.

(* The semantics is not actually total (example: addition with empty stack is not defined).
 * Hence, we wrap the semantics in an inductive giving a "escape hatch value".
 * *)
Inductive BigStep_total :
  code -> stackerr -> option stackerr -> Prop :=
| BigStep_cont :
    forall (i : code) (d d' : stackerr),
      BigStep i d d' ->
      BigStep_total i d (Some d')
| BigStep_stuck :
    forall  (i : code) (d : stackerr),
      BigStep_total i d None.

(* Clearly if we have Some value with wrapped semantics, it is also in underlying *)
Fact BigStep_total_to_BigStep :
  forall i d d',
    BigStep_total i d (Some d') ->
    BigStep i d d'.
Proof. intros i d d' H. now inversion H. Qed.

(* Some convenient tactics *)

(* called when the interpreter is stuck *)
Ltac stuck := exists None; constructor.

(* destruct a as num, if it is not none the interpreter is stuck *)
Ltac as_num v1 :=
  destruct v1 eqn:Hd0;
  match goal with
  | [ Hd0 : v1 = d_Num _ |- _ ] => clear Hd0
  | _ => stuck
  end.

(* To show that the semantics can be executed. This proof of theorem
will then be extracted as an ocaml program *)
Theorem total :
  forall i d,
      { md : _ & BigStep_total i d md }.
Proof.
  intros i.

  intro d. destruct d as [|d].
  eexists. constructor. apply failed_fails.

  Hint Constructors BigStep.
  Hint Resolve BigStep_cont failed_fails BigStep_total_to_BigStep.

  generalize dependent d.
  generalize dependent i.
  induction i; intros d0; eauto.

  (* I here prove for the rules of sequence, addition, subtraction *)

  (* Sequence *)
  3: {
  destruct (IHi1 d0) as [ [[|d'']|] Hi1 ]; [ | | stuck].
  (* Case i1 fails *)
    + eauto.
  (* case it doesn't *)
    + destruct (IHi2 d'') as [ [d'|] Hi2 ]; [ | stuck].
      eauto 10.
  }

  (* Add *)
  (* 30: { *)
  (*   (* execution can only continue if there two values on the stack *) *)
  (*   destruct d0 as [ | v1 [| v2 d0] ]; [ stuck | stuck | ]. *)
  (*   as_num v1. as_num v2. eauto. *)
  (* } *)

  (* (* Sub *) *)
  (* 30: { *)
  (*   destruct d0 as [ | v1 [| v2 d0] ]; [ stuck | stuck | ]. *)
  (*   as_num v1. as_num v2. eauto. *)
  (* } *)

  (* TODO: deal with remaining cases *)
  all : stuck.
Defined.

(* extract the function total to michelson.ml *)
Require Extraction.
Extraction Language OCaml.
Extraction "michelson.ml" total.


(** Coq coding by choukh, Nov 2020 **)

Require Export ZFC.Elements.EX6_3.
Require Import ZFC.Lib.OrdFacts.
Require Import ZFC.Lib.WosetMin.
Import WosetMin.FullVer.

(***
  基数的序与序数的序等价，
  无限基数是极限基数，
  后继基数，
  每个序数都有比它大的基数，
  不存在包括所有基数的集合
***)

(* == implicit AC == *)
(* 基数是序数 *)
Lemma card_is_ord : 𝐂𝐃 ⫃ 𝐎𝐍.
Proof.
  intros 𝜅 [k Hk]. subst. apply card_is_initord.
Qed.
Global Hint Resolve card_is_ord : core.

(* == implicit AC == *)
(* 无限基数是序数 *)
Lemma infcard_is_ord : 𝐂𝐃ⁱⁿᶠ ⫃ 𝐎𝐍.
Proof. intros 𝜅 [H _]. auto. Qed.
Global Hint Immediate infcard_is_ord : core.

(* == implicit AC == *)
(* 基数集是良序集 *)
Lemma cards_woset : ∀ 𝛫, 𝛫 ⪽ 𝐂𝐃 → woset 𝛫 (MemberRel 𝛫).
Proof.
  intros K HK. apply ords_woset.
  intros 𝜅 H𝜅. apply card_is_ord. apply HK. apply H𝜅.
Qed.

(* == implicit AC == *)
Lemma ord_lt_to_cardLt : ∀ 𝜅 𝜆 ⋵ 𝐂𝐃, 𝜅 ∈ 𝜆 → 𝜅 <𝐜 𝜆.
Proof with auto.
  intros 𝜅 H𝜅 𝜆 H𝜆 Hlt.
  apply ord_lt_iff_psub in Hlt as [Hsub Hnq]...
  apply dominate_sub in Hsub. repeat split...
Qed.

(* == implicit AC == *)
Lemma cardLt_to_ord_lt : ∀ 𝜅 𝜆,
  𝜅 <𝐜 𝜆 → 𝜅 ∈ 𝜆.
Proof with auto.
  intros 𝜅 𝜆 [[H𝜅 [H𝜆 Hdom]] Hnq].
  contra. apply Hnq.
  rewrite (card_of_card 𝜅), (card_of_card 𝜆)... apply CardAx1.
  apply ord_le_iff_not_gt in H...
  apply ord_le_iff_sub in H...
  apply dominate_sub in H. apply Schröeder_Bernstein...
Qed.

(* == implicit AC == *)
(* 基数的序与序数的序等价 *)
Fact cardLt_iff_ord_lt : ∀ 𝜅 𝜆,
  𝜅 <𝐜 𝜆 ↔ 𝜅 ⋵ 𝐂𝐃 ∧ 𝜆 ⋵ 𝐂𝐃 ∧ 𝜅 ∈ 𝜆.
Proof with auto.
  split.
  - intros Hlt. split. apply Hlt. split. apply Hlt.
    apply cardLt_to_ord_lt...
  - intros [H𝜅 [H𝜆 Hlt]]. apply ord_lt_to_cardLt...
Qed.

Module AlternativeProofAboutCardConnectivity.

Check EST6_4.card_connected.

(* == implicit AC == *)
(* 基数具有连通性 *)
Fact card_connected : ∀ 𝜅 𝜆 ⋵ 𝐂𝐃, 𝜅 ≠ 𝜆 → 𝜅 <𝐜 𝜆 ∨ 𝜆 <𝐜 𝜅.
Proof.
  intros 𝜅 H𝜅 𝜆 H𝜆 Hnq.
  apply ord_connected in Hnq as [];
  auto; [left|right]; apply cardLt_iff_ord_lt; auto.
Qed.

End AlternativeProofAboutCardConnectivity.

(* == implicit AC == *)
Lemma ord_le_to_cardLe : ∀ 𝜅 𝜆 ⋵ 𝐂𝐃, 𝜅 ⋸ 𝜆 → 𝜅 ≤ 𝜆.
Proof with auto.
  intros 𝜅 H𝜅 𝜆 H𝜆 Hlt.
  rewrite (card_of_card 𝜅), (card_of_card 𝜆)...
  apply cardLe_iff. apply dominate_sub.
  apply ord_le_iff_sub...
Qed.

(* == implicit AC == *)
Lemma cardLe_to_ord_le : ∀ 𝜅 𝜆, 𝜅 ≤ 𝜆 → 𝜅 ⋸ 𝜆.
Proof with auto.
  intros.
  apply cardLe_iff_lt_or_eq in H as [|[_ [_ H]]]...
  left. apply cardLt_to_ord_lt...
Qed.

(* == implicit AC == *)
(* 基数的序与序数的序等价 *)
Fact cardLe_iff_ord_le : ∀ 𝜅 𝜆,
  𝜅 ≤ 𝜆 ↔ 𝜅 ⋵ 𝐂𝐃 ∧ 𝜆 ⋵ 𝐂𝐃 ∧ 𝜅 ⋸ 𝜆.
Proof with auto.
  split.
  - intros Hlt. split. apply Hlt. split. apply Hlt.
    apply cardLe_to_ord_le...
  - intros [H𝜅 [H𝜆 Hlt]]. apply ord_le_to_cardLe...
Qed.

(* == implicit AC == *)
(* 无限基数是极限序数 *)
Lemma infcard_is_limit : 𝐂𝐃ⁱⁿᶠ ⫃ 𝐎𝐍ˡⁱᵐ.
Proof.
  intros 𝜅 [Hcd Hinf].
  apply initial_inford_is_limit; [|split; auto].
  destruct Hcd as [k Hk]. rewrite Hk.
  apply card_is_initord.
Qed.

(* 后继基数 *)
Notation "A ₊" := (HartogsNumber A) (at level 8, format "A ₊") : set_scope.

(* 后继基数是基数 *)
Lemma card_suc_is_card : ∀ A, A₊ ⋵ 𝐂𝐃.
Proof with eauto.
  intros.
  pose proof (hartog_spec_intro A) as [HoA [Hndom Hleast]].
  exists A₊. apply card_iff_initord. split...
  intros β Hβ. intros Hqn.
  assert (Hoβ: β ⋵ 𝐎𝐍). eapply ord_is_ords...
  assert (¬ β ≼ A). {
    intros H. apply Hndom.
    apply (dominate_rewrite_l _ β)... symmetry...
  }
  apply Hleast in H... eapply ord_not_le_gt; revgoals...
Qed.
Global Hint Immediate card_suc_is_card : core.

(* 后继基数是序数 *)
Corollary card_suc_is_ord : ∀ A, A₊ ⋵ 𝐎𝐍.
Proof.
  intros. apply card_is_ord. apply card_suc_is_card.
Qed.
Global Hint Immediate card_suc_is_ord : core.

(* 集合的基数小于其后继 *)
Lemma card_suc_has_card : ∀ A, |A| ∈ A₊.
Proof with auto; try easy.
  intros. unfold card.
  set (Min A₊ (MemberRel A₊)) as min.
  set {ξ ∊ A₊ | ξ ≈ A} as B.
  pose proof (hartog_spec_intro A) as [Hα [Hndom Hleast]].
  pose proof (min_correct A₊ (MemberRel A₊) B) as [Hm Hmin]... {
    apply ords_woset. intros b Hb. eapply ord_is_ords.
    apply hartog_spec_intro. apply Hb.
  } {
    exists (|A|). apply SepI...
    apply ord_lt_iff_not_sub...
    intros H. apply dominate_sub in H...
    apply (dominate_rewrite_r A) in H...
    rewrite <- CardAx0... rewrite <- CardAx0...
  } {
    intros x Hx. apply SepE1 in Hx...
  }
  apply SepE1 in Hm...
Qed.

(* 后继基数是大于该基数的最小基数 *)
Lemma card_suc_correct : ∀ A, ∀𝜅 ⋵ 𝐂𝐃, |A| ∈ 𝜅 → A₊ ⋸ 𝜅.
Proof with eauto.
  intros A 𝜅 Hcd HA𝜅.
  pose proof (hartog_spec_intro A) as [Ho [Hndom Hleast]].
  apply ord_lt_to_cardLt in HA𝜅...
  apply Hleast. apply card_is_ord...
  intros H𝜅A. apply cardLe_iff in H𝜅A.
  rewrite <- card_of_card in H𝜅A...
  eapply cardLe_to_not_gt...
Qed.

(* ex7_23 集合的哈特格斯数是该集合基数的后继基数 *)
Theorem hartogs_is_card_suc : ∀ A,
  (* i   *) A₊ ⋵ 𝐂𝐃 ∧
  (* ii  *) |A| ∈ A₊ ∧
  (* iii *) ∀𝜅 ⋵ 𝐂𝐃, |A| ∈ 𝜅 → A₊ ⋸ 𝜅.
Proof.
  intros. repeat split.
  - apply card_suc_is_card.
  - apply card_suc_has_card.
  - apply card_suc_correct.
Qed.

(* ex7_24 每个序数都有比它大的基数 *)
Theorem all_ord_ex_larger_card : ∀α ⋵ 𝐎𝐍, ∃𝜅 ⋵ 𝐂𝐃, α ∈ 𝜅.
Proof with auto.
  intros α Hα. exists α₊. split.
  apply card_suc_is_card.
  pose proof (card_suc_has_card α) as Hlt.
  apply ord_lt_to_cardLt in Hlt...
  rewrite (card_of_card α₊) in Hlt...
  apply cardLt_iff in Hlt as [Hdom Hnqn].
  apply ord_lt_iff_not_sub...
  intros H. apply dominate_sub in H.
  apply Hnqn. apply Schröeder_Bernstein...
Qed.

(* 不存在一个集合包括所有基数 *)
Corollary no_set_of_all_card : ¬ ∃ A, ∀𝜅 ⋵ 𝐂𝐃, 𝜅 ∈ A.
Proof with auto.
  intros [A H]. apply Burali_Forti.
  exists (⋃ A). intros α Hoα. apply UnionAx.
  apply all_ord_ex_larger_card in Hoα as [𝜅 [Hcd Hα]].
  exists 𝜅. split...
Qed.

(* 不存在一个集合包括所有无限基数 *)
Corollary no_set_of_all_infcard : ¬ ∃ A, ∀𝜅 ⋵ 𝐂𝐃ⁱⁿᶠ, 𝜅 ∈ A.
Proof with eauto.
  intros [A H]. apply Burali_Forti.
  exists (⋃ A). intros α Hoα. apply UnionAx.
  apply all_ord_ex_larger_card in Hoα as [𝜅 [H𝜅 Hα]].
  assert (Hcs: 𝜅 + ℵ₀ ⋵ 𝐂𝐃)...
  assert (Hos: (𝜅 + ℵ₀) ⋵ 𝐎𝐍)...
  apply all_ord_ex_larger_card in Hos as [𝜆 [H𝜆 Hlt]].
  exists 𝜆. split. apply H. split...
  - apply (parent_set_of_infinite_is_infinite (𝜅 + ℵ₀)).
    apply ord_le_iff_sub... apply cardAdd_infinite_iff...
  - eapply ord_trans...
    cut (𝜅 <𝐜 𝜆). apply cardLt_iff_ord_lt.
    eapply cardLe_lt_trans; revgoals.
    apply cardLt_iff_ord_lt... apply cardAdd_enlarge...
Qed.


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

(***
Modulus : 2^285 - 9
Base: 57
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 57;
    bitwidth := 64;
    s := 2^285;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 5); [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.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import VST.floyd.functional_base.
Require Import hmacdrbg.DRBG_functions.

Definition HMAC_DRBG_update (HMAC: list byte -> list byte -> list byte) (provided_data K V: list byte): (list byte * list byte) :=
  let K := HMAC (V ++ [Byte.zero] ++ provided_data) K in
  let V := HMAC V K in
  match provided_data with
    | [] => (K, V)
    | _::_ =>
      let K := HMAC (V ++ [Byte.one] ++ provided_data) K in
      let V := HMAC V K in
      (K, V)
  end.

Definition initial_key: list byte := repeat Byte.zero 32.

Definition initial_value: list byte := repeat Byte.one 32.

Definition HMAC_DRBG_instantiate_algorithm (HMAC: list byte -> list byte -> list byte)
           (entropy_input nonce personalization_string: list byte) (security_strength: Z): DRBG_working_state :=
  let seed_material := entropy_input ++ nonce ++ personalization_string in
  let key := initial_key in
  let value := initial_value in
  let (key, value) := HMAC_DRBG_update HMAC seed_material key value in
  let reseed_counter := 1 in
  (value, key, reseed_counter).

Definition HMAC_DRBG_reseed_algorithm (HMAC: list byte -> list byte -> list byte)
           (working_state: DRBG_working_state) (entropy_input additional_input: list byte): DRBG_working_state :=
  match working_state with (v, key, _) =>
                           let seed_material := entropy_input ++ additional_input in
                           let (key, v) := HMAC_DRBG_update HMAC seed_material key v in
                           let reseed_counter := 1 in
                           (v, key, reseed_counter)
  end.

Function HMAC_DRBG_generate_helper_Z (HMAC: list byte -> list byte -> list byte) (key v: list byte)
          (requested_number_of_bytes: Z) {measure Z.to_nat requested_number_of_bytes}: (list byte * list byte) :=
  if 0 >=? requested_number_of_bytes then (v, [])
  else
    let len := 32%nat in
    let (v, rest) := HMAC_DRBG_generate_helper_Z HMAC key v (requested_number_of_bytes - (Z.of_nat len)) in
    let v := HMAC v key in
    let temp := v in
    (v, rest ++ temp).
Proof.
  intros. rewrite Z2Nat.inj_sub by lia.
  rewrite Nat2Z.id.
  assert ((0 <? requested_number_of_bytes) = true).
  *
    rewrite Z.ltb_antisym.
    rewrite <- Z.geb_leb.
    rewrite teq.
    auto.
  *
  apply Zlt_is_lt_bool in H.
  apply Z2Nat.inj_lt in H; lia.
Defined.

Definition HMAC_DRBG_generate_algorithm (HMAC: list byte -> list byte -> list byte) (reseed_interval: Z)
           (working_state: DRBG_working_state) (requested_number_of_bytes: Z)
           (additional_input: list byte): DRBG_generate_algorithm_result :=
  match working_state with (v, key, reseed_counter) =>
    if reseed_counter >? reseed_interval then generate_algorithm_reseed_required
    else
      let (key, v) := match additional_input with
                        | [] => (key, v)
                        | _::_ => HMAC_DRBG_update HMAC additional_input key v
                      end in
      let (v, temp) := HMAC_DRBG_generate_helper_Z HMAC key v requested_number_of_bytes in
      let returned_bits := firstn (Z.to_nat requested_number_of_bytes) temp in
      let (key, v) := HMAC_DRBG_update HMAC additional_input key v in
      let reseed_counter := reseed_counter + 1 in
      generate_algorithm_success returned_bits (v, key, reseed_counter)
  end.


Require Import lattice.
Require Import Zee.lang.

Section Vals.
  Context {A : Set}.
  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition AtomSecTy := @AtomSecTy A.
  Definition Version := nat.

  Inductive SecTyV :=
  | ASTyV: AtomSecTyV -> SecTyV
  | ProdSecTyV: AtomSecTyV -> SecTyV -> SecTyV
  | NilTyV: SecTyV
  with AtomSecTyV :=
       | STyV: TyV -> A -> AtomSecTyV
       | NonSecTyV: AtomSecTyV
  with TyV :=
       | IntTV : TyV
       | PtrTV : A -> SecTyV -> TyV
       | SPtrTV : SecTyV -> SecTyV -> TyV
       | ExTyTV : string -> SecTy -> TyV
       | ExLabTV : string -> SecTy -> TyV
       | RecTyV: string -> SecTy -> TyV.
  Hint Constructors TyV SecTyV.

  Inductive V :=
  | VNum: nat -> V
  | VAddr: nat -> Version -> V
  | ExLab: A -> V -> V
  | ExTy: SecTyV -> V -> V.
  Hint Constructors V.
End Vals.

Coercion VNum : nat >-> V.
Coercion ASTyV : AtomSecTyV >-> SecTyV.


Definition ignore (n:nat) := tt.
Lemma ignore_S x : ignore (S x) = ignore x. exact eq_refl. Qed.

Goal ignore  125 = tt. Time rewrite !ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 0.108 secs (0.039u,0.068s) (successful) *)
(* Finished transaction in 0.066 secs (0.05u,0.016s) (successful) *)
Goal ignore  250 = tt. Time rewrite !ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 0.206 secs (0.204u,0.s) (successful) *)
(* Finished transaction in 0.172 secs (0.171u,0.s) (successful) *)
Goal ignore  500 = tt. Time rewrite !ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 0.769 secs (0.764u,0.001s) (successful) *)
(* Finished transaction in 0.686 secs (0.677u,0.006s) (successful) *)
Goal ignore 1000 = tt. Time rewrite !ignore_S. exact eq_refl. Time Qed.
(* Finished transaction in 3.011 secs (2.986u,0.009s) (successful) *)
(* Finished transaction in 2.674 secs (2.663u,0.s) (successful) *)

(* coqc experiments/bench/rewrite_ignore.v  7.99s user 0.14s system 99% cpu 8.168 total *)


Require Import Ascii String.
Require Import List. Import ListNotations.
Require Import Coq.Program.Basics.
Require Import Extraction.

Require Import OUVerT.dyadic.
Require Import MLCert.axioms.

Open Scope program_scope.

Definition print_nat : nat -> nat := id.
Extract Constant print_nat =>
"fun n ->
  let rec int_of_nat = function
    | O -> 0
    | S n' -> 1 + int_of_nat n'
  in (print_int (int_of_nat n); n)".

Definition print_D : D -> D := id.
Extract Constant print_D =>
"fun d ->
  let rec int_of_positive = function
    | XI p -> 2 * (int_of_positive p) + 1
    | XO p -> 2 * (int_of_positive p)
    | XH -> 1 in
  let int_of_z = function
    | Z0 -> 0
    | Zpos p -> int_of_positive p
    | Zneg p -> - (int_of_positive p) in
  let float_of_d d =
    float_of_int (int_of_z (num d)) /. (2.0 ** float_of_int (int_of_positive (den d))) in
(print_float (float_of_d d); d)".

Definition print_DRed : DRed.t -> DRed.t := id.
Extract Constant print_DRed =>
"fun d ->
  let rec int_of_positive = function
    | XI p -> 2 * (int_of_positive p) + 1
    | XO p -> 2 * (int_of_positive p)
    | XH -> 1 in
  let int_of_z = function
    | Z0 -> 0
    | Zpos p -> int_of_positive p
    | Zneg p -> - (int_of_positive p) in
  let float_of_d d =
    float_of_int (int_of_z (num d)) /. (2.0 ** float_of_int (int_of_positive (den d))) in
(print_float (float_of_d d); d)".

Definition print_newline : forall {X}, X -> X := fun _ x => x.
Extract Constant print_newline =>
"fun x -> print_newline (); x".

Definition print_ascii_nats : forall {X}, list nat -> X -> X := fun _ _ x => x.
Extract Constant print_ascii_nats =>
"fun l x ->
  let rec int_of_nat = function
    | O -> 0
    | S n' -> 1 + int_of_nat n'
  in
  List.iter (fun n -> print_char (Char.chr (int_of_nat n))) l; x".

Fixpoint string_ascii (s : string) : list ascii :=
  match s with
  | EmptyString => []
  | String x s' => x :: string_ascii s'
  end.

Definition print_string {X} : string -> X -> X :=
  print_ascii_nats ∘ (map nat_of_ascii) ∘ string_ascii.

Definition print_space {X} : X -> X := print_string " ".

Definition tuple_fun : forall {A B C}, (A -> B) -> (A -> C) -> A -> B*C :=
  fun _ _ _ f g x => (f x, g x).
(* Force left-to-right evaluation order... *)
Extract Constant tuple_fun =>
"fun f g x -> let a = f x in let b = g x in (a, b)".
Notation " f △ g " :=
  (tuple_fun f g) (at level 50, no associativity) : program_scope.

Definition print_pair {A B} (f : A -> A) (g : B -> B) : A*B -> A*B :=
  f ∘ fst △ g ∘ print_space ∘ snd.

(* Print a vector in machine-readable format. *)
Definition print_vector {A n} (f : A -> A) : AxVec n A -> AxVec n A :=
  AxVec_map (print_space ∘ f).

(* Print a matrix in machine-readable format. *)
Definition print_matrix {A n m} (f : A -> A) : AxMat A n m -> AxMat A n m :=
  AxVec_map (print_newline ∘ print_vector f).