Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Coq.Lists.List.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Require Import bedrock2.NotationsCustomEntry.
Require Import bedrock2.Syntax.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import bedrock2.Semantics.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.ReifiedOperation.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Spec.MxDH.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Translation.Parameters.SelectParameters.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Bedrock.Field.bls12prime.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Bedrock.Field.quadratic_extension_bls12.
Require Import Implementations.SOS.SOSReduction.
Require Import coqutil.Map.Properties.
Require Import bedrock2.Lift1Prop.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Theory.Fields.QuadraticFieldExtensions.
Require Import Theory.WordByWordMontgomery.MontgomeryRingTheory.
Require Import Bedrock.Util.Util.
Require Import MontgomeryCurveSpecs.
Require Import Bedrock.Util.Tactics.
Require Import Bedrock.Util.Bignum.
Require Import Bedrock.Util.Word.
Import Syntax.Coercions.
Local Open Scope string_scope.
Import ListNotations.
Local Open Scope Z_scope.

Section Spec.

(*Parameters to be changed: specify prime and import reification from cache.*)
    Require Import Bedrock.Examples.felem_copy_64.
    Local Definition felem_suffix := felem_copy_64.aff.
    Local Notation m := bls12prime.m.
    Local Definition prefix := "bls12_"%string. (* placed before function names *)
    Local Notation ar := (0 mod m).
    Local Notation ai := (0 mod m).
    Local Notation br := (4 mod m).
    Local Notation bi := (4 mod m).

    Existing Instances Defaults64.default_parameters bls12_bedrock2_funcs
    bls12_bedrock2_specs bls12_bedrock2_correctness.

    Existing Instance spec_of_my_add_alt2.
    Existing Instance spec_of_my_sub_alt2.
    Existing Instance spec_of_my_mul_alt2.

    Instance spec_of_reified_Fp2_mul :
    spec_of (append prefix "Fp2_mul") := spec_of_my_mul_alt2.
    Instance spec_of_reified_Fp2_add :
    spec_of (append prefix "Fp2_add") := spec_of_my_add_alt2.
    Instance spec_of_reified_Fp2_sub :
    spec_of (append prefix "Fp2_sub") := spec_of_my_sub_alt2.

(*  We instantiate specs of all imported bedrock2 functions.
    This needs to be done for typeclass inference to work properly.*)
  Instance spec_of_reified_mul :
  spec_of (append prefix "mul") := spec_of_mul.

  Instance spec_of_reified_square :
  spec_of (append prefix "square") := spec_of_square.

  Instance spec_of_reified_add :
  spec_of (append prefix "add") := spec_of_add.

  Instance spec_of_reified_sub :
  spec_of (append prefix "sub") := spec_of_sub.

  Instance spec_of_reified_opp :
  spec_of (append prefix "opp") := spec_of_opp.

  Instance spec_of_reified_to_montgomery :
  spec_of (append prefix "to_montgomery") := spec_of_to_montgomery.

  Instance spec_of_reified_from_montgomery :
  spec_of (append prefix "from_montgomery") := spec_of_from_montgomery.

  Instance spec_of_reified_nonzero :
  spec_of (append prefix "nonzero") := spec_of_nonzero.

  Instance spec_of_reified_selectznz :
  spec_of (append prefix "selectznz") := spec_of_selectznz.

  Instance spec_of_reified_to_bytes :
  spec_of (append prefix "to_bytes") := spec_of_to_bytes.

  Instance spec_of_reified_from_bytes :
  spec_of (append prefix "from_bytes") := spec_of_from_bytes.

  (*Instantiation done.*)

  (*Initializing parameters; do not touch*)
  Local Notation bw := (@width (semantics)).
  Local Notation m' := (@WordByWordMontgomery.m' m bw).
  Notation n := (WordByWordMontgomery.n m bw).
  Local Notation eval := (@WordByWordMontgomery.WordByWordMontgomery.eval bw n).
  Local Notation valid := (@WordByWordMontgomery.valid bw n m).
  Local Notation from_mont := (@WordByWordMontgomery.from_montgomerymod bw n m m').
  Local Notation to_mont := (@WordByWordMontgomery.to_montgomerymod bw n m m').
  Local Notation thisword := (@word semantics).
  Local Definition valid_words w := valid (List.map (@Interface.word.unsigned width thisword) w).
  Local Definition map_words := List.map (@Interface.word.unsigned width thisword).
  Local Notation r := (WordByWordMontgomery.r bw).
  Local Notation r' := (WordByWordMontgomery.r' m bw).
  Local Definition num_bytes := Eval compute in (Z.of_nat (((Z.to_nat bw * n) / 8)%nat)).
  Local Notation three_br := (3 * br mod m).
  Local Notation three_bi := (3 * bi mod m).
  Local Notation uw := (uweight 64).
  Definition three_br_list := (Partition.partition uw 6 (three_br)).
  Definition three_br_mont := Eval native_compute in (WordByWordMontgomery.to_montgomerymod bw n m m' three_br_list).
  Definition three_bi_list := (Partition.partition uw 6 three_bi).
  Definition three_bi_mont := Eval native_compute in (WordByWordMontgomery.to_montgomerymod bw n m m' three_bi_list).

  (*Some Notation*)
  Local Notation evfrom x := ((eval (from_mont (fst x)), eval (from_mont (snd x)))).
  Local Notation toZ x := (List.map Interface.word.unsigned x).

  Local Infix "*p2" := (mulp2 m) (at level 80).
  Local Infix "+p2" := (addp2 m) (at level 90).
  Local Infix "-p2" := (subp2 m) (at level 90).

  Local Notation evfrom_mod' := (@evfrom_mod'  m width n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
  Notation mod_pair x := ((fst x) mod m, (snd x) mod m).
  Definition small x := 0 <= x < m.
  Notation valid_pair x := ((valid (fst x)) /\ (valid (snd x))).
  Notation small_pair x := ((small (fst x)) /\ (small (snd x))).

  Local Infix "+Fp" := (montFp2_add m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big) (at level 190).
  Local Infix "*Fp" := (montFp2_mul m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big) (at level 200).
  Local Infix "-Fp" := (montFp2_sub m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big) (at level 200).

  Notation S aw := (word.add (word.of_Z word_size_in_bytes) aw).

  Notation montsub a b c :=
    ((eval (from_mont (a))) mod m =
        (eval (from_mont (b)) -
        eval (from_mont (c))) mod m).

  Notation montadd a b c :=
    ((eval (from_mont (a))) mod m =
        (eval (from_mont (b)) +
        eval (from_mont (c))) mod m).

  Notation montmul a b c :=
    ((eval (from_mont (a))) mod m =
        (eval (from_mont (b)) *
        eval (from_mont (c))) mod m).

  (*Lemmas of correctness of parameters to be used for montgomery arithmetic.*)
  Lemma r'_correct : (2 ^ bw * r') mod Spec.m = 1.
  Proof. auto with zarith. Qed.

  Lemma m'_correct : (Spec.m * m') mod 2 ^ bw = -1 mod 2 ^ bw.
  Proof. auto with zarith. Qed.

  Lemma bw_big : 0 < bw.
  Proof. unfold bw; simpl; lia. Qed.

  Lemma m_big : 1 < Spec.m.
  Proof. unfold m; lia. Qed.

  Lemma n_nz : n <> 0%nat.
  Proof. unfold n; simpl; auto with zarith. Qed.

  Lemma m_small : Spec.m < (2 ^ bw) ^ Z.of_nat n.
  Proof. unfold n, m; simpl; auto with zarith. Qed.

  Ltac wbw_conds :=
    repeat first [ progress apply r'_correct
                | progress apply m'_correct
                | progress apply bw_big
                | progress apply m_big
                | progress apply n_nz
                | progress apply m_small
                | progress apply m'_correct
                | progress apply m'_correct ].

  Lemma n_small : Z.of_nat n < 2 ^ bw.
  Proof. cbv. auto. Qed.

  Add Ring Mp2 : (montFp2_ring' m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).

  Local Notation toZ_ofZ_eq := (toZ_ofZ_eq n n_nz n_small m).
  Local Notation from_mont_correct := (@from_mont_correct m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
  Local Notation to_mont_correct := (@to_mont_correct m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
  Local Notation from_to_mont_inv := (@from_to_mont_inv m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
  Local Notation valid_mod := (valid_mod m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
  Local Notation mont_add := (mont_add m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
  Local Notation mont_sub := (mont_sub m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
  Local Notation mont_mul := (mont_mul m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
  Local Notation valid_valid'_equiv := (valid_valid'_equiv m bw n n_nz m_big).
  Local Notation evfrom_mod := (evfrom_mod' m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
  Local Notation eval_from_mont_inj := (eval_from_mont_inj m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
  Local Notation mont_zero := (mont_zero m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
  Local Notation wordof_Z := (@word.of_Z width (@word (@semantics Defaults64.default_parameters))).

  (*Lemmas/Tactics for parameters a and b*)
  Lemma three_br_mont_correct : three_br_mont = (WordByWordMontgomery.to_montgomerymod bw n m m' three_br_list).
  Proof.
    (vm_compute (WordByWordMontgomery.to_montgomerymod bw n m m' three_br_list)); reflexivity.
  Qed.

  Lemma three_br_valid: valid three_br_list.
  Proof.
    split; [cbv; auto| split; cbv; auto; intros; discriminate].
  Qed.

  Lemma three_br_mont_valid : valid three_br_mont.
  Proof.
    split; [cbv; auto| split; cbv; auto; intros; discriminate].
  Qed.

  Lemma three_bi_mont_correct : three_bi_mont = (WordByWordMontgomery.to_montgomerymod bw n m m' three_bi_list).
  Proof.
    (vm_compute (WordByWordMontgomery.to_montgomerymod bw n m m' three_bi_list)); reflexivity.
  Qed.

  Lemma three_bi_valid: valid three_bi_list.
  Proof.
    split; [cbv; auto| split; cbv; auto; intros; discriminate].
  Qed.

  Lemma three_bi_mont_valid : valid three_bi_mont.
  Proof.
    split; [cbv; auto| split; cbv; auto; intros; discriminate].
  Qed.

  Lemma valid_toZ_wordofZ_three_br_mont : valid (toZ (map wordof_Z three_br_mont)).
  Proof.
    rewrite toZ_ofZ_eq; apply three_br_mont_valid.
  Qed.

  Lemma valid_toZ_wordofZ_three_bi_mont : valid (toZ (map wordof_Z three_bi_mont)).
  Proof.
    rewrite toZ_ofZ_eq; apply three_bi_mont_valid.
  Qed.

  Lemma ai_small : ai mod m = ai.
  Proof. cbv; auto. Qed.

  Lemma ar_small : ar mod m = ar.
  Proof. cbv; auto. Qed.

  Lemma three_br_small : three_br = three_br mod m.
  Proof. cbv. auto. Qed.

  Lemma three_bi_small : three_bi = three_bi mod m.
  Proof. cbv. auto. Qed.

  Lemma remember_three_b H : ((enc_mont_pair m bw n (toZ (map wordof_Z three_br_mont), toZ (map wordof_Z three_bi_mont)) H)
    = (three_bp2 m bw n r' m' three_bi three_bi three_br_small three_bi_small r'_correct m'_correct bw_big n_nz m_small m_big)).
  Proof.
    apply pair_equal_spec; split; apply mont_enc_irr; rewrite mont_enc_val; [rewrite Prod.fst_pair| rewrite Prod.snd_pair];
    rewrite toZ_ofZ_eq; [unfold MontgomeryCurveSpecs.three_br_mont|apply three_br_mont_valid| unfold MontgomeryCurveSpecs.three_bi_mont |apply three_bi_mont_valid];
    rewrite mont_enc_val; [unfold three_br_mont_list; rewrite three_br_mont_correct| unfold three_bi_mont_list; rewrite three_bi_mont_correct];
    apply (f_equal (fun y => to_mont y)); cbv; auto.
  Qed.

  Local Notation Mp2_O := (MontgomeryRingTheory.montFp2_zero m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).

  Lemma remember_ap2 : (((ap2 m bw n r' m' 0 0 ar_small ai_small r'_correct m'_correct bw_big n_nz m_small m_big) = Mp2_O)).
  Proof.
    apply pair_equal_spec; split; unfold ar_mont, ai_mont; apply mont_enc_irr;
    rewrite !mont_enc_val; unfold ar_mont_list, ai_mont_list; unfold mont_zero;
    rewrite mont_enc_val; unfold ar_list, ai_list; apply (f_equal (fun y => to_mont y)); cbv; auto.
  Qed.

  (*Gallina specs
    Note that we use 2 different specs; one is more general and proven correct in Fiats library.
    The other is correct only when the parameter a is 0; which is the case here.
    Their equivalence is shown below.*)
  Definition BLS12_add_Gallina_spec X1r X1i Y1r Y1i Z1r Z1i X2r X2i Y2r Y2i Z2r Z2i outxr outxi outyr outyi outzr outzi :=
    @BLS12_G2_add_Gallina_spec m bw n m' 0 0 three_br three_bi (X1r, X1i) (Y1r, Y1i) (Z1r, Z1i) (X2r, X2i) (Y2r, Y2i) (Z2r, Z2i) (outxr, outxi) (outyr, outyi) (outzr, outzi).

  (*Bedrock2 Function Definition*)
  Definition BLS12_add : Syntax.func :=
      let outxr := "outxr" in
      let outyr := "outyr" in
      let outzr := "outzr" in

      let X1r := "X1r" in
      let Y1r := "Y1r" in
      let Z1r := "Z1r" in

      let X2r := "X2r" in
      let Y2r := "Y2r" in
      let Z2r := "Z2r" in

      let t0r := "t0r" in
      let t1r := "t1r" in
      let t2r := "t2r" in
      let t3r := "t3r" in
      let t4r := "t4r" in
      let t5r := "t5r" in
      let three_br := "three_br" in

      let outxi := "outxi" in
      let outyi := "outyi" in
      let outzi := "outzi" in

      let X1i := "X1i" in
      let Y1i := "Y1i" in
      let Z1i := "Z1i" in

      let X2i := "X2i" in
      let Y2i := "Y2i" in
      let Z2i := "Z2i" in

      let t0i := "t0i" in
      let t1i := "t1i" in
      let t2i := "t2i" in
      let t3i := "t3i" in
      let t4i := "t4i" in
      let t5i := "t5i" in
      let three_bi := "three_bi" in

      let add := ("Fp2_add_alt2") in
      let mul := ("Fp2_mul_alt2") in
      let sub := ("Fp2_sub_alt2") in
      ("BLS12_G2_add", (
        [outxr; outxi; outyr; outyi; outzr; outzi; X1r; X1i; Y1r; Y1i; Z1r; Z1i; X2r; X2i; Y2r; Y2i; Z2r; Z2i], [],
        bedrock_func_body:(
        stackalloc num_bytes as three_br{
          stackalloc num_bytes as t0r {
            stackalloc num_bytes as t1r {
              stackalloc num_bytes as t2r {
                stackalloc num_bytes as t3r {
                  stackalloc num_bytes as t4r {
                    stackalloc num_bytes as t5r {
                      stackalloc num_bytes as three_bi{
                        stackalloc num_bytes as t0i {
                          stackalloc num_bytes as t1i {
                            stackalloc num_bytes as t2i {
                              stackalloc num_bytes as t3i {
                                stackalloc num_bytes as t4i {
                                  stackalloc num_bytes as t5i {
                                    store(three_br, (coq:(nth 0 three_br_mont 0)));
                                    store(three_br + coq:(8), coq:(nth 1 three_br_mont 0));
                                    store(three_br + coq:(16), coq:(nth 2 three_br_mont 0));
                                    store(three_br + coq:(24), coq:(nth 3 three_br_mont 0));
                                    store(three_br + coq:(32), coq:(nth 4 three_br_mont 0));
                                    store(three_br + coq:(40), coq:(nth 5 three_br_mont 0));
                                    store(three_bi, (coq:(nth 0 three_bi_mont 0)));
                                    store(three_bi + coq:(8), coq:(nth 1 three_bi_mont 0));
                                    store(three_bi + coq:(16), coq:(nth 2 three_bi_mont 0));
                                    store(three_bi + coq:(24), coq:(nth 3 three_bi_mont 0));
                                    store(three_bi + coq:(32), coq:(nth 4 three_bi_mont 0));
                                    store(three_bi + coq:(40), coq:(nth 5 three_bi_mont 0));
                                    mul (t0r, t0i, X1r, X1i, X2r, X2i);
                                    mul (t1r, t1i, Y1r, Y1i, Y2r, Y2i);
                                    mul (t2r, t2i, Z1r, Z1i, Z2r, Z2i);
                                    add (t3r, t3i, X1r, X1i, Y1r, Y1i);
                                    add (t4r, t4i, X2r, X2i, Y2r, Y2i);
                                    mul (t3r, t3i, t3r, t3i, t4r, t4i);
                                    add (t4r, t4i, t0r, t0i, t1r, t1i);
                                    sub (t3r, t3i, t3r, t3i, t4r, t4i);
                                    add (t4r, t4i, X1r, X1i, Z1r, Z1i);
                                    add (t5r, t5i, X2r, X2i, Z2r, Z2i);
                                    mul (t4r, t4i, t4r, t4i, t5r, t5i);
                                    add (t5r, t5i, t0r, t0i, t2r, t2i);
                                    sub (t4r, t4i, t4r, t4i, t5r, t5i);
                                    add (t5r, t5i, Y1r, Y1i, Z1r, Z1i);
                                    add (outxr, outxi, Y2r, Y2i, Z2r, Z2i);
                                    mul (t5r, t5i, t5r, t5i, outxr, outxi);
                                    add (outxr, outxi, t1r, t1i, t2r, t2i);
                                    sub (t5r, t5i, t5r, t5i, outxr, outxi);
                                    mul (outzr, outzi, three_br, three_bi, t2r, t2i);
                                    sub (outxr, outxi, t1r, t1i, outzr, outzi);
                                    add (outzr, outzi, outzr, outzi, t1r, t1i);
                                    mul (outyr, outyi, outxr, outxi, outzr, outzi);
                                    add (t1r, t1i, t0r, t0i, t0r, t0i);
                                    add (t1r, t1i, t1r, t1i, t0r, t0i);
                                    mul (t4r, t4i, three_br, three_bi, t4r, t4i);
                                    mul (t0r, t0i, t1r, t1i, t4r, t4i);
                                    add (outyr, outyi, outyr, outyi, t0r, t0i);
                                    mul (t0r, t0i, t5r, t5i, t4r, t4i);
                                    mul (outxr, outxi, t3r, t3i, outxr, outxi);
                                    sub (outxr, outxi, outxr, outxi, t0r, t0i);
                                    mul (t0r, t0i, t3r, t3i, t1r, t1i);
                                    mul (outzr, outzi, t5r, t5i, outzr, outzi);
                                    add (outzr, outzi, outzr, outzi, t0r, t0i)
                                  }
                                }
                              }
                            }
                          }
                        }
                      }
                    }
                  }
                }
              }
            }
          }
        }
        )
      )).

  Local Open Scope string_scope.
  Local Infix "*" := sep : sep_scope.
  Delimit Scope sep_scope with sep.

  (*Bedrock2 function Spec*)
  Instance spec_of_BLS12_add: spec_of BLS12_add :=
  fun functions : list (string * (list string * list string * cmd)) =>
      forall (wX1r wY1r wZ1r wX2r wY2r wZ2r wX1i wY1i wZ1i wX2i wY2i wZ2i : list Interface.word.rep)
      (pX1r pY1r pZ1r pX2r pY2r pZ2r pX1i pY1i pZ1i pX2i pY2i pZ2i poutxr poutyr poutzr poutxi poutyi poutzi: Interface.word.rep)
      (wold_outxr wold_outyr wold_outzr wold_outxi wold_outyi wold_outzi: list Interface.word.rep) (t : Semantics.trace)
      (m0 : Interface.map.rep) (Rout : Interface.map.rep -> Prop),
      valid (List.map Interface.word.unsigned wX1r) /\
      valid (List.map Interface.word.unsigned wY1r) /\
      valid (List.map Interface.word.unsigned wZ1r) /\
      valid (List.map Interface.word.unsigned wX2r) /\
      valid (List.map Interface.word.unsigned wY2r) /\
      valid (List.map Interface.word.unsigned wZ2r) /\
      valid (List.map Interface.word.unsigned wX1i) /\
      valid (List.map Interface.word.unsigned wY1i) /\
      valid (List.map Interface.word.unsigned wZ1i) /\
      valid (List.map Interface.word.unsigned wX2i) /\
      valid (List.map Interface.word.unsigned wY2i) /\
      valid (List.map Interface.word.unsigned wZ2i) ->
      ((Bignum n pX1r wX1r) *
      (Bignum n pX2r wX2r) *
      (Bignum n pY1r wY1r) *
      (Bignum n pY2r wY2r) *
      (Bignum n pZ1r wZ1r) *
      (Bignum n pZ2r wZ2r) *
      (Bignum n pX1i wX1i) *
      (Bignum n pX2i wX2i) *
      (Bignum n pY1i wY1i) *
      (Bignum n pY2i wY2i) *
      (Bignum n pZ1i wZ1i) *
      (Bignum n pZ2i wZ2i) *
      (Bignum n poutxr wold_outxr) * (Bignum n poutyr wold_outyr) * (Bignum n poutzr wold_outzr) *
      (Bignum n poutxi wold_outxi) * (Bignum n poutyi wold_outyi) * (Bignum n poutzi wold_outzi) * Rout)%sep m0 ->
      WeakestPrecondition.call functions ( "BLS12_G2_add") t m0
      ([poutxr; poutxi; poutyr; poutyi; poutzr; poutzi; pX1r; pX1i; pY1r; pY1i; pZ1r; pZ1i; pX2r; pX2i; pY2r; pY2i; pZ2r; pZ2i])
      (fun (t' : Semantics.trace) (m' : Interface.map.rep)
          (rets : list Interface.word.rep) =>
      t = t' /\
      rets = nil /\
      (exists (woutxr woutyr woutzr woutxi woutyi woutzi: list Interface.word.rep) Rout,
          (
                  (BLS12_add_Gallina_spec (toZ wX1r) (toZ wX1i) (toZ wY1r) (toZ wY1i) (toZ wZ1r) (toZ wZ1i) (toZ wX2r)
                  (toZ wX2i) (toZ wY2r) (toZ wY2i)
                  (toZ wZ2r) (toZ wZ2i) (toZ woutxr) (toZ woutxi) (toZ woutyr) (toZ woutyi) (toZ woutzr) (toZ woutzi) /\
              ((Bignum n pX1r wX1r) *
              (Bignum n pX2r wX2r) *
              (Bignum n pY1r wY1r) *
              (Bignum n pY2r wY2r) *
              (Bignum n pZ1r wZ1r) *
              (Bignum n pX1i wX1i) *
              (Bignum n pX2i wX2i) *
              (Bignum n pY1i wY1i) *
              (Bignum n pY2i wY2i) *
              (Bignum n pZ1i wZ1i) *
              (Bignum n pZ2r wZ2r) *
              (Bignum n pZ2i wZ2i) *
              (Bignum n poutxr woutxr) * (Bignum n poutyr woutyr) * (Bignum n poutzr woutzr) *
              (Bignum n poutxi woutxi) * (Bignum n poutyi woutyi) * (Bignum n poutzi woutzi) * Rout)%sep m')))).

  (*Lemmas/Tactics for handling Bignum/Scalar/many_Scalars*)
  Notation msplit := Interface.map.split.

  Ltac get_list_from_length l :=
    (repeat (destruct l; [discriminate| ])); destruct l; [| discriminate].

  Ltac Bignum_to_Scalars l := let Hsep := (fresh "Hsep") in
  eassert (Hsep : (Bignum n _ l * _)%sep _) by ecancel_assumption;
  apply Bignum_manyScalars_R in Hsep; sepsimpl_hyps; get_list_from_length l;
  lazymatch goal with
  | [H : (many_Scalars n _ _ * _)%sep _ |- _] => let Htemp := (fresh "Htemp") in
    eassert (Htemp : many_Scalars n _ _ = many_Scalars _ _ _) by (vm_compute n; auto);
    rewrite Htemp in H; clear Htemp;
    repeat rewrite many_Scalars_next in H;
    rewrite many_Scalars_nil in H
  | _ => fail
  end.

  Ltac straightline' :=
    match goal with
    | [Hminit : ?mcond (?minit : @Interface.map.rep _ _ _)
        |- forall (_ : @word.rep _ _)
                  (_ _ : @Interface.map.rep _ _ _),
            anybytes _ ?numbytes _ -> msplit _ ?minit _ -> _ ] =>
        let a := (fresh "a") in
        let mStack := (fresh "mStack") in
        let mnew := (fresh "mnew") in
        let Hany := (fresh "Hany") in
        let HanyBignum := (fresh "HanyBignum") in
        let anyval := (fresh "anyval") in
        let Hsplit := (fresh "Hsplit") in
        let Hmnew := (fresh "Hmnew") in
        let R := (fresh "R") in
        intros a mStack mnew Hany Hsplit; destruct (anybytes_Bignum mStack a Hany) as [anyval HanyBignum];
        destruct (alloc_seps_alt mnew minit mStack mcond (Bignum _ _ _) Hsplit (empty_frame mcond minit Hminit) (empty_frame (Bignum _ _ _) mStack HanyBignum)) as [R Hmnew];
        clear Hany Hsplit HanyBignum
    | _ => straightline
    end.

  (*Tactics to handle stores*)
  Ltac subst_vars :=
    lazymatch goal with
    | [|- WeakestPrecondition.store _ _ ?thisa _ _] =>
      try subst thisa
    end.

  Ltac handle_store_step :=
    lazymatch goal with
      | [ |- ((Scalars.scalar ?thisa _) * _)%sep _ ] =>
      try subst thisa; repeat (rewrite next_word'; try (rewrite word_add_0)); ecancel_assumption
    end.

  Ltac handle_store :=
    repeat (subst_vars; eapply Scalars.store_word_of_sep; [handle_store_step|]; repeat straightline'); clear_old_seps.

  (*Tactic for function calls*)
  Ltac next_call :=
    lazymatch goal with
      | [H' : (_ * _)%sep _ |- _] =>
      straightline_call; [|ecancel_assumption | ecancel_assumption| ecancel_assumption| ecancel_assumption| ecancel_assumption|]; [split; [assumption| split; [assumption| split; assumption]]|]; repeat straightline; clear H'
      | _ => idtac
        end.

  (*Tactics to handle stack allocation*)
  Lemma alloc_anybytes_Bignum n0 : forall (R : Interface.map.rep -> Prop) a m m0 m1, n0 = Z.of_nat (n * Z.to_nat word_size_in_bytes) -> msplit m m0 m1 -> anybytes a n0 m1 -> R m0 -> exists l, (R * (Bignum n a l))%sep m.
  Proof.
    intros.
    pose proof (anybytes_Bignum n m1 n0 a).
    apply H3 in H1; [| cbv; auto].
    destruct H1. exists x. unfold sep. exists m0. exists m1. auto.
  Qed.

  Ltac alloc_Bignum := lazymatch goal with
    | Hprec : _ ?mpre |- forall _ _ _, anybytes _ ?n0 _ ->
      msplit _ ?mpre _ -> _ =>
      let a := (fresh "a") in
      let mStack := (fresh "mStack") in
      let mComb := (fresh "mComb") in
      let Hany := (fresh "Hany") in
      let Hcomb := (fresh "Hcomb") in
      let Htemp := (fresh "Htemp") in
      intros a mStack mComb Hany Hcomb;
      assert (Htemp : n0 = Z.of_nat (n * Z.to_nat word_size_in_bytes)) by (cbv; auto);
      destruct (alloc_anybytes_Bignum n0 _ a mComb mpre mStack Htemp Hcomb Hany Hprec); clear Htemp Hprec Hany
    | _ => idtac
    end.

  Ltac straightline_stackalloc_Bignum := try (alloc_Bignum); straightline.

  (*Lemmas and tactics casting return values from function calls to Mp2 elements*)
  Lemma montmul_to_Mp2 : forall x y z Hx Hy Hz, Fp2_mul_Gallina_spec x y z -> enc_mont_pair m bw n z Hz = montFp2_mul m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big
  (enc_mont_pair m bw n x Hx) (enc_mont_pair m bw n y Hy).
  Proof.
    intros [pr pi] [yr yi] [zr zi] Hx Hy Hz [_ [_ [H'1 H'2]]].
    apply pair_equal_spec; split; apply eval_from_mont_inj.
      - rewrite mont_enc_val. rewrite Prod.fst_pair. rewrite Prod.fst_pair in H'1.
        rewrite H'1. rewrite !Prod.fst_pair, !Prod.snd_pair.
        pose proof (mont_sub_spec m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
        rewrite H. rewrite !mont_mul_spec.
        assert (Htempfst : forall y z H, val m bw n (fst (enc_mont_pair m bw n (y, z) H)) = y) by reflexivity.
        assert (Htempsnd : forall y z H, val m bw n (snd (enc_mont_pair m bw n (y, z) H)) = z) by reflexivity.
        rewrite !Htempfst, !Htempsnd. apply Zminus_mod.
      - rewrite mont_enc_val. rewrite Prod.snd_pair. rewrite Prod.snd_pair in H'2.
        rewrite H'2. rewrite !Prod.fst_pair, !Prod.snd_pair.
        pose proof (mont_add_spec m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
        rewrite H. rewrite !mont_mul_spec.
        assert (Htempfst : forall y z H, val m bw n (fst (enc_mont_pair m bw n (y, z) H)) = y) by reflexivity.
        assert (Htempsnd : forall y z H, val m bw n (snd (enc_mont_pair m bw n (y, z) H)) = z) by reflexivity.
        rewrite !Htempfst, !Htempsnd. rewrite <- Zplus_mod. apply (f_equal (fun y => y mod m)). ring.
  Qed.

  Lemma montsub_to_Mp2 : forall x y z Hx Hy Hz, Fp2_sub_Gallina_spec x y z -> enc_mont_pair m bw n z Hz = montFp2_sub m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big
      (enc_mont_pair m bw n x Hx) (enc_mont_pair m bw n y Hy).
  Proof.
    intros [pr pi] [yr yi] [zr zi] Hx Hy Hz [_ [_ [H'1 H'2]]].
    apply pair_equal_spec; split; apply eval_from_mont_inj.
      - rewrite mont_enc_val. rewrite Prod.fst_pair. rewrite Prod.fst_pair in H'1.
        rewrite H'1. rewrite !Prod.fst_pair.
        pose proof (mont_sub_spec m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
        rewrite H.
        assert (Htempfst : forall y z H, val m bw n (fst (enc_mont_pair m bw n (y, z) H)) = y) by reflexivity.
        assert (Htempsnd : forall y z H, val m bw n (snd (enc_mont_pair m bw n (y, z) H)) = z) by reflexivity.
        rewrite !Htempfst. reflexivity.
      - rewrite mont_enc_val. rewrite Prod.snd_pair. rewrite Prod.snd_pair in H'2.
        rewrite H'2. rewrite !Prod.snd_pair.
        pose proof (mont_sub_spec m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
        rewrite H.
        assert (Htempfst : forall y z H, val m bw n (fst (enc_mont_pair m bw n (y, z) H)) = y) by reflexivity.
        assert (Htempsnd : forall y z H, val m bw n (snd (enc_mont_pair m bw n (y, z) H)) = z) by reflexivity.
        rewrite !Htempsnd. reflexivity.
  Qed.

  Lemma montadd_to_Mp2 : forall x y z Hx Hy Hz, Fp2_add_Gallina_spec x y z -> enc_mont_pair m bw n z Hz = montFp2_add m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big
  (enc_mont_pair m bw n x Hx) (enc_mont_pair m bw n y Hy).
  Proof.
    intros [pr pi] [yr yi] [zr zi] Hx Hy Hz [_ [_ [H'1 H'2]]].
    apply pair_equal_spec; split; apply eval_from_mont_inj.
      - rewrite mont_enc_val. rewrite Prod.fst_pair. rewrite Prod.fst_pair in H'1.
        rewrite H'1. rewrite !Prod.fst_pair.
        pose proof (mont_add_spec m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
        rewrite H.
        assert (Htempfst : forall y z H, val m bw n (fst (enc_mont_pair m bw n (y, z) H)) = y) by reflexivity.
        assert (Htempsnd : forall y z H, val m bw n (snd (enc_mont_pair m bw n (y, z) H)) = z) by reflexivity.
        rewrite !Htempfst. reflexivity.
      - rewrite mont_enc_val. rewrite Prod.snd_pair. rewrite Prod.snd_pair in H'2.
        rewrite H'2. rewrite !Prod.snd_pair.
        pose proof (mont_add_spec m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
        rewrite H.
        assert (Htempfst : forall y z H, val m bw n (fst (enc_mont_pair m bw n (y, z) H)) = y) by reflexivity.
        assert (Htempsnd : forall y z H, val m bw n (snd (enc_mont_pair m bw n (y, z) H)) = z) by reflexivity.
        rewrite !Htempsnd. reflexivity.
  Qed.

  Ltac assert_valid_pair xr xi := let Hv := (fresh "Hv") in
  assert (Hv : valid'_pair m bw n (toZ xr, toZ xi)) by (split; (apply valid_valid'_equiv; assumption)).

  (*Tactics to use return values from function calls*)
  Local Notation valid'_pair := (valid'_pair m bw n).

  Ltac assert_valid_tac := split; [rewrite Prod.fst_pair| rewrite Prod.snd_pair]; apply valid_valid'_equiv; assumption.

  Ltac assert_valid_pair_new x H :=
    tryif (assert (H : valid'_pair x) by assumption; clear H) then idtac else (assert (H : valid'_pair x) by (assert_valid_tac)).

  Ltac use_return_values z :=
      lazymatch goal with
      | H1 : Fp2_sub_Gallina_spec ?x ?y z |- _ => let Htemp := (fresh "Htemp") in let Htemp' := (fresh "Htemp") in
      assert_valid_pair_new y Htemp;
      assert_valid_pair_new x Htemp';
      lazymatch goal with | Hx : valid'_pair x |- _ => lazymatch goal with Hy : valid'_pair y |- _ =>
      rewrite (montsub_to_Mp2 x y z Hx Hy) end end; [| apply H1]; try (use_return_values y); try (use_return_values x)
      | H1 : Fp2_add_Gallina_spec ?x ?y z |- _ => let Htemp := (fresh "Htemp") in let Htemp' := (fresh "Htemp") in
      assert_valid_pair_new y Htemp;
      assert_valid_pair_new x Htemp';
      lazymatch goal with | Hx : valid'_pair x |- _ => lazymatch goal with Hy : valid'_pair y |- _ =>
      rewrite (montadd_to_Mp2 x y z Hx Hy) end end; [| apply H1]; try (use_return_values y); try (use_return_values x)
      | H1 : Fp2_mul_Gallina_spec ?x ?y z |- _ => let Htemp := (fresh "Htemp") in let Htemp' := (fresh "Htemp") in
      assert_valid_pair_new y Htemp;
      assert_valid_pair_new x Htemp';
      lazymatch goal with | Hx : valid'_pair x |- _ => lazymatch goal with Hy : valid'_pair y |- _ =>
      rewrite (montmul_to_Mp2 x y z Hx Hy) end end; [| apply H1]; try (use_return_values y); try (use_return_values x)
      | _ => idtac
      end.

  Theorem G2_add_func_ok : program_logic_goal_for_function! BLS12_add.
  Proof.
    (*initialize proof*)
    repeat straightline_stackalloc_Bignum.
    repeat straightline'.

    (*Store three_br*)
    Bignum_to_Scalars x. clear H33.
    handle_store.
    eassert ( (Bignum n a (List.map wordof_Z three_br_mont) * _)%sep _).
    {
      unfold Bignum. sepsimpl; [ cbv; auto|]. unfold array. cbv [three_br_mont map].
      repeat rewrite (word_add_comm _ (word.of_Z word_size_in_bytes)).
      repeat (rewrite next_word' in H51; try rewrite word_add_0 in H51).
      ecancel_assumption.
    }
    clear H51.

    (*store three_bi*)
    Bignum_to_Scalars x6. clear H33.
    handle_store.
    eassert ( (Bignum n a6 (List.map wordof_Z three_bi_mont) * _)%sep _).
    {
      unfold Bignum. sepsimpl; [ cbv; auto|]. unfold array. cbv [three_bi_mont map].
      repeat rewrite (word_add_comm _ (word.of_Z word_size_in_bytes)).
      repeat (rewrite next_word' in H52; try rewrite word_add_0 in H52).
      ecancel_assumption.
    }
    clear H52.

    rename H33 into H'.
    repeat straightline'.

    (*Preconditions of callees must be in context for function calls to handled automatically by the "next_call" tactic*)
    pose proof valid_toZ_wordofZ_three_br_mont.
    pose proof valid_toZ_wordofZ_three_bi_mont.

    (*Handle function calls.*)
    next_call.
    do 5 next_call.
    repeat next_call.

    (*Defragment allocated memory in context*)
    repeat (defrag_in_context (WordByWordMontgomery.n Spec.m bw)).
    repeat straightline.

    (*Postcondition*)
    (*Trivial subgoals are handled first*)
    do 2 (split; [reflexivity| ]).
    do 7 eexists; split; [| ecancel_assumption].

    (*Gallina specification part of postcondition*)
    unfold BLS12_add_Gallina_spec.

    (*Inputs/Outputs are valid elements of Mp2*)
    assert_valid_pair wX1r wX1i.
    assert_valid_pair wX2r wX2i.

    assert_valid_pair wY1r wY1i.
    assert_valid_pair wY2r wY2i.

    assert_valid_pair wZ1r wZ1i.
    assert_valid_pair wZ2r wZ2i.

    assert_valid_pair x86 x87.
    assert_valid_pair x77 x78.
    assert_valid_pair x95 x96.

    (*Use alternative curve spec*)
    destruct (MontgomeryCurveSpecs.BLS12_G2_add_Specs_equiv' m bw n r' m' 0 0 three_br three_bi ar_small ai_small three_br_small three_bi_small
      r'_correct m'_correct bw_big n_nz m_small m_big _ _ _ _ _ _ _ _ _ Hv Hv0 Hv1 Hv2 Hv3 Hv4 Hv5 Hv6 Hv7) as [Hequiv _].
    apply Hequiv; clear Hequiv.
    unfold BLS12_G2_add_mont_spec.

    (*Use return values from function calls*)
    use_return_values (toZ x86, toZ x87).
    use_return_values (toZ x77, toZ x78).
    use_return_values (toZ x95, toZ x96).

    (*Alias ring elements to help ring tactic solve goal*)
    rewrite remember_ap2.
    rewrite <- (remember_three_b Htemp4).
    remember (enc_mont_pair m bw n (toZ (map wordof_Z three_br_mont), toZ (map wordof_Z three_bi_mont)) Htemp4) as tb.
    remember (enc_mont_pair m bw n (toZ wY1r, toZ wY1i) Hv1) as y1.
    remember (enc_mont_pair m bw n (toZ wY2r, toZ wY2i) Hv2) as y2.
    remember (enc_mont_pair m bw n (toZ wX1r, toZ wX1i) Hv) as p1.
    remember (enc_mont_pair m bw n (toZ wX2r, toZ wX2i) Hv0) as p2.
    remember (enc_mont_pair m bw n (toZ wZ1r, toZ wZ1i) Hv3) as z1.
    remember (enc_mont_pair m bw n (toZ wZ2r, toZ wZ2i) Hv4) as z2.

    (*Equality of each coordinate is solved by ring tactic*)
    apply pair_equal_spec; split; [apply pair_equal_spec; split|]; try ring.
  Qed.

(*Variant that allows overlapping inputs/outputs*)
  (*Bedrock2 Function Definition*)
  Definition BLS12_add_alt : Syntax.func :=
      let outxr := "outxr" in
      let outyr := "outyr" in
      let outzr := "outzr" in

      let X1r := "X1r" in
      let Y1r := "Y1r" in
      let Z1r := "Z1r" in

      let X2r := "X2r" in
      let Y2r := "Y2r" in
      let Z2r := "Z2r" in

      let X1rsep := "X1rsep" in
      let Y1rsep := "Y1rsep" in
      let Z1rsep := "Z1rsep" in

      let X2rsep := "X2rsep" in
      let Y2rsep := "Y2rsep" in
      let Z2rsep := "Z2rsep" in

      let outxi := "outxi" in
      let outyi := "outyi" in
      let outzi := "outzi" in

      let X1i := "X1i" in
      let Y1i := "Y1i" in
      let Z1i := "Z1i" in

      let X2i := "X2i" in
      let Y2i := "Y2i" in
      let Z2i := "Z2i" in

      let X1isep := "X1isep" in
      let Y1isep := "Y1isep" in
      let Z1isep := "Z1isep" in

      let X2isep := "X2isep" in
      let Y2isep := "Y2isep" in
      let Z2isep := "Z2isep" in

      let BLS12_G2_add := "BLS12_G2_add" in
      let felem_copy := ("felem_copy" ++ felem_suffix) in
      ("BLS12_G2_add_alt", (
        [outxr; outxi; outyr; outyi; outzr; outzi; X1r; X1i; Y1r; Y1i; Z1r; Z1i;
            X2r; X2i; Y2r; Y2i; Z2r; Z2i], [],
        bedrock_func_body:(

        stackalloc num_bytes as X1rsep {
        stackalloc num_bytes as X1isep {
        stackalloc num_bytes as Y1rsep {
        stackalloc num_bytes as Y1isep {
        stackalloc num_bytes as Z1rsep {
        stackalloc num_bytes as Z1isep {
        stackalloc num_bytes as X2rsep {
        stackalloc num_bytes as X2isep {
        stackalloc num_bytes as Y2rsep {
        stackalloc num_bytes as Y2isep {
        stackalloc num_bytes as Z2rsep {
        stackalloc num_bytes as Z2isep {

            (*copying X1*)
            felem_copy( X1rsep, X1r);
            felem_copy( X1isep, X1i);
            felem_copy( Y1rsep, Y1r);
            felem_copy( Y1isep, Y1i);
            felem_copy( Z1rsep, Z1r);
            felem_copy( Z1isep, Z1i);
            felem_copy( X2rsep, X2r);
            felem_copy( X2isep, X2i);
            felem_copy( Y2rsep, Y2r);
            felem_copy( Y2isep, Y2i);
            felem_copy( Z2rsep, Z2r);
            felem_copy( Z2isep, Z2i);

            BLS12_G2_add (outxr, outxi, outyr, outyi, outzr, outzi, X1rsep, X1isep, Y1rsep, Y1isep,
              Z1rsep, Z1isep, X2rsep, X2isep, Y2rsep, Y2isep, Z2rsep, Z2isep)
          }}}}}}}}}}}}
        )
      )).

Local Open Scope string_scope.
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.

(*Bedrock2 function Spec*)

Instance spec_of_BLS12_add_alt: spec_of BLS12_add_alt :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (wX1r wY1r wZ1r wX2r wY2r wZ2r wX1i wY1i wZ1i wX2i wY2i wZ2i : list Interface.word.rep)
    (pX1r pY1r pZ1r pX2r pY2r pZ2r pX1i pY1i pZ1i pX2i pY2i pZ2i poutxr poutyr poutzr poutxi poutyi poutzi: Interface.word.rep)
    (wold_outxr wold_outyr wold_outzr wold_outxi wold_outyi wold_outzi: list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (RX1r RX1i RY1r RY1i RZ1r RZ1i
      RX2r RX2i RY2r RY2i RZ2r RZ2i Rout : Interface.map.rep -> Prop),
    valid (List.map Interface.word.unsigned wX1r) /\
    valid (List.map Interface.word.unsigned wY1r) /\
    valid (List.map Interface.word.unsigned wZ1r) /\
    valid (List.map Interface.word.unsigned wX2r) /\
    valid (List.map Interface.word.unsigned wY2r) /\
    valid (List.map Interface.word.unsigned wZ2r) /\
    valid (List.map Interface.word.unsigned wX1i) /\
    valid (List.map Interface.word.unsigned wY1i) /\
    valid (List.map Interface.word.unsigned wZ1i) /\
    valid (List.map Interface.word.unsigned wX2i) /\
    valid (List.map Interface.word.unsigned wY2i) /\
    valid (List.map Interface.word.unsigned wZ2i) ->
    ((Bignum n pX1r wX1r) * RX1r)%sep m0 ->
    ((Bignum n pX1i wX1i) * RX1i)%sep m0 ->
    ((Bignum n pY1r wY1r) * RY1r)%sep m0 ->
    ((Bignum n pY1i wY1i) * RY1i)%sep m0 ->
    ((Bignum n pZ1r wZ1r) * RZ1r)%sep m0 ->
    ((Bignum n pZ1i wZ1i) * RZ1i)%sep m0 ->
    ((Bignum n pX2r wX2r) * RX2r)%sep m0 ->
    ((Bignum n pX2i wX2i) * RX2i)%sep m0 ->
    ((Bignum n pY2r wY2r) * RY2r)%sep m0 ->
    ((Bignum n pY2i wY2i) * RY2i)%sep m0 ->
    ((Bignum n pZ2r wZ2r) * RZ2r)%sep m0 ->
    ((Bignum n pZ2i wZ2i) * RZ2i)%sep m0 ->
    ((Bignum n poutxr wold_outxr) * (Bignum n poutyr wold_outyr) * (Bignum n poutzr wold_outzr) *
    (Bignum n poutxi wold_outxi) * (Bignum n poutyi wold_outyi) * (Bignum n poutzi wold_outzi) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "BLS12_G2_add_alt") t m0
    ([poutxr; poutxi; poutyr; poutyi; poutzr; poutzi; pX1r; pX1i; pY1r; pY1i; pZ1r; pZ1i; pX2r; pX2i; pY2r; pY2i; pZ2r; pZ2i])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutxr woutyr woutzr woutxi woutyi woutzi: list Interface.word.rep) Rout,
        (
                (BLS12_add_Gallina_spec (toZ wX1r) (toZ wX1i) (toZ wY1r) (toZ wY1i) (toZ wZ1r) (toZ wZ1i) (toZ wX2r)
                (toZ wX2i) (toZ wY2r) (toZ wY2i)
                (toZ wZ2r) (toZ wZ2i) (toZ woutxr) (toZ woutxi) (toZ woutyr) (toZ woutyi) (toZ woutzr) (toZ woutzi) /\
             ((Bignum n poutxr woutxr) * (Bignum n poutyr woutyr) * (Bignum n poutzr woutzr) *
             (Bignum n poutxi woutxi) * (Bignum n poutyi woutyi) * (Bignum n poutzi woutzi) * Rout)%sep m')))).

  Ltac straightline'' :=
  lazymatch goal with
  | [Hminit : ?mcond (?minit)
      |- forall (_ : @word.rep _ _)
                (_ _ : @Interface.map.rep _ _ _),
          anybytes _ ?numbytes _ -> msplit _ ?minit _ -> _ ] =>
      let a := (fresh "a") in
      let mStack := (fresh "mStack") in
      let mnew := (fresh "mnew") in
      let Hany := (fresh "Hany") in
      let HanyBignum := (fresh "HanyBignum") in
      let anyval := (fresh "anyval") in
      let Hsplit := (fresh "Hsplit") in
      let Hmnew := (fresh "Hmnew") in
      let R := (fresh "R") in
      intros a mStack mnew Hany Hsplit; destruct (anybytes_Bignum n mStack numbytes a numbytes_correct Hany) as [anyval HanyBignum];
      destruct (alloc_seps_alt mnew minit mStack mcond (Bignum _ _ _) Hsplit (empty_frame mcond minit Hminit) (empty_frame (Bignum _ _ _) mStack HanyBignum)) as [R Hmnew];
      clear Hany Hsplit HanyBignum
  | _ => straightline
  end.

  Theorem G1_add_alt_func_ok : program_logic_goal_for_function! BLS12_add_alt.
  Proof.
    do 12 straightline.

    (*Assert single hypothesis for stackallocation.*)
    remember (Bignum n pX1r wX1r * RX1r)%sep as RX1r'.
    remember (Bignum n pY1r wY1r * RY1r)%sep as RY1r'.
    remember (Bignum n pZ1r wZ1r * RZ1r)%sep as RZ1r'.
    remember (Bignum n pX2r wX2r * RX2r)%sep as RX2r'.
    remember (Bignum n pY2r wY2r * RY2r)%sep as RY2r'.
    remember (Bignum n pZ2r wZ2r * RZ2r)%sep as RZ2r'.
    remember (Bignum n pX1i wX1i * RX1i)%sep as RX1i'.
    remember (Bignum n pY1i wY1i * RY1i)%sep as RY1i'.
    remember (Bignum n pZ1i wZ1i * RZ1i)%sep as RZ1i'.
    remember (Bignum n pX2i wX2i * RX2i)%sep as RX2i'.
    remember (Bignum n pY2i wY2i * RY2i)%sep as RY2i'.
    remember (Bignum n pZ2i wZ2i * RZ2i)%sep as RZ2i'.
    remember ((Bignum n poutxr wold_outxr * Bignum n poutyr wold_outyr *
          Bignum n poutzr wold_outzr * Bignum n poutxi wold_outxi *
          Bignum n poutyi wold_outyi * Bignum n poutzi wold_outzi * Rout)%sep) as Rout'.

    assert (
        id (fun m => (RX1r' m /\ RX1i' m /\ RY1r' m /\ RY1i' m /\ RZ1r' m /\ RZ1i' m /\
        RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m)) m0).
    {
      cbv [id]. split; auto. repeat (split; auto); auto.
    }

    (*Allocate memory on stack. *)
    repeat straightline''. clear H37 Hmnew Hmnew0 Hmnew1 Hmnew2 Hmnew3 Hmnew4 Hmnew5 Hmnew6 Hmnew7 Hmnew8 Hmnew9.
    repeat straightline'. cbv [id] in *.

    (*Handle calls to felem_copy.
      Perhaps find a good way to automate these tactic applications?*)
      Ltac copy_next R fR thism pX1 wX1 RX1 a H := straightline_call; [subst R; remember fR as thisP;
      eassert (thisH : ((fun m => (Bignum n pX1 wX1 * RX1)%sep m /\ thisP m) * Bignum n a _ * _)%sep thism) by (subst thisP; ecancel_assumption); subst thisP; apply thisH |]; clear H; repeat straightline.

    copy_next RX1r' (fun m => (RX1i' m /\ RY1r' m /\ RY1i' m /\ RZ1r' m /\ RZ1i' m /\
    RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m)) mnew10 pX1r wX1r RX1r a Hmnew10.

    copy_next RX1i' (fun m => (RY1r' m /\ RY1i' m /\ RZ1r' m /\ RZ1i' m /\
    RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m)) a12 pX1i wX1i RX1i a0 H39.

    copy_next RY1r' (fun m => (RY1i' m /\ RZ1r' m /\ RZ1i' m /\
    RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m)) a14 pY1r wY1r RY1r a1 H39.

    copy_next RY1i' (fun m => (RZ1r' m /\ RZ1i' m /\
    RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m)) a12 pY1i wY1i RY1i a2 H39.

    copy_next RZ1r' (fun m => (RZ1i' m /\
    RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m)) a14 pZ1r wZ1r RZ1r a3 H39.

    copy_next RZ1i' (fun m => (RX2r' m /\ RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m))
        a12 pZ1i wZ1i RZ1i a4 H39.

    copy_next RX2r' (fun m => (RX2i' m /\ RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m))
        a14 pX2r wX2r RX2r a5 H39.

    copy_next RX2i' (fun m => (RY2r' m /\ RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m))
        a12 pX2i wX2i RX2i a6 H39.

    copy_next RY2r' (fun m => (RY2i' m /\ RZ2r' m /\ RZ2i' m /\ Rout' m))
        a14 pY2r wY2r RY2r a7 H39.

    copy_next RY2i' (fun m => (RZ2r' m /\ RZ2i' m /\ Rout' m))
        a12 pY2i wY2i RY2i a8 H39.

    copy_next RZ2r' (fun m => (RZ2i' m /\ Rout' m))
        a14 pZ2r wZ2r RZ2r a9 H39.

    copy_next RZ2i' (fun m => (Rout' m))
        a12 pZ2i wZ2i RZ2i a10 H39.

    (*Handle function call*)
    repeat straightline.
    straightline_call.
    2: assert (nval : num_limbs = n) by (cbv; auto); rewrite nval in *; ecancel_assumption.
    1: repeat (split; auto).

    (*Defragment memory in context after stack allocation. *)
    repeat straightline.
    repeat (defrag_in_context (WordByWordMontgomery.n Spec.m bw)).

    (*Postcondition*)
    repeat straightline. do 2 split; auto.
    do 7 eexists. split.
    2: ecancel_assumption.
    auto.
  Qed.

(* Printing to C
From bedrock2 Require Import ToCString Bytedump.
Definition bls12_c_add :=
  c_module (add :: nil).
  Definition bls12_c_mul :=
  c_module (mul :: nil).
  Definition bls12_c_sub :=
  c_module (sub :: nil).
  Definition bls12_c_Fp2add' :=
   c_module (Fp2_add :: nil).
  Definition bls12_c_Fp2sub' :=
  c_module (Fp2_sub :: nil).
  Definition bls12_c_Fp2mul' :=
   c_module (Fp2_mul :: nil).
  Definition bls12_c_Fp2add :=
  c_module (Fp2_add_alt2 :: nil).
  Definition bls12_c_felem_copy :=
  c_module (felem_copy :: nil).
  Definition bls12_c_Fp2sub :=
  c_module (Fp2_sub_alt2 :: nil).
  Definition bls12_c_Fp2mul :=
  c_module (Fp2_mul_alt2 :: nil).
  Definition G2_add :=
  c_module (BLS12_add :: nil).
  Eval compute in bls12_c_Fp2mul'. *)

End Spec.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2021, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals List.

Require Import Sig.
Require Import Generic_proof.
Require Import Interval_helper.
Require Import Xreal Interval Tree Reify Prog.

Definition reify_var : R.
Proof. exact 0%R. Qed.

Definition plot2 (f : R -> R) (ox dx oy dy : R) (h : Z) (l : list (Z * Z)) :=
  forall i x, (ox + dx * INR i <= x <= ox + dx * INR (S i))%R ->
  (oy <= f x <= oy + dy * IZR h)%R ->
  let r := nth i l (0%Z, h) in
  (oy + dy * IZR (fst r) <= f x <= oy + dy * IZR (snd r))%R.

Module PlotTacticAux (F : FloatOps with Definition radix := Zaux.radix2 with Definition sensible_format := true) (I : IntervalOps with Module F := F).

Module F' := FloatExt F.
Module IH := IntervalTacticAux I.
Import IH.

Definition plot1 (f : R -> R) (ox dx : R) (l : list I.type) :=
  forall i x, (ox + dx * INR i <= x <= ox + dx * INR (S i))%R ->
  contains (I.convert (nth i l I.nai)) (Xreal (f x)).

Lemma plot_ext :
  forall f g u d l,
  (forall x, f x = g x) ->
  plot1 f u d l -> plot1 g u d l.
Proof.
intros f g u d l H K i x Hx.
specialize (K i x Hx).
now rewrite <- H.
Qed.

Fixpoint bound_plot_aux prec (fi : I.type -> I.type) (ui di : I.type) (xz : Z) (i : nat) (acc : I.type) : I.type :=
  match i with
  | O => acc
  | S i =>
    let xz := Z.succ xz in
    let xi := I.add prec ui (I.mul prec di (I.fromZ prec xz)) in
    bound_plot_aux prec fi ui di xz i (I.join (fi xi) acc)
  end.

Definition bound_plot prec hyps pf cf oxi dxi nb :=
  let bounds := R.merge_hyps prec hyps ++ map (T.eval_bnd prec) cf in
  let fi xi := nth 0 (A.BndValuator.eval prec pf (xi :: bounds)) I.nai in
  bound_plot_aux prec fi oxi dxi 0%Z (Z.to_nat nb) (fi oxi).

Fixpoint sample_plot_aux prec (gi : I.type -> I.type -> I.type) (check : I.type -> bool) (ui di zi2 : I.type) (fi : I.type -> I.type) (i : nat) (mz xz rz : Z) (acc : list I.type) : list I.type :=
  match i with
  | O => acc
  | S i =>
    let xz' := Z.pred xz in
    let xi1 := I.add prec ui (I.mul prec di (I.fromZ prec xz')) in
    let xi2 := I.add prec ui (I.mul prec di (I.fromZ prec xz)) in
    let xi := I.join xi1 xi2 in
    let zi1 := fi xi1 in
    let yi := fi xi in
    let c := andb
      (orb (check (I.meet yi (I.lower_extent zi1))) (check (I.meet yi (I.upper_extent zi1))))
      (orb (check (I.meet yi (I.lower_extent zi2))) (check (I.meet yi (I.upper_extent zi2)))) in
    let yizi :=
      if c then (yi, zi1)
      else let fi := gi xi in (fi xi, fi xi1) in
    let mz' :=
      if Z.eqb mz xz' then (mz - Z.div2 (3 * rz))%Z
      else if c then mz
      else (xz' - 1 - Z.div2 rz)%Z in
    let mz' :=
      if Z.ltb mz' 0%Z then 0%Z else mz' in
    let firz :=
      if Z.eqb mz mz' then (fi, rz)
      else
        let xi0 := I.add prec ui (I.mul prec di (I.fromZ prec mz')) in
        (gi (I.join xi0 xi1), (xz' - mz'))%Z in
    let acc := fst yizi :: acc in
    sample_plot_aux prec gi check ui di (snd yizi) (fst firz) i mz' xz' (snd firz) acc
  end.

Definition sample_plot prec deg check hyps pf cf oxi dxi nb :=
  let hyps := R.merge_hyps prec hyps in
  let gi :=
    let bounds := hyps ++ map (T.eval_bnd prec) cf in
    let fi xi := nth 0 (A.BndValuator.eval prec pf (xi :: bounds)) I.nai in
    let bounds := A.TaylorValuator.TM.var :: map A.TaylorValuator.TM.const bounds in
    fun yi =>
      let zi := fi yi in
      let fi := nth 0 (A.TaylorValuator.eval prec deg yi pf bounds) A.TaylorValuator.TM.dummy in
      fun xi =>
        let zi' := A.TaylorValuator.TM.eval (prec, deg) fi yi xi in
        if I.subset xi yi then I.meet zi zi' else zi' in
  let ui := I.add prec oxi (I.mul prec dxi (I.fromZ prec 0)) in
  let vi := I.add prec oxi (I.mul prec dxi (I.fromZ prec nb)) in
  sample_plot_aux prec gi check oxi dxi I.whole (gi (I.join ui vi)) (Z.to_nat nb) 0%Z nb nb nil.

Lemma sample_plot_correct :
  forall prec deg check vars hyps pf cf oxi dxi ox dx nb l,
  contains (I.convert oxi) (Xreal ox) ->
  contains (I.convert dxi) (Xreal dx) ->
  sample_plot prec deg check hyps pf cf oxi dxi (Zpos nb) = l ->
  eval_hyps hyps vars (
    plot1 (fun t => eval_real' pf (t :: vars) cf) ox dx l).
Proof.
intros prec deg check vars hyps pf cf oxi dxi ox dx nb l Box Bdx <-.
apply (R.eval_hyps_bnd_correct prec).
intros H'.
unfold sample_plot, eval_real'.
set (bounds' := R.merge_hyps prec hyps ++ _).
set (bounds := A.TaylorValuator.TM.var :: _).
set (ui := I.add prec oxi (I.mul prec dxi (I.fromZ prec 0))).
set (vi := I.add prec oxi (I.mul prec dxi (I.fromZ prec (Zpos nb)))).
set (gi := fun yi =>
      let zi := nth 0 (A.BndValuator.eval prec pf (yi :: bounds')) I.nai in
      let fi := nth 0 (A.TaylorValuator.eval prec deg yi pf bounds) A.TaylorValuator.TM.dummy in
      fun xi =>
        let zi' := A.TaylorValuator.TM.eval (prec, deg) fi yi xi in
        if I.subset xi yi then I.meet zi zi' else zi').
set (f x := nth 0 (eval_real pf ((x :: vars) ++ map (fun c : expr => eval c nil) cf)) 0%R).
fold (gi (I.join ui vi)).
assert (Hg: forall ti xi x, contains (I.convert xi) (Xreal x) -> contains (I.convert (gi ti xi)) (Xreal (f x))).
{ intros ti xi x Hx.
  unfold gi.
  destruct I.subset eqn:Hs.
  apply I.meet_correct.
  apply A.BndValuator.eval_correct_ext'.
  now apply app_merge_hyps_eval_bnd.
  apply subset_contains with (2 := Hx).
  now apply I.subset_correct.
  apply A.TaylorValuator.eval_correct with (2 := Hx).
  now apply app_merge_hyps_eval_bnd.
  apply A.TaylorValuator.eval_correct with (2 := Hx).
  now apply app_merge_hyps_eval_bnd. }
rewrite <- (Z2Nat.id (Zpos nb)) at 2 by easy.
set (i := Z.to_nat (Zpos nb)).
cut (plot1 f (ox + dx * INR i) dx nil).
2: intros [|j] x _ ; apply J.nai_correct.
generalize (@nil I.type).
generalize I.whole (I.join ui vi) 0%Z (Z.pos nb).
clearbody f gi i.
clear -Box Bdx Hg.
induction i as [|n IH].
{ simpl. intros _ _ _ _ l. now rewrite Rmult_0_r, Rplus_0_r. }
intros zi2 gxi mz rz acc Hacc.
cbn beta iota zeta delta [sample_plot_aux].
rewrite <- Nat2Z.inj_pred by apply lt_O_Sn.
simpl (Nat.pred (S n)).
set (xi1 := I.add prec oxi (I.mul prec dxi (I.fromZ prec (Z.of_nat n)))).
set (xi2 := I.add prec oxi (I.mul prec dxi (I.fromZ prec (Z.of_nat (S n))))).
set (xi := I.join xi1 xi2).
set (zi1 := gi gxi xi1).
set (yi := gi gxi xi).
set (c := andb
  (orb (check (I.meet yi (I.lower_extent zi1))) (check (I.meet yi (I.upper_extent zi1))))
  (orb (check (I.meet yi (I.lower_extent zi2))) (check (I.meet yi (I.upper_extent zi2))))).
clearbody c.
set (yizi := if c then (yi, zi1) else (gi xi xi, gi xi xi1)).
set (mz' :=
  if Z.eqb mz (Z.of_nat n) then (mz - Z.div2 (3 * rz))%Z
  else if c then mz
  else (Z.of_nat n - 1 - Z.div2 rz)%Z).
set (mz'' := if Z.ltb mz' 0%Z then 0%Z else mz').
clearbody mz' mz''.
set (gxi' := I.join (I.add prec oxi (I.mul prec dxi (I.fromZ prec mz''))) xi1).
clearbody gxi'.
cut (plot1 f (ox + dx * INR n) dx (fst yizi :: acc)).
{ destruct Z.eqb ; apply IH. }
clear -Box Bdx Hg Hacc.
intros [|i] x Hx.
2: {
  apply Hacc.
  revert Hx. clear.
  rewrite !S_INR.
  replace (ox + dx * INR n + dx * (INR i + 1))%R with (ox + dx * (INR n + 1) + dx * INR i)%R by ring.
  replace (ox + dx * INR n + dx * (INR i + 1 + 1))%R with (ox + dx * (INR n + 1) + dx * (INR i + 1))%R by ring.
  easy. }
assert (Hxi: contains (I.convert xi) (Xreal x)).
{ apply J.join_correct with (u := (ox + dx * (IZR (Z.of_nat n)))%R) (v := (ox + dx * (IZR (Z.of_nat (S n))))%R).
  apply J.add_correct with (1 := Box).
  apply J.mul_correct with (1 := Bdx).
  apply I.fromZ_correct.
  apply J.add_correct with (1 := Box).
  apply J.mul_correct with (1 := Bdx).
  apply I.fromZ_correct.
  rewrite Nat2Z.inj_succ, succ_IZR, <- INR_IZR_INZ.
  revert Hx. clear.
  now rewrite Rmult_0_r, Rplus_0_r, Rmult_plus_distr_l, Rplus_assoc. }
now destruct c ; simpl ; apply Hg.
Qed.

Definition clamp_lower (v : Basic.float Basic.radix2) (h : Z) :=
  match v with
  | Basic.Fzero => 0%Z
  | Basic.Fnan => 0%Z
  | Basic.Float true _ _ => 0%Z
  | Basic.Float false m e =>
    let v := Z.shiftl (Zpos m) e in
    if Z.leb h v then h else v
  end.

Definition clamp_upper (v : Basic.float Basic.radix2) (h : Z) :=
  match v with
  | Basic.Fzero => 0%Z
  | Basic.Fnan => h
  | Basic.Float true _ _ => 0%Z
  | Basic.Float false m e =>
    let v:=
      match e with
      | Z0 => Zpos m
      | Zpos e' => Z.shiftl (Zpos m) e
      | Zneg e' => Z.shiftl (Zpos m + (Z.shiftl 1 (Zpos e')) - 1) e
      end in
    if Z.leb h v then h else v
  end.

Definition clamp (xi : I.type) (h : Z) :=
  (clamp_lower (F.toF (I.lower xi)) h, clamp_upper (F.toF (I.upper xi)) h).

Theorem clamp_correct :
  forall xi h x,
  contains (I.convert xi) (Xreal x) ->
  (0 <= x <= IZR h)%R ->
  let yi := clamp xi h in
  (IZR (fst yi) <= x <= IZR (snd yi))%R.
Proof.
intros xi h x Bx Hx.
unfold clamp.
assert (Nx := not_empty_contains _ _ Bx).
split ; simpl.
- assert (Vl := I.lower_correct _ Nx).
  change I.F.convert with F.convert in Vl.
  unfold F.convert in Vl.
  destruct F.toF as [| |[|] mx ex] ; try easy.
  destruct (I.convert xi) as [|[|xl] xu] ; try easy.
  apply Rle_trans with (2 := proj1 Bx).
  clear -Vl.
  injection Vl as <-.
  unfold clamp_lower.
  apply Rle_trans with (IZR (Z.shiftl (Zpos mx) ex)).
  { destruct (Z.leb_spec h (Z.shiftl (Zpos mx) ex)) as [H|H].
    now apply IZR_le.
    apply Rle_refl. }
  unfold Basic.FtoR.
  destruct ex as [|ex|ex].
  + apply Rle_refl.
  + rewrite Z.shiftl_mul_pow2 by easy.
    apply Rle_refl.
  + rewrite Z.shiftl_div_pow2 by easy.
    rewrite <- Raux.Zfloor_div.
    apply Raux.Zfloor_lb.
    apply Zaux.Zgt_not_eq.
    now apply Z.pow_pos_nonneg.
- assert (Vu := I.upper_correct _ Nx).
  clear Nx.
  change I.F.convert with F.convert in Vu.
  unfold F.convert in Vu.
  destruct (I.convert xi) as [|xl [|xu]] ; try easy.
    now destruct F.toF.
    now destruct F.toF.
  destruct F.toF as [| |[|] mx ex] ; try easy.
  { apply Rle_trans with (1 := proj2 Bx).
    injection Vu as <-.
    apply Rle_refl. }
  { apply Rle_trans with (1 := proj2 Bx).
    injection Vu as <-.
    apply Rlt_le, Generic_proof.FtoR_Rneg. }
  unfold clamp_upper.
  destruct Z.leb.
  { easy. }
  apply Rle_trans with (1 := proj2 Bx).
  clear -Vu.
  injection Vu as <-.
  destruct ex as [|ex|ex].
  + apply Rle_refl.
  + rewrite Z.shiftl_mul_pow2 by easy.
    apply Rle_refl.
  + rewrite Z.shiftl_div_pow2 by easy.
    rewrite Z.shiftl_mul_pow2 by easy.
    simpl Z.opp. simpl Basic.FtoR.
    fold (2 ^ Zpos ex)%Z.
    apply Generic_proof.Rdiv_ge_mult_pos.
    apply IZR_lt.
    now apply Z.pow_pos_nonneg.
    rewrite <- mult_IZR.
    apply IZR_le.
    apply Z.lt_pred_le.
    replace (Zpos mx + 1 * 2 ^ Zpos ex - 1)%Z with (Zpos mx - 1 + 1 * 2 ^ Zpos ex)%Z by ring.
    rewrite Zdiv.Z_div_plus_full.
    apply Z.mul_succ_div_gt.
    now apply Z.pow_pos_nonneg.
    apply Zaux.Zgt_not_eq.
    now apply Z.pow_pos_nonneg.
Qed.

Fixpoint clamp_plot prec (vi ei : I.type) (h : Z) (l : list I.type) : list (Z * Z) :=
  match l with
  | nil => nil
  | cons yi l =>
    let r := clamp (I.mul prec (I.sub prec yi vi) ei) h in
    cons r (clamp_plot prec vi ei h l)
  end.

Lemma affine_transf :
  forall oy dy y1 y2 y : R,
  (0 < dy)%R ->
  (oy + dy * y1 <= y <= oy + dy * y2)%R <-> (y1 <= (y - oy) / dy <= y2)%R.
Proof.
intros oy dy y1 y2 y Hdy.
replace y with (oy + dy * ((y - oy) / dy))%R at 1 2.
2: now field ; apply Rgt_not_eq.
split ; intros [H1 H2] ; split.
- apply Rmult_le_reg_l with (1 := Hdy).
  apply Rplus_le_reg_l with (1 := H1).
- apply Rmult_le_reg_l with (1 := Hdy).
  apply Rplus_le_reg_l with (1 := H2).
- apply Rplus_le_compat_l.
  apply Rmult_le_compat_l with (2 := H1).
  now apply Rlt_le.
- apply Rplus_le_compat_l.
  apply Rmult_le_compat_l with (2 := H2).
  now apply Rlt_le.
Qed.

Lemma clamp_plot_correct :
  forall prec oyi dyi f ox dx oy dy h l1 l2,
  (0 < dy)%R ->
  contains (I.convert oyi) (Xreal oy) ->
  contains (I.convert dyi) (Xreal (/dy)) ->
  clamp_plot prec oyi dyi h l1 = l2 ->
  plot1 f ox dx l1 ->
  plot2 f ox dx oy dy h l2.
Proof.
intros prec oyi dyi f ox dx oy dy h l l2 Hdy Boy Bdy <-.
intros H i x Hx Hy.
specialize (H i x Hx).
revert i ox H Hx.
induction l as [|yi l IH] ; intros [|i] ox Hl Hx.
- now simpl ; rewrite Rmult_0_r, Rplus_0_r.
- now simpl ; rewrite Rmult_0_r, Rplus_0_r.
- assert (By: contains (I.convert (I.mul prec (I.sub prec yi oyi) dyi)) (Xreal ((f x - oy) / dy))).
  { apply J.mul_correct with (2 := Bdy).
    apply J.sub_correct with (2 := Boy).
    now apply Hl. }
  simpl nth.
  generalize (clamp_correct (I.mul prec (I.sub prec yi oyi) dyi) h ((f x - oy) / dy)%R By).
  destruct clamp as [y1 y2].
  clear -Hdy Hy.
  intros H.
  apply affine_transf with (1 := Hdy).
  apply H.
  apply affine_transf with (1 := Hdy).
  now rewrite Rmult_0_r, Rplus_0_r.
- apply (IH i (ox + dx * INR 1)%R Hl).
  now rewrite 2!Rplus_assoc, <- 2!Rmult_plus_distr_l, 2!(Rplus_comm 1), <- 2!S_INR.
Qed.

Definition get_bounds (prec : F.precision) (l : list I.type): F.type * F.type :=
  let yi :=
    match l with
    | cons hi l => List.fold_left I.join l hi
    | nil => I.empty
    end in
  (I.lower yi, I.upper yi).
  (*
  let mi := I.div prec (I.sub prec yi2 yi1) (I.fromZ prec 20) in
  (I.sub prec yi1 mi, I.add prec yi2 mi)
  *)

Ltac unify_eq native :=
  match goal with
  | |- ?f ?p1 = ?p2 =>
    match native with
    | true =>
      let p1 := eval hnf in p1 in
      let p := eval native_compute in (f p1) in
      instantiate (p2 := p) ;
      native_cast_no_check (eq_refl p2)
    | false =>
      let p1 := eval hnf in p1 in
      let p := eval vm_compute in (f p1) in
      instantiate (p2 := p) ;
      vm_cast_no_check (eq_refl p2)
    end
  end.

Ltac plot1_aux1 prec x1 x2 w h native tac_b :=
  let x1 := reify x1 constr:(@nil R) in
  let x2 := reify x2 constr:(@nil R) in
  let ox := eval vm_compute in (I.lower (T.eval_bnd prec x1)) in
  let dx := eval vm_compute in (F.div_UP prec (F.sub_UP prec (I.upper (T.eval_bnd prec x2)) ox) (F.fromZ_DN prec (Zpos w))) in
  let oxr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert ox)) in
  let dxr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert dx)) in
  match goal with
  | |- plot1 ?f ?ox' ?dx' ?p =>
    unify ox' oxr ;
    unify dx' dxr ;
    let fapp := eval cbv beta in (f reify_var) in
    let vars := constr:((reify_var :: nil)%list) in
    let vars := get_vars fapp vars in
    let vars :=
      match get_vars fapp vars with
      | (reify_var :: ?vars)%list => vars
      end in
    eapply plot_ext ; [
      let t := fresh "t" in intros t ;
      let fapp := eval cbv beta in (f t) in
      reify_partial fapp (t :: vars) ;
      exact (fun H => H) |] ;
    find_hyps vars ;
    let y1y2 := tac_b prec ox dx w in
    let thr := eval vm_compute in (F.div_UP prec (F.sub_UP prec (snd y1y2) (fst y1y2)) (F.fromZ_DN prec (Zpos h))) in
    apply (sample_plot_correct prec) with
      (deg := 10%nat) (nb := w) (l := p)
      (check := fun yi => F'.le' (F.sub_UP prec (I.upper yi) (I.lower yi)) thr)
      (1 := I.singleton_correct ox)
      (2 := I.singleton_correct dx) ;
    unify_eq native
  end.

Ltac plot2_aux prec x1 x2 w native tac_t tac_b :=
  match goal with
  | |- plot2 ?f ?ox ?dx ?oy' ?dy' (Zpos ?h) ?p2 =>
    let p1 := fresh "__p1" in
    evar (p1 : list I.type) ;
    let Hp := fresh "__Hp" in
    assert (Hp: plot1 f ox dx p1) by plot1_aux1 prec x1 x2 w h native tac_t ;
    revert Hp ;
    let y1y2 := tac_b prec in
    let oy := constr:(fst y1y2) in
    let dy := eval vm_compute in (F.div_UP prec (F.sub_UP prec (snd y1y2) oy) (F.fromZ_DN prec (Zpos h))) in
    let oyr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert oy)) in
    let dyr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert dy)) in
    unify oy' oyr ;
    unify dy' dyr ;
    refine (clamp_plot_correct prec _ _ _ _ _ oyr dyr _ _ _ _ (I.singleton_correct oy) (J.inv_correct prec _ _ (I.singleton_correct dy)) _) ;
    [ try apply IZR_lt ;
      apply Rdiv_lt_0_compat ;
      now apply IZR_lt
    | unify_eq false ]
  end.

Definition get_threshold prec hyps pf cf ox dx w :=
  let w' := 50%Z in
  let dx := I.mul prec (I.singleton dx) (I.div prec (I.fromZ prec (Zpos w)) (I.fromZ prec w')) in
  let yi := bound_plot prec hyps pf cf (I.singleton ox) dx w' in
  (I.lower yi, I.upper yi).

Ltac plot_get_threshold prec ox dx w :=
  match goal with
  | |- eval_hyps ?hyps _ (plot1 (fun t => eval_real' ?pf (t :: _) ?cf) _ _ _) =>
    eval vm_compute in (get_threshold prec hyps pf cf ox dx w)
  end.

Ltac plot_get_bounds prec :=
  match goal with
  | |- plot1 _ _ _ ?p -> _ =>
    let p := eval vm_compute in p in
    eval vm_compute in (get_bounds prec p)
  end.

Ltac plot_y_get_threshold y1 y2 prec ox dx w := constr:((y1, y2)).

Ltac plot_y_get_bounds y1 y2 prec := constr:((y1, y2)).

Ltac do_plot f x1 x2 prec degree width height native :=
  let p := fresh "__p2" in
  evar (p : list (Z * Z)) ;
  refine (_: plot2 f _ _ _ _ (Zpos height) p) ;
  plot2_aux prec x1 x2 width native plot_get_threshold plot_get_bounds.

Ltac do_plot_y f x1 x2 y1 y2 prec degree width height native :=
  let p := fresh "__p2" in
  let y1 := reify y1 constr:(@nil R) in
  let y2 := reify y2 constr:(@nil R) in
  let y1 := eval vm_compute in (I.lower (T.eval_bnd prec y1)) in
  let y2 := eval vm_compute in (I.upper (T.eval_bnd prec y2)) in
  evar (p : list (Z * Z)) ;
  refine (_: plot2 f _ _ _ _ (Zpos height) p) ;
  plot2_aux prec x1 x2 width native ltac:(plot_y_get_threshold y1 y2) ltac:(plot_y_get_bounds y1 y2).

End PlotTacticAux.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat ssrint.
From fourcolor Require Import part hubcap present.

(******************************************************************************)
(*   This file contains the unavoidability proof for cartwheels with a hub    *)
(* arity of 5. This proof is a reencoding of the argument that appeared in    *)
(* the main text of the Robertson et al. revised proof.                       *)
(******************************************************************************)

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

Lemma exclude5 : excluded_arity 5.
Proof.
Presentation red.
Pcase L0_1: s[1] <= 5.
  Pcase L1_1: s[2] <= 5.
    Pcase L2_1: s[3] <= 6.
      Pcase: s[3] <= 5.
        Reducible.
      Pcase: s[4] <= 5.
        Reducible.
      Pcase: s[5] > 6.
        Hubcap $[1,2]<=0 $[3,4]<=(-6) $[5]<=(-4) $.
      Pcase: s[5] > 5.
        Hubcap $[1,2]<=0 $[3,4]<=(-7) $[5]<=(-3) $.
      Reducible.
    Pcase: s[5] <= 6.
      Similar to *L2_1[3].
    Pcase: s[4] > 5.
      Hubcap $[1,2]<=0 $[3,4]<=(-6) $[5]<=(-4) $.
    Hubcap $[1,2]<=0 $[3,4]<=(-5) $[5]<=(-5) $.
  Pcase: s[5] <= 5.
    Similar to L1_1[4].
  Pcase L1_2: s[3] <= 5.
    Pcase: s[2] <= 6.
      Reducible.
    Pcase: s[4] <= 5.
      Similar to L1_1[2].
    Pcase L2_1: s[4] <= 6.
      Pcase: s[5] <= 6.
        Reducible.
      Hubcap $[1,2]<=(-4) $[3,4]<=(-2) $[5]<=(-4) $.
    Pcase: s[5] <= 6.
      Similar to *L2_1[2].
    Hubcap $[1,2]<=(-4) $[3,4]<=(-3) $[5]<=(-3) $.
  Pcase: s[4] <= 5.
    Similar to *L1_2[4].
  Pcase L1_3: s[2] > 6.
    Pcase: s[5] > 6.
      Hubcap $[1,2]<=(-3) $[3,4]<=(-4) $[5]<=(-3) $.
    Hubcap $[1,2]<=(-3) $[3,4]<=(-5) $[5]<=(-2) $.
  Pcase: s[5] > 6.
    Similar to *L1_3[4].
  Hubcap $[1,2]<=(-2) $[3,4]<=(-6) $[5]<=(-2) $.
Pcase: s[2] <= 5.
  Similar to L0_1[1].
Pcase: s[3] <= 5.
  Similar to L0_1[2].
Pcase: s[4] <= 5.
  Similar to L0_1[3].
Pcase: s[5] <= 5.
  Similar to L0_1[4].
Hubcap $[1,2]<=(-4) $[3,4]<=(-4) $[5]<=(-2) $.
Qed.


(** * Combi.MPoly.Schur_mpoly : Schur symmetric polynomials *)
(******************************************************************************)
(*      Copyright (C) 2016-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Combinatorial definition of Schur symmetric polynomials

- [Schur n0 R la] == The Schur polynomial associated to the partition [la] in
                     [{mpoly R[n0.+1]}] as the sum of all tableau of shape
                     [la] over the alphabet ['I_n0.+1].

We give some values for particular partition such as small one, rows and columns.
***********)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp Require Import tuple finfun finset bigop ssralg order path.
From SsrMultinomials Require Import ssrcomplements freeg mpoly.

Require Import tools ordtype partition tableau.

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

Import Order.TTheory.
Local Open Scope ring_scope.
Import GRing.Theory.

Section Schur.

Variable n0 : nat.
Local Notation n := n0.+1.
Variable R : ringType.

Lemma mons2mE s : 'X_[s2m s] = \prod_(i <- s) 'X_i :> {mpoly R[n]}.
Proof.
rewrite /s2m; elim: s => [| s0 s IHs]/=.
  by rewrite big_nil -/mnm0 mpolyX0.
rewrite big_cons -{}IHs -mpolyXD; congr ('X_[_]).
by rewrite mnmP => i; rewrite mnmDE !mnmE.
Qed.

Definition Schur d (sh : 'P_d) : {mpoly R[n]} :=
  \sum_(t : tabsh sh) \prod_(i <- to_word t) 'X_i.

Lemma Schur_tabsh_readingE  d (sh : 'P_d) :
  Schur sh =
  \sum_(t : d.-tuple 'I_n | tabsh_reading sh t) \prod_(i <- t) 'X_i.
Proof using.
rewrite /Schur -big_enum /=.
pose prodw := fun w => \prod_(i <- w) 'X_i : {mpoly R[n]}.
rewrite -[LHS](big_map (fun t => to_word (val t)) xpredT prodw).
rewrite -[RHS](big_map val (tabsh_reading sh) prodw).
rewrite -[RHS]big_filter.
rewrite (perm_big _ (to_word_enum_tabsh sh)) /=.
by rewrite !big_filter !big_map.
Qed.

(** ** Some particular Schur functions *)

Lemma Schur0 (sh : 'P_0) : Schur sh = 1.
Proof using.
rewrite Schur_tabsh_readingE (eq_bigl (xpred1 [tuple])); first last.
  by move=> i /=; rewrite tuple0 [RHS]eq_refl val_intpartn0.
by rewrite big_pred1_eq big_nil.
Qed.

Lemma Schur_oversize d (sh : 'P_d) : (size sh > n)%N -> Schur sh = 0.
Proof using.
move=> Hn; apply big1 => t _; exfalso.
have:= size_tabsh t; rewrite -(size_map size) -/(shape t) shape_tabsh.
by move=> /(leq_trans Hn); rewrite ltnn.
Qed.

(** Equivalent definition of symh symmetric function *)

Lemma tabwordshape_row d (w : d.-tuple 'I_n) :
  tabsh_reading (rowpartn d) w = sorted leq [seq val i | i <- w].
Proof using.
rewrite /tabsh_reading /= rowpartnE ; case: w => w /=/eqP Hw.
case: d Hw => [//= | d] Hw; rewrite Hw /=; first by case: w Hw.
rewrite addn0 eq_refl andbT //=.
case: w Hw => [//= | w0 w] /= /eqP; rewrite eqSS => /eqP <-.
rewrite take_size; apply esym; apply (map_path (b := pred0)) => //.
by apply/hasPn => x /=.
Qed.

Lemma symh_basisE d :
  \sum_(s in basis n d) 'X_[s2m s] = Schur (rowpartn d).
Proof using.
rewrite Schur_tabsh_readingE (eq_bigl _ _ (@tabwordshape_row d)).
under [LHS]eq_bigr do rewrite mons2mE.
by apply eq_bigl => m; rewrite inE.
Qed.

End Schur.

Section SchurComRingType.

Variable n0 : nat.
Local Notation n := (n0.+1).
Variable R : comRingType.

Lemma perm_enum_basis d :
  perm_eq [seq s2m (tval s) | s in basis n d]
          [seq val m | m in [set m : 'X_{1..n < d.+1} | mdeg m == d]].
Proof using.
apply uniq_perm.
- rewrite map_inj_in_uniq; first exact: enum_uniq.
  move=> i j; rewrite !mem_enum => Hi Hj; exact: inj_s2m.
- rewrite map_inj_uniq; [exact: enum_uniq | exact: val_inj].
move=> m; apply/mapP/mapP => [[] s | [] mb].
- rewrite mem_enum inE /= => Hsort ->.
  have mdegs : mdeg (s2m s) = d.
    rewrite /s2m /mdeg mnm_valK /= big_map enumT -/(index_enum _).
    by rewrite combclass.sum_count_mem count_predT size_tuple.
  have mdegsP : (mdeg (s2m s) < d.+1)%N by rewrite mdegs.
  exists (BMultinom mdegsP) => //.
  by rewrite mem_enum inE /= mdegs.
- rewrite mem_enum inE => /eqP Hmb ->.
  have Ht : size (m2s mb) == d by rewrite -{2}Hmb size_m2s.
  exists (Tuple Ht) => /=; last by rewrite s2mK.
  rewrite mem_enum inE /=; exact: srt_m2s.
Qed.

Lemma Schur_rowpartn d :
  \sum_(m : 'X_{1..n < d.+1} | mdeg m == d) 'X_[m] = Schur n0 R (rowpartn d).
Proof using.
rewrite -symh_basisE.
transitivity
  (\sum_(m <- [seq s2m (tval s) | s in basis n d]) 'X_[m] : {mpoly R[n]});
    last by rewrite big_map big_enum.
rewrite (perm_big _ (perm_enum_basis d)) big_map big_enum /=.
by apply eq_bigl => m; rewrite inE.
Qed.

(** The definition of column Schur symmetric polynomials agrees with mesym
    from mpoly *)

Lemma tabwordshape_col d (w : d.-tuple 'I_n) :
  tabsh_reading (colpartn d) w = sorted >%O w.
Proof using.
rewrite /tabsh_reading /= colpartnE ; case: w => w /=/eqP Hw.
have -> : sumn (nseq d 1%N) = d.
  by elim: d {Hw} => //= d /= ->; rewrite add1n.
rewrite Hw eq_refl /= rev_nseq.
have -> : rev (reshape (nseq d 1%N) w) = [seq [:: i] | i <- rev w].
  rewrite map_rev; congr rev.
  elim: d w Hw => [| d IHd] //=; first by case.
  case => [| w0 w] //= /eqP; rewrite eqSS => /eqP /IHd <-.
  by rewrite take0 drop0.
rewrite -rev_sorted.
case: {w} (rev w) {d Hw} => [|w0 w] //=.
elim: w w0 => [//= | w1 w /= <-] w0 /=.
by congr andb; rewrite /dominate /= andbT {w}.
Qed.

Lemma mesym_SchurE d :
  mesym n R d = Schur n0 R (colpartn d).
Proof using.
rewrite /= mesym_tupleE /tmono Schur_tabsh_readingE.
rewrite (eq_bigl _ _ (@tabwordshape_col d)).
under [LHS]eq_bigr => i do have /permPl/(perm_big _) <- /= := perm_rev i.
rewrite (eq_bigl (fun i => sorted >%O (rev_tuple i))); first last.
  move=> [t /= _]; rewrite rev_sorted sorted_map.
  exact: sorted.eq_sorted.
by apply/esym/reindex/onW_bij/inv_bij => x; apply val_inj; rewrite /= revK.
Qed.

Lemma Schur1 (sh : 'P_1) : Schur n0 R sh = \sum_(i < n) 'X_i.
Proof using.
suff -> : sh = colpartn 1 by rewrite -mesym_SchurE mesym1E.
by rewrite !intpartn1.
Qed.

End SchurComRingType.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Byte.
Require Import coqutil.Word.Interface.
Require Import bedrock2.Semantics.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.

Section Representation.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {field_parameters : FieldParameters}
          {p_ok : Types.ok}.
  Context (n n_bytes : nat) (weight : nat -> Z)
          (bounds : Type)
          (list_in_bounds : bounds -> list Z -> Prop)
          (loose_bounds tight_bounds byte_bounds : bounds)
          (relax_bounds :
             forall X : list Z,
               list_in_bounds tight_bounds X ->
               list_in_bounds loose_bounds X)
          (*Transformation to applied to list before evaluating. For Solinas, this is the identity,
            and for word-by-word Montgomery, the argument must be pulled out of the Montgomery domain*)
          (eval_transformation : list Z -> list Z).

  Definition eval_words : list word -> F M_pos :=
    fun ws =>
      F.of_Z _ (Positional.eval weight n (eval_transformation (map word.unsigned ws))).

  Definition eval_bytes : list byte -> F M_pos :=
    fun bs =>
      F.of_Z _ (Positional.eval
                           (ModOps.weight 8 1)
                           n_bytes
                           (map byte.unsigned bs)).

  Local Instance frep : FieldRepresentation := {
      feval := eval_words;
      feval_bytes := eval_bytes;
      felem_size_in_words := n;
      encoded_felem_size_in_bytes := n_bytes;
      bytes_in_bounds bs := list_in_bounds byte_bounds (map byte.unsigned bs);
      bounds := bounds;
      bounded_by bs ws := list_in_bounds bs (map word.unsigned ws);
      loose_bounds := loose_bounds;
      tight_bounds := tight_bounds;
    }.

  Local Instance frep_ok : FieldRepresentation_ok.
  Proof. split. cbn [bounded_by frep]; intros. apply relax_bounds; auto. Qed.
End Representation.


(*
1) labeled repr.

2) executable

- matching
- K, subsorting
- configuration abstraction
- K bindings/substitution (HOAS?)
- freshness
- builtin primitives

-
*)

Definition int := nat.

Inductive id : Set :=
  Id : int -> id.

Fixpoint beq_int (n m : int) : bool :=
  match (n, m) with
    | (0, 0) => true
    | (S _, 0) => false
    | (0, S _) => false
    | (S n', S m') => beq_int n' m'
  end.

Definition bneq_int (n m : int) : bool := negb (beq_int n m).

Definition beq_id X1 X2 :=
  match (X1, X2) with
    (Id n1, Id n2) => beq_int n1 n2
  end.

Definition bneq_id X1 X2 := negb (beq_id X1 X2).

Inductive AExp : Set :=
  | c_int : int -> AExp
  | c_id : id -> AExp
  | c_plus : AExp -> AExp -> AExp
  | c_div : AExp -> AExp -> AExp.

Inductive BExp : Set :=
  | c_bool : bool -> BExp
  | c_le : AExp -> AExp -> BExp
  | c_not : BExp -> BExp
  | c_and : BExp -> BExp -> BExp.

Inductive Stmt : Set :=
  | c_skip : Stmt
  | c_assignment : id -> AExp -> Stmt
  | c_seq : Stmt -> Stmt -> Stmt
  | c_ifthenelse : BExp -> Stmt -> Stmt -> Stmt
  | c_while : BExp -> Stmt -> Stmt.

Inductive Ids : Set :=
  | c_listid : list id -> Ids.

Inductive Pgm : Set :=
  | c_pgm : list id -> Stmt -> Pgm.

Inductive K : Set :=
  | k_pgm : Pgm -> K
  | k_Stmt : Stmt -> K
  | k_BExp : BExp -> K
  | k_AExp : AExp -> K

  | k_id : id -> K
  | k_int : int -> K

  | k_hole : K

  | k_list : K -> K -> K.
(*
Inductive Klabel : Set :=
  | l_while : Klabel
  | l_ifthenelse : Klabel
  | l_ifholethenelse : Klabel

Inductive K' : Set :=
  | k_apply : Klabel -> list K' -> K'
  | k_arrow : list K' -> K'.

k_apply plus (1 ~> 2) 3         (*  *)

k_apply l_ifthenelse (k_arrow true 2 3, ... )
*)
(*

  l, l1, l3

  exists l2, l = l1 ++ l2 ++ l3

*)

(*

    X ~> Y

    X ~> Y + HOLE ~> Z + HOLE

    X1 ~> (X2 ~> ... ~> Xn)

*)

Definition is_value (k : K) : bool :=
  match k with
    | k_BExp (c_bool _) => true
    | k_AExp (c_int _) => true
    | _ => false
  end.

Definition configuration : Set := prod K (list (prod id K)).

(*
   record
        k : K
        state : record
                  env : map id K
                end
        threads : list record
                         ...
                       end
        k' : option K
        race : option K

*)

(*
mapsto M i k when M maps i into k

identifiers can be K's.
*)

Inductive mapsto : list (prod id K) -> id -> K -> Prop :=
  | first : forall (i : id) (k : K) (other : list (prod id K)),
              mapsto ((i, k) :: other) i k
  | next : forall (i i' : id) (k k' : K) (other : list (prod id K)),
              beq_id i i' = false ->
              mapsto other i k ->
              mapsto ((i', k') :: other) i k.

Fixpoint fillhole (small : K) (big : K) :=
  match big with
    | k_hole => small
    | k_list a b => k_list (fillhole small a) (fillhole small b)
    | _ => big
  end.

Inductive transition : configuration -> configuration -> Prop :=
  | lookup : forall (X : id) (I : int) (other : K) (map : list (prod id K)),
               mapsto map X (k_int I) ->
               transition (k_list (k_id X) other, map)
                          (k_list (k_int I) other, map)
  | cool : forall (k : K) (other : K) (map : list (prod id K)),
           is_value k = true ->
           transition (k_list k other, map) (fillhole other k, map).

  | heat_plus_1 : forall (a1 a2 : AExp) (other : K) (map : list (prod id K)),
           transition (k_list (k_AExp (c_plus a1 a2)) other, map)
                      (k_list (k_AExp a1) (k_list (k_AExp (c_plus k_hole a2)) other), map).


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.basic.schedule rt.model.schedule.global.basic.interference
               rt.model.schedule.global.basic.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module InterferenceEDF.

  Import Schedule Priority Platform Interference Priority.

  Section Lemmas.

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

    (* Assume any job arrival sequence... *)
    Context {arr_seq: arrival_sequence Job}.

    (* Consider any schedule. *)
    Variable num_cpus: nat.
    Variable sched: schedule Job num_cpus.

    (* Assume that the schedule satisfies the global scheduling invariant
       for EDF, i.e., if any job of tsk is backlogged, every processor
       must be busy with jobs with no larger absolute deadline. *)
    Hypothesis H_scheduler_uses_EDF:
      respects_JLFP_policy job_arrival job_cost arr_seq sched (EDF job_arrival job_deadline).

    (* Under EDF scheduling, a job only causes interference if its deadline
       is not larger than the deadline of the analyzed job. *)
    Lemma interference_under_edf_implies_shorter_deadlines :
      forall j j' t1 t2,
        arrives_in arr_seq j ->
        arrives_in arr_seq j' ->
        job_interference job_arrival job_cost sched j' j t1 t2 != 0 ->
        job_arrival j + job_deadline j <= job_arrival j' + job_deadline j'.
    Proof.
      rename H_scheduler_uses_EDF into PRIO.
      intros j j' t1 t2 ARR1 ARR2 INTERF.
      unfold job_interference in INTERF.
      destruct ([exists t': 'I_t2,
                   [exists cpu: processor num_cpus,
                      (t' >= t1) &&
                      backlogged job_arrival job_cost sched j' t' &&
                      scheduled_on sched j cpu t']]) eqn:EX.
      {
        move: EX => /existsP [t' /existsP [cpu /andP [/andP [LE BACK] SCHED]]].
        apply PRIO with (t := t'); try (by done).
        by apply/existsP; exists cpu.
      }
      {
        apply negbT in EX; rewrite negb_exists in EX; move: EX => /forallP ALL.
        rewrite big_nat_cond (eq_bigr (fun x => 0)) in INTERF;
          first by rewrite -big_nat_cond big_const_nat iter_addn mul0n  addn0 eq_refl in INTERF.
        move => i /andP [/andP [GEi LTi] _].
        specialize (ALL (Ordinal LTi)).
        rewrite negb_exists in ALL.
        move: ALL => /forallP ALL.
        rewrite (eq_bigr (fun x => 0));
          first by rewrite big_const_ord iter_addn mul0n addn0.
        intros cpu _; specialize (ALL cpu); simpl in ALL.
        destruct (backlogged job_arrival job_cost sched j' i); last by rewrite andFb.
        rewrite GEi 2!andTb in ALL; rewrite andTb.
        by apply negbTE in ALL; rewrite ALL.
      }
    Qed.

  End Lemmas.

End InterferenceEDF.


Require Import init.

Require Import zorn_real_zorn.

Require Import polynomial_base.
Require Import linear_grade.

Require Import order_self_abs.
Require Import order_minmax.
Require Import set.
Require Import nat.

Section Analysis.

Let PP := polynomial_plus real_cring.
Let PZ := polynomial_zero real_cring.
Let PN := polynomial_neg real_cring.
Let PPC := polynomial_plus_comm real_cring.
Let PPA := polynomial_plus_assoc real_cring.
Let PPZ := polynomial_plus_lid real_cring.
Let PPN := polynomial_plus_linv real_cring.
Let PM := polynomial_mult real_cring.
Let PO := polynomial_one real_cring.
Let PL := polynomial_ldist real_cring.
Let PMA := polynomial_mult_assoc real_cring.
Let PMC := polynomial_mult_comm real_cring.
Let PMO := polynomial_mult_lid real_cring.
Let PSM := polynomial_scalar real_cring.
Let PSMO := polynomial_scalar_id real_cring.
Let PSML := polynomial_scalar_ldist real_cring.
Let PSMR := polynomial_scalar_rdist real_cring.
Let PSMC := polynomial_scalar_comp real_cring.
Let PML := polynomial_scalar_lmult real_cring.
Let PMR := polynomial_scalar_rmult real_cring.
Let PG := polynomial_grade real_cring.

Local Existing Instances PP PZ PN PPC PPA PPZ PPN PM PO PL PMA PMC PMO PSM PSMO
    PSML PSMR PSMC PML PMR PG.

Variable cut : real → Prop.
Hypothesis cut_in : ∃ a, cut a.
Hypothesis cut_out : ∃ a, ¬cut a.
Hypothesis cut_lt : ∀ l u, cut u → l ≤ u → cut l.

Theorem cut_gt : ∀ l u, ¬cut l → l ≤ u → ¬cut u.
Proof.
    intros l u l_nin lu u_in.
    apply l_nin.
    exact (cut_lt _ _ u_in lu).
Qed.

Theorem cut_inout : ∀ a b, cut a → ¬cut b → a < b.
Proof.
    intros a b a_in b_nin.
    classic_contradiction contr.
    rewrite nlt_le in contr.
    apply b_nin.
    exact (cut_lt _ _ a_in contr).
Qed.

Let top_of_cut δ x := cut x ∧ ¬cut (x + δ).

Theorem top_of_cut_in : ∀ a b x, a ≤ b → top_of_cut a x → top_of_cut b x.
Proof.
    intros a b x lt [x_in x_nin].
    split; [>exact x_in|].
    apply le_lplus with x in lt.
    exact (cut_gt _ _ x_nin lt).
Qed.

Notation "| a |" := (abs a) (at level 30).

Lemma polynomial_bounded_xn : ∀ n a b,
    ∃ M, ∀ x, a ≤ x → x ≤ b →
    |polynomial_eval (polynomial_xn real_cring n) x| ≤ M.
Proof.
    intros n a b.
    classic_case (|a| ≤ |b|) as [leq|leq].
    -   exists (|b|^n)%nat.
        intros x ax xb.
        rewrite polynomial_eval_xn.
        nat_induction n.
        +   do 2 rewrite nat_pow_zero.
            rewrite abs_one.
            apply refl.
        +   do 2 rewrite nat_pow_suc.
            rewrite abs_mult.
            apply (le_rmult_pos (|x|) (abs_pos _)) in IHn.
            apply (trans IHn).
            apply le_lmult_pos.
            *   clear.
                nat_induction n.
                --  rewrite nat_pow_zero.
                    apply one_pos.
                --  rewrite nat_pow_suc.
                    apply le_mult; [>exact IHn|apply abs_pos].
            *   apply abs_le.
                split.
                --  apply le_neg in leq.
                    apply (trans leq).
                    apply (trans2 ax).
                    apply le_neg.
                    rewrite neg_neg.
                    apply abs_le_neg.
                --  apply (trans xb).
                    apply abs_le_pos.
    -   rewrite nle_lt in leq.
        exists (|a|^n)%nat.
        intros x ax xb.
        rewrite polynomial_eval_xn.
        nat_induction n.
        +   do 2 rewrite nat_pow_zero.
            rewrite abs_one.
            apply refl.
        +   do 2 rewrite nat_pow_suc.
            rewrite abs_mult.
            apply (le_rmult_pos (|x|) (abs_pos _)) in IHn.
            apply (trans IHn).
            apply le_lmult_pos.
            *   clear.
                nat_induction n.
                --  rewrite nat_pow_zero.
                    apply one_pos.
                --  cbn.
                    apply le_mult; [>exact IHn|apply abs_pos].
            *   apply abs_le.
                split.
                --  apply (trans2 ax).
                    apply le_neg.
                    rewrite neg_neg.
                    apply abs_le_neg.
                --  apply (le_lt_trans2 leq).
                    apply (trans xb).
                    apply abs_le_pos.
Qed.

Theorem polynomial_bounded : ∀ (f : polynomial real_cring) a b,
    ∃ M, ∀ x, a ≤ x → x ≤ b → |polynomial_eval f x| ≤ M.
Proof.
    intros f a b.
    induction f as [|f f' n fn fn' IHf] using grade_induction.
    {
        exists 0.
        intros x ax xb.
        rewrite polynomial_eval_zero.
        rewrite <- abs_zero.
        apply refl.
    }
    destruct IHf as [M1 M1_max].
    apply polynomial_xn_ex in fn as [α f_eq]; subst f.
    pose proof (polynomial_bounded_xn n a b) as [M2 M2_max].
    exists (M1 + |α| * M2).
    intros x ax xb.
    specialize (M1_max x ax xb).
    specialize (M2_max x ax xb).
    rewrite polynomial_eval_plus.
    rewrite polynomial_eval_scalar.
    apply (trans (abs_tri _ _)).
    rewrite plus_comm.
    apply le_lrplus; [>exact M1_max|].
    rewrite abs_mult.
    apply le_lmult_pos; [>apply abs_pos|].
    exact M2_max.
Qed.

Lemma polynomial_continuous_xn : ∀ n,
    ∀ ε, 0 < ε → ∃ δ, 0 < δ ∧ ∀ x y, top_of_cut δ x → top_of_cut δ y →
    |(x^n)%nat - (y^n)%nat| < ε.
Proof.
    intros n.
    nat_induction n; intros ε ε_pos.
    {
        exists 1.
        split; [>exact one_pos|].
        intros x y x_in y_in.
        do 2 rewrite nat_pow_zero.
        rewrite plus_rinv.
        rewrite <- abs_zero.
        exact ε_pos.
    }
    destruct cut_in as [a a_in].
    destruct cut_out as [b b_in].
    pose (m := max (|a - 1|) (|b|)).
    assert (0 < m) as m_pos.
    {
        unfold m.
        split.
        -   unfold max; case_if; apply abs_pos.
        -   intros contr.
            pose proof (lmax (|a - 1|) (|b|)) as leq1.
            pose proof (rmax (|a - 1|) (|b|)) as leq2.
            rewrite <- contr in leq1, leq2.
            pose proof (antisym (abs_pos _) leq1) as eq1.
            pose proof (antisym (abs_pos _) leq2) as eq2.
            rewrite abs_def in eq1, eq2.
            rewrite eq1 in eq2.
            pose proof (cut_inout _ _ a_in b_in) as ltq.
            rewrite <- eq2 in ltq.
            rewrite <- lt_plus_0_a_b_ba in ltq.
            apply pos_neg2 in ltq.
            rewrite neg_neg in ltq.
            destruct (trans ltq one_pos); contradiction.
    }
    pose proof (div_pos m_pos) as m'_pos.
    pose proof (half_pos ε_pos) as ε2_pos.
    pose proof (lt_mult ε2_pos m'_pos) as ε2m_pos.
    specialize (IHn _ ε2m_pos) as [δ1 [δ1_pos IHn]].
    destruct (polynomial_bounded (polynomial_xn real_cring n) (a-1) b) as [M' M'_max].
    pose (M := M' + 1).
    assert (0 < M) as M_pos.
    {
        specialize (M'_max a).
        rewrite polynomial_eval_xn in M'_max.
        prove_parts M'_max.
        {
            rewrite <- le_plus_a_0_ba_b.
            apply pos_neg.
            apply one_pos.
        }
        {
            apply cut_inout; assumption.
        }
        apply le_rplus with 1 in M'_max.
        apply (lt_le_trans2 M'_max).
        apply (lt_le_trans one_pos).
        rewrite <- le_plus_0_a_b_ab.
        apply abs_pos.
    }
    assert (∀ x, a - 1 ≤ x → x ≤ b → |(x^n)%nat| < M) as M_max.
    {
        intros x ax xb.
        specialize (M'_max x ax xb).
        rewrite polynomial_eval_xn in M'_max.
        apply (le_lt_trans M'_max).
        unfold M.
        rewrite <- lt_plus_0_a_b_ba.
        exact one_pos.
    }
    clearbody M.
    clear M' M'_max.
    pose (δ := min δ1 (min (ε / 2 / M) 1)).
    assert (0 < δ) as δ_pos.
    {
        unfold δ, min.
        case_if; [>|case_if].
        -   exact δ1_pos.
        -   apply lt_mult.
            +   exact ε2_pos.
            +   apply div_pos.
                exact M_pos.
        -   exact one_pos.
    }
    exists δ.
    split; [>exact δ_pos|].
    intros x y x_in y_in.
    do 2 rewrite nat_pow_suc.
    assert (∀ z, top_of_cut δ z → a - 1 < z ∧ z < b) as cut_ab.
    {
        intros z z_in.
        split.
        -   destruct z_in as [z_in z_nin].
            pose proof (cut_inout _ _ a_in z_nin) as ltq.
            assert (δ ≤ 1) as leq.
            {
                apply (trans (rmin _ _)).
                apply (rmin _ _).
            }
            apply le_lplus with z in leq.
            pose proof (lt_le_trans ltq leq) as ltq2.
            rewrite lt_plus_rrmove in ltq2.
            apply ltq2.
        -   apply cut_inout.
            +   apply z_in.
            +   exact b_in.
    }
    specialize (M_max y (land (land (cut_ab _ y_in)))
                        (land (rand (cut_ab _ y_in)))).
    assert (|x| < m) as x'_lt.
    {
        apply cut_ab in x_in as [x_gt x_lt].
        unfold m.
        unfold abs at 1; case_if.
        -   apply (lt_le_trans2 (rmax _ _)).
            rewrite (abs_pos_eq _ (land (le_lt_trans l x_lt))).
            exact x_lt.
        -   apply (lt_le_trans2 (lmax _ _)).
            rewrite nle_lt in n0.
            rewrite (abs_neg_eq _ (land (trans x_gt n0))).
            apply lt_neg.
            do 2 rewrite neg_neg.
            exact x_gt.
    }
    assert (|x - y| < ε / 2 / M) as xy_lt.
    {
        destruct x_in as [x_in x_nin].
        destruct y_in as [y_in y_nin].
        pose proof (cut_inout _ _ x_in y_nin) as ltq1.
        pose proof (cut_inout _ _ y_in x_nin) as ltq2.
        rewrite lt_plus_rlmove in ltq1, ltq2.
        rewrite plus_comm in ltq1.
        apply lt_neg in ltq2.
        rewrite neg_plus, neg_neg in ltq2.
        apply (lt_le_trans (rand (abs_lt _ _) (make_and ltq2 ltq1))).
        apply (trans (rmin _ _)).
        apply lmin.
    }
    assert (∀ z, top_of_cut δ z → top_of_cut δ1 z) as to_cut_in.
    {
        intros z.
        apply top_of_cut_in.
        apply lmin.
    }
    apply to_cut_in in x_in, y_in.
    specialize (IHn x y x_in y_in).
    rewrite <- (plus_lrinv y x) at 2.
    rewrite ldist.
    rewrite neg_plus.
    rewrite plus_assoc.
    rewrite <- mult_lneg.
    rewrite <- rdist.
    rewrite <- mult_rneg.
    rewrite neg_plus, neg_neg.
    apply (le_lt_trans (abs_tri _ _)).
    do 2 rewrite abs_mult.
    pose proof (lt_lrmult_pos _ _ _ _ (abs_pos _) (abs_pos _) IHn x'_lt)
        as ltq1.
    rewrite (mult_comm _ (|x - y|)).
    pose proof (lt_lrmult_pos _ _ _ _ (abs_pos _) (abs_pos _) xy_lt M_max)
        as ltq2.
    rewrite mult_rlinv in ltq1 by apply m_pos.
    rewrite mult_rlinv in ltq2 by apply M_pos.
    pose proof (lt_lrplus ltq1 ltq2) as ltq.
    rewrite plus_half in ltq.
    exact ltq.
Qed.

Theorem polynomial_continuous : ∀ (f : polynomial real_cring),
    ∀ ε, 0 < ε → ∃ δ, 0 < δ ∧ ∀ x y, top_of_cut δ x → top_of_cut δ y →
    |polynomial_eval f x - polynomial_eval f y| < ε.
Proof.
    intros f.
    induction f as [|f f' n fn fn' IHf] using grade_induction.
    {
        intros ε ε_pos.
        exists 1.
        split; [>exact one_pos|].
        intros x y x_in y_in.
        rewrite polynomial_eval_zero.
        rewrite polynomial_eval_zero.
        rewrite neg_zero, plus_rid.
        rewrite <- abs_zero.
        exact ε_pos.
    }
    intros ε ε_pos.
    apply polynomial_xn_ex in fn as [a f_eq]; subst f.
    pose proof (polynomial_continuous_xn n) as xn_lim.
    classic_case (0 = a) as [a_z|a_nz].
    {
        subst a.
        rewrite scalar_lanni.
        rewrite plus_lid.
        exact (IHf ε ε_pos).
    }
    assert (0 < |a|) as a_pos.
    {
        split.
        -   apply abs_pos.
        -   apply abs_nz.
            exact a_nz.
    }
    pose proof (div_pos a_pos) as a'_pos.
    pose proof (half_pos ε_pos) as ε2_pos.
    pose proof (lt_mult ε2_pos a'_pos) as ε2a_pos.
    specialize (IHf _ ε2_pos) as [δ1 [δ1_pos IHf]].
    specialize (xn_lim _ ε2a_pos) as [δ2 [δ2_pos xn_lim]].
    exists (min δ1 δ2).
    split; [>unfold min; case_if; assumption|].
    intros x y x_lt y_lt.
    specialize (IHf x y (top_of_cut_in _ _ _ (lmin _ _) x_lt)
                        (top_of_cut_in _ _ _ (lmin _ _) y_lt)).
    specialize (xn_lim x y (top_of_cut_in _ _ _ (rmin _ _) x_lt)
                           (top_of_cut_in _ _ _ (rmin _ _) y_lt)).
    rewrite <- lt_mult_lrmove_pos in xn_lim by exact a_pos.
    rewrite mult_comm in xn_lim.
    pose proof (lt_lrplus xn_lim IHf) as ltq.
    rewrite plus_half in ltq.
    apply (le_lt_trans2 ltq).
    do 2 rewrite polynomial_eval_plus.
    do 2 rewrite polynomial_eval_scalar.
    do 2 rewrite polynomial_eval_xn.
    rewrite <- abs_mult.
    rewrite ldist.
    rewrite mult_rneg.
    rewrite neg_plus.
    rewrite plus_assoc.
    rewrite <- (plus_assoc (a * (x^n)%nat)).
    rewrite (plus_comm _ (-(a * (y^n)%nat))).
    rewrite plus_assoc.
    rewrite <- (plus_assoc _ (polynomial_eval _ _)).
    apply abs_tri.
Qed.

End Analysis.