(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import fcf.FCF.
Require Import fcf.PRF.
Require Import fcf.CompFold.

Section PRF_Convert.

  Variable K D R : Set.
  Variable K' D' R' : Set.

  Hypothesis D'_EqDec : EqDec D'.
  Hypothesis R'_EqDec : EqDec R'.
  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.
  Hypothesis K_EqDec : EqDec K.

  Variable RndK' : Comp K'.
  Variable RndR : Comp R.

  Variable f : K -> D -> R.

  Variable k_f : K' -> K.
  Variable d_f : D' -> D.
  Hypothesis d_f_1_1 :
    forall x y,
      x <> y ->
      d_f x <> d_f y.

  Variable r_f : R -> R'.

  Definition f' (k : K')(d : D') : R' :=
      r_f (f (k_f k) (d_f d)).

  Definition RndR' :=
    r <-$ RndR;
    ret (r_f r).

  Definition RndK :=
    k <-$ RndK';
    ret (k_f k).

  Variable A : OracleComp D' R' bool.

  Definition f'_o (x : unit)(d : D') : OracleComp D R (R' * unit) :=
    r <--$ OC_Query _ (d_f d);
    $ ret (r_f r, tt).

  Definition A_f : OracleComp D R bool :=
    [b, _] <--$2 OC_Run _ _ _ A f'_o tt;
    $ ret b.

  Theorem PRF_Convert_Adv :
    PRF_Advantage RndK' RndR' f' _ _ A ==
    PRF_Advantage RndK RndR f _ _ A_f.

    unfold PRF_Advantage.
    eapply ratDistance_eqRat_compat.

    unfold PRF_G_A.
    unfold RndK.
    inline_first.
    comp_skip.
    comp_simp.
    unfold A_f.

    eapply comp_spec_eq_impl_eq.
    simpl.
    inline_first.
    comp_skip.
    eapply (oc_comp_spec_eq _ _ _ _ _ _ (fun a b => True)).
    intuition.
    intuition.
    unfold f_oracle.
    inline_first.
    comp_simp.
    inline_first.
    comp_simp.
    simpl.
    eapply comp_spec_ret.
    intuition.

    simpl in *.
    comp_simp.
    simpl.
    comp_simp.
    inline_first.
    comp_simp.
    intuition; subst.
    eapply comp_spec_ret; intuition.

    unfold PRF_G_B.
    unfold RndR'.
    unfold A_f.
    eapply comp_spec_eq_impl_eq.
    simpl.
    inline_first.
    comp_skip.
    eapply (oc_comp_spec_eq _ _ _ _ _ _
                            (fun a b =>
                               forall x,
                                 match (arrayLookup _ a x) with
                                   | None => arrayLookup _ (snd b) (d_f x) = None
                                   | Some y => exists y',
                                                 arrayLookup _ (snd b) (d_f x) = Some y'
                                                 /\ r_f y' = y
                                 end
                                   )
                            ).
    intuition.
    simpl.
    trivial.

    intuition.
    inline_first.

    unfold RndR_func, randomFunc.
    pose proof H.
    specialize (H a).

    case_eq ( arrayLookup D'_EqDec x1 a); intuition.
    rewrite H1 in H.
    destruct H.
    intuition.
    rewrite H2.
    comp_simp.
    subst.
    inline_first.
    comp_simp.
    simpl.
    eapply comp_spec_ret; intuition.

    rewrite H1 in H.
    rewrite H.

    inline_first.
    assert R.
    eapply comp_base_exists.
    eauto.
    comp_skip.

    comp_simp.
    inline_first.
    comp_simp.
    simpl.
    eapply comp_spec_ret; intuition.
    simpl.

    case_eq (eqb x a); intuition.
    rewrite eqb_leibniz in H5.
    subst.
    rewrite eqb_refl.
    econstructor.
    intuition.

    assert (eqb (d_f x) (d_f a) = false).
    case_eq ( eqb (d_f x) (d_f a)); intuition.
    rewrite eqb_leibniz in H6.
    exfalso.
    destruct (EqDec_dec _ x a).
    subst.
    rewrite eqb_refl in H5.
    discriminate.
    eapply d_f_1_1.
    intros.
    eapply n.
    eapply H7.
    trivial.

    rewrite H6.

    eapply H0.

    comp_simp.
    simpl in *.
    inline_first.
    comp_simp.
    intuition.
    subst.
    eapply comp_spec_eq_refl.

  Qed.

End PRF_Convert.


From isla Require Import opsem.

Definition a38 : isla_trace :=
  Smt (DeclareConst 50%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R19" [] (RegVal_Base (Val_Symbolic 50%Z)) Mk_annot :t:
  Smt (DefineConst 56%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Val (Val_Symbolic 50%Z) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R1" [] (RegVal_Base (Val_Symbolic 56%Z)) Mk_annot :t:
  Smt (DeclareConst 57%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 57%Z)) Mk_annot :t:
  Smt (DefineConst 58%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 57%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 58%Z)) Mk_annot :t:
  tnil
.


Require Import Cid.
Require Import Tid.
Require Import Mid.
Require Import Var.
Require Import Lang.

Definition t_store := MV.t type.
Definition t_taskmap := MT.t type.
Definition t_heap := MM.t type.

Section Checks.

  (** Type of tasks *)
  Variable TS: t_taskmap.

  (** Type of heap *)
  Variable HS: t_heap.

  (** Typecheck words. *)

  Inductive WCheck: word -> type -> Prop :=
  | w_check_num:
    forall n,
    WCheck (Num n) t_number
  | w_check_task:
    forall x t,
    MT.MapsTo x t TS ->
    WCheck (TaskLabel x) (t_task t)
  | w_check_heap:
    forall x t,
    MM.MapsTo x t HS ->
    WCheck (HeapLabel x) (t_ref t).

  (** Define the type of a code block (an arrow type). *)

  Structure t_code := {
    s_params: list type;
    s_ret: type
  }.

  (**
    Invoking a future of this code type, yields a
    type, which is a future of the return type.
    *)

  Definition t_future s := t_task (s_ret s).

  (** Defines the code segment type of a program. *)

  Definition t_code_segment := MC.t t_code.

  (** Type of the code fragments *)
  Variable CS: t_code_segment.

  Section Values.

    (** Type of store *)

    Variable LS: t_store.

   (** Typecheck a value *)

    Inductive VCheck: value -> type -> Prop :=
    | v_check_var:
      forall x t,
      MV.MapsTo x t LS ->
      VCheck (Var x) t
    | v_check_word:
      forall w t,
      WCheck w t ->
      VCheck (Word w) t.

    (** Type check a vector of values. *)

    Inductive VSCheck : list value -> list type -> Prop :=
    | vs_check_nil:
      VSCheck nil nil
    | vs_check_cons:
      forall v t vs ts,
      VCheck v t ->
      VSCheck vs ts ->
      VSCheck (v::vs) (t::ts).

    Inductive ECheck: expression -> type -> Prop :=
    | e_check_value:
      forall v t,
      VCheck v t ->
      ECheck (Value v) t
    | e_check_malloc:
      forall v t,
      VCheck v t ->
      ECheck (Malloc v) (t_ref t)
    | e_check_deref:
      forall v t,
      VCheck v (t_ref t) ->
      ECheck (Deref v) t
    | e_check_future:
      forall f vs s,
      MC.MapsTo f s CS ->
      VSCheck vs (s_params s) ->
      ECheck (Future f vs) (t_future s)
    | e_check_force:
      forall v t,
      VCheck v (t_task t) ->
      ECheck (Force v) t.

    Inductive ICheck: instruction -> t_store -> Prop :=
    | i_check_assign:
      forall x e t,
      ECheck e t ->
      ICheck (Assign x e) (MV.add x t LS)
    | i_check_store:
      forall v e t,
      VCheck v (t_ref t) ->
      ECheck e t ->
      ICheck (Store v e) LS.

  End Values.

  Inductive PCheck: t_store -> program -> type -> Prop :=
  | p_check_ret:
    forall s v t,
    VCheck s v t ->
    PCheck s (Ret v) t
  | p_check_seq:
    forall s i p s' t,
    ICheck s i s' ->
    PCheck s' p t ->
    PCheck s (Seq i p) t
  | p_check_if:
    forall s v p1 p2 t,
    VCheck s v t_number ->
    PCheck s p1 t ->
    PCheck s p2 t ->
    PCheck s (If v p1 p2) t.

End Checks.

Section State.
  Structure t_state := {
    t_s_heap: t_heap;
    t_s_tasks: t_taskmap;
    t_s_stores: MT.t t_store
  }.

  Variable cs: t_code_segment.

  Variable s: t_state.

  Let WCheck := WCheck (t_s_tasks s) (t_s_heap s).

  (* Check if a reference in the heap matches the expected type in t_heap. *)

  Inductive MidCheck (hs:heap) x : Prop :=
  | mid_check_def:
    forall w t,
    MM.MapsTo x w hs ->           (* H(x) = w) *)
    MM.MapsTo x t (t_s_heap s) -> (* \Gamma(x) = t *)
    WCheck w t ->                 (* |- w : t *)
    MidCheck hs x.

  (** Checks if all heaps in the heap are well typed. *)

  Definition HeapLabelCheck hs := forall m, MM.In m hs -> MidCheck hs m.

  (** Checks if all heap-type is in the heap *)

  Definition HeapLabelRange (hs:heap) := forall m, MM.In m (t_s_heap s) -> MM.In m hs.

  Inductive HeapCheck hs : Prop :=
  | heap_check_def:
    HeapLabelCheck hs ->
    HeapLabelRange hs ->
    HeapCheck hs.

  (** Check the local store *)

  Inductive VarCheck (m:store) (mt:t_store) (x:var) : Prop :=
  | var_check_def:
    forall w t,
    MV.MapsTo x w m ->  (* \sigma(x) = w *)
    MV.MapsTo x t mt -> (* \Gamma(x) = t *)
    WCheck w t ->       (* |- w : t *)
    VarCheck m mt x.

  Definition StoreVarCheck (m:store) mt := forall x, MV.In x m -> VarCheck m mt x.

  Definition StoreVarRange (m:store) (mt:t_store) := forall x, MV.In x mt -> MV.In x m.

  Inductive StoreCheck (m:store) (mt:t_store) : Prop :=
  | store_check_def:
    StoreVarCheck m mt ->
    StoreVarRange m mt ->
    StoreCheck m mt.

  Let PCheck := PCheck (t_s_tasks s) (t_s_heap s) cs.

  (** Check a task *)

  Inductive ProgramCheck (x:tid) (mt:t_store) (p:program) : Prop :=
  | program_check_def:
    forall t,
    MT.MapsTo x t (t_s_tasks s) -> (* get type of code *)
    PCheck mt p t -> (* check if the code matches its type *)
    ProgramCheck x mt p.

  Inductive TaskCheck (x:tid) : task -> Prop :=
  | t_check_def:
    forall m p mt,
    MT.MapsTo x mt (t_s_stores s) -> (* get type of store *)
    StoreCheck m mt -> (* check if store matches its type *)
    ProgramCheck x mt p -> (* check the program *)
    TaskCheck x (m, p).

  Definition TaskLabelCheck (ts:taskmap) := forall x e, MT.MapsTo x e ts -> TaskCheck x e.

  Definition TaskLabelRange (ts:taskmap) := forall x, MT.In x (t_s_tasks s) -> MT.In x ts.

  Inductive TMCheck tm : Prop :=
  | tm_check_def:
    TaskLabelCheck tm ->
    TaskLabelRange tm ->
    TMCheck tm.

  Inductive SCheck : state -> Prop :=
  | s_check_def:
    forall hs tm,
    TMCheck tm ->
    HeapCheck hs ->
    SCheck (hs,tm).

End State.

Section CodeSegment.

  (** Constructs a [t_store] from a list of variable names and a list of signature types. *)

  Definition mk_t_store (vs:list var) ts : t_store := MV_Props.of_list (List.combine vs ts).

  Variable s_t: t_state.

  Variable c_t: t_code_segment.

  Let PCheck := PCheck (t_s_tasks s_t) (t_s_heap s_t) (c_t).

  Inductive CodeCheck (x:cid) (c:code) : Prop :=
  | code_check_def:
    forall t,
    MC.MapsTo x t c_t ->
    length (c_vars c) = length (s_params t) ->
    PCheck (mk_t_store (c_vars c) (s_params t)) (c_program c) (s_ret t) ->
    CodeCheck x c.

  Definition CodeLabelCheck (cs:code_segment) := forall x c, MC.MapsTo x c cs -> CodeCheck x c.

  Definition CodeLabelRange (cs:code_segment) := forall x, MC.In x c_t -> MC.In x cs.

  Inductive CSCheck (cs:code_segment) : Prop :=
  | cs_check_def:
    CodeLabelCheck cs ->
    CodeLabelRange cs ->
    CSCheck cs.

End CodeSegment.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv0 lv1))).
Admitted.
QuickChick conj14eqsynthconj1.


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

(***
Modulus : 2^190 - 11
Base: 38
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 38;
    bitwidth := 64;
    s := 2^190;
    c := [(1, 11)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal86.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (IHx:@eq natural (mult (plus x y) z) (plus (mult x z) (mult y z))):@eq natural (plus (plus (mult x z) (mult y z)) z)
  (plus (plus (mult x z) z) (mult y z)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal86_distrib_96_plus_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z.
QuickChick collect_data.
Success.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Extraction of [nat] into Ocaml's [int] *)

Require Import Arith Even Div2 EqNat Euclid.
Require Import ExtrOcamlBasic.

(** Disclaimer: trying to obtain efficient certified programs
    by extracting [nat] into [int] is definitively *not* a good idea:

    - Since [int] is bounded while [nat] is (theoretically) infinite,
    you have to make sure by yourself that your program will not
    manipulate numbers greater than [max_int]. Otherwise you should
    consider the translation of [nat] into [big_int].

    - Moreover, the mere translation of [nat] into [int] does not
    change the complexity of functions. For instance, [mult] stays
    quadratic. To mitigate this, we propose here a few efficient (but
    uncertified) realizers for some common functions over [nat].

    This file is hence provided mainly for testing / prototyping
    purpose. For serious use of numbers in extracted programs,
    you are advised to use either coq advanced representations
    (positive, Z, N, BigN, BigZ) or modular/axiomatic representation.
*)

(** Mapping of [nat] into [int]. The last string corresponds to
    a [nat_case], see documentation of [Extract Inductive]. *)

Extract Inductive nat => int [ "0" "succ" ]
 "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

(** Efficient (but uncertified) versions for usual [nat] functions *)

Extract Constant plus => "(+)".
Extract Constant pred => "fun n -> max 0 (n-1)".
Extract Constant minus => "fun n m -> max 0 (n-m)".
Extract Constant mult => "( * )".
Extract Inlined Constant max => max.
Extract Inlined Constant min => min.
Extract Inlined Constant nat_beq => "(=)".
Extract Inlined Constant EqNat.beq_nat => "(=)".
Extract Inlined Constant EqNat.eq_nat_decide => "(=)".

Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".

Extract Constant Compare_dec.nat_compare =>
 "fun n m -> if n=m then Eq else if n<m then Lt else Gt".
Extract Inlined Constant Compare_dec.leb => "(<=)".
Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
Extract Constant Compare_dec.lt_eq_lt_dec =>
 "fun n m -> if n>m then None else Some (n<m)".

Extract Constant Even.even_odd_dec => "fun n -> n mod 2 = 0".
Extract Constant Div2.div2 => "fun n -> n/2".

Extract Inductive Euclid.diveucl => "(int * int)" [ "" ].
Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)".
Extract Constant Euclid.quotient => "fun n m -> m/n".
Extract Constant Euclid.modulo => "fun n m -> m mod n".

(*
Definition test n m (H:m>0) :=
 let (q,r,_,_) := eucl_dev m H n in
 nat_compare n (q*m+r).

Recursive Extraction test fact.
*)


From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From compcert Require Import common.Values.
From compcert Require Import lib.Integers.

From VST Require Import floyd.proofauto.

Local Open Scope Z.

Definition int_or_ptr__is_valid_int (x: val): Prop :=
  if Archi.ptr64
  then
    match x with
    | Vlong i => Int64.testbit i 0 = true
    | _ => False
    end
  else
    match x with
    | Vint i => Int.testbit i 0 = true
    | _ => False
    end.

Definition int_or_ptr__is_valid_ptr (x: val): Prop :=
  match x with
  | Vptr _ z => Ptrofs.testbit z 0 = false /\ Ptrofs.testbit z 1 = false
  | _ => False
  end.

Definition int_or_ptr__is_valid (x: val): Prop :=
  int_or_ptr__is_valid_int x \/ int_or_ptr__is_valid_ptr x.

Definition int_or_ptr: Type := option {p: val | int_or_ptr__is_valid p}.

#[global]Instance int_or_ptr__Inhabitant (X: Type) : (Inhabitant int_or_ptr) := None.

Definition int_or_ptr__to_val (x: int_or_ptr): val
 := match x with
    | None => Vundef
    | Some v => proj1_sig v
    end.

Lemma int_or_ptr__to_val__is_valid (x: int_or_ptr) (Hx: x <> None):
  int_or_ptr__is_valid (int_or_ptr__to_val x).
Proof.
  destruct x as [x|] ; try congruence.
  apply (proj2_sig x).
Qed.

Definition int_or_ptr__is_int (x: val): bool
 := if Archi.ptr64
    then
      match x with
      | Vlong _ => true
      | _ => false
      end
    else
      match x with
      | Vint _ => true
      | _ => false
      end.

Lemma int_or_ptr__is_int__true (x: val):
  (int_or_ptr__is_valid x /\ int_or_ptr__is_int x = true)
  <-> int_or_ptr__is_valid_int x.
Proof.
  split.
  - intros [Hx E].
    destruct Hx as [Hx|Hx] ; now destruct x.
  - intro H.
    unfold int_or_ptr__is_valid.
    destruct x ; intuition easy.
Qed.

Lemma int_or_ptr__is_int__false (x: val):
  (int_or_ptr__is_valid x /\ int_or_ptr__is_int x = false)
  <-> int_or_ptr__is_valid_ptr x.
Proof.
  split.
  - intros [Hx e].
    destruct Hx as [Hx|Hx] ; now destruct x.
  - intro H.
    unfold int_or_ptr__is_valid.
    destruct x ; intuition easy.
Qed.

Lemma int64__odd__and_one (i: int64) (Hodd: Z.odd (Int64.unsigned i) = true):
  Int64.repr 1 = Int64.and i (Int64.repr 1).
Proof.
  destruct i as [i Hi].
  destruct i ; try lia ; try easy.
  unfold Int64.and.
  f_equal.
  simpl in *.
  clear -Hodd.
  change
    (Int64.unsigned (Int64.repr 1))
    with 1.
  simpl.
  change
    1
    with (Z.of_N (1)%N).
  f_equal.
  now destruct p.
Qed.

Lemma int__odd__and_one (i: int) (Hodd: Z.odd (Int.unsigned i) = true):
  Int.repr 1 = Int.and i (Int.repr 1).
Proof.
  destruct i as [i Hi].
  destruct i ; try lia ; try easy.
  unfold Int.and.
  f_equal.
  simpl in *.
  clear -Hodd.
  change
    (Int.unsigned (Int.repr 1))
    with 1.
  simpl.
  change
    1
    with (Z.of_N (1)%N).
  f_equal.
  now destruct p.
Qed.


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

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

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype.
From LemmaOverloading
Require Import prelude prefix xfind heaps terms.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(******************************************************************************)
(* cancelR :                                                                  *)
(*   Lemma automated with Canonical Structures to cancel heap expressions.    *)
(*   Usage:                                                                   *)
(*     apply (cancelR D) in H                                                 *)
(*   where D : def h1 and H : h1 = h2                                         *)
(******************************************************************************)

(* Syntactification of heaps *)
Section HeapReflection.

(* The algorithm works as follow:
   - if the heap is h1 :+ h2 then recurse over both and concatenate the results
   - if the heap is the empty heap, return []
   - if the heap is p :-> v then add p to the context, and return [Pts x v],
     where x is the deBruijn index for p in the context
   - if the heap is whatever else, add the heap to the context and return
     [Var n], where n is the deBruijn index for the heap in the context
 *)

(* a tagging structure to control the flow of computation *)
Structure tagged_heap := Tag {untag :> heap}.

(* in reversed order; first test for unions, then empty, pts and vars *)
Definition var_tag := Tag.
Definition pts_tag := var_tag.
Definition empty_tag := pts_tag.
Canonical Structure union_tag hc := empty_tag hc.

Definition invariant i j t h := [/\ interp j t = h, subctx i j & valid j t].

(* Main structure
   i : input context
   j : output context
   t : syntactification of heap_of using context j *)
Structure ast (i j : ctx) (t : synheap) :=
  Ast {heap_of :> tagged_heap;
       _ : invariant i j t heap_of}.

Arguments Ast : clear implicits.

Lemma union_pf i j k t1 t2 (f1 : ast i j t1) (f2 : ast j k t2) :
        invariant i k (t1 ++ t2) (union_tag (f1 :+ f2)).
Proof.
case: f1 f2=>h1 /= [<- S1 D1] [h2 /= [<- S2 D2]].
split; first by rewrite interp_cat (interp_subctx D1 S2).
- by apply: (subctx_trans S1 S2).
by rewrite valid_cat D2 andbT; apply: (valid_subctx S2).
Qed.

(* pass output context of f1 as input of f2 *)
Canonical Structure
  union_struct i j k t1 t2 (f1 : ast i j t1) (f2 : ast j k t2) :=
  Ast i k _ (union_tag (f1 :+ f2)) (union_pf f1 f2).

Lemma empty_pf i : invariant i i [::] (empty_tag empty).
Proof. split; by [|apply: subctx_refl|]. Qed.

Canonical Structure empty_struct i :=
  Ast i i [::] (empty_tag empty) (empty_pf i).

Lemma pts_pf A hs xs1 xs2 x (d : A) (xs : xfind xs1 xs2 x):
        invariant (Context hs xs1) (Context hs xs2)
                  [:: Pts x (dyn d)] (pts_tag (xuntag xs :-> d)).
Proof.
case: xs=>[p /= [H P]]; split; first by rewrite /= H.
- by split; [apply: prefix_refl|].
by apply/andP; rewrite /= (onth_size H).
Qed.

Canonical Structure
  pts_struct A hs xs1 xs2 x (d : A)
           (xs : xfind xs1 xs2 x) :=
  Ast (Context hs xs1) (Context hs xs2)
       [:: Pts x (dyn d)]
       (pts_tag (xuntag xs :-> d))
       (pts_pf hs _ xs).

Lemma var_pf hs1 hs2 xs n (f : xfind hs1 hs2 n) :
        invariant (Context hs1 xs) (Context hs2 xs) [:: Var n] (var_tag (xuntag f)).
Proof.
case:f=>p [H1 H2]; split; first by rewrite /= /hlook H1.
- by split; [|apply: prefix_refl].
by apply/andP; rewrite /= (onth_size H1).
Qed.

Canonical Structure var_struct hs1 hs2 xs n (f : xfind hs1 hs2 n) :=
  Ast (Context hs1 xs) (Context hs2 xs) _
      (var_tag (xuntag f))
      (var_pf xs f).

End HeapReflection.

(* The main lemma *)
Theorem cancelR j k t1 t2 (f1 : ast empc j t1) (f2 : ast j k t2) :
        def (untag (heap_of f1)) ->
        untag (heap_of f1) = untag (heap_of f2) ->
        eval k (cancel k t1 t2).
Proof.
case: f1 f2=>hp1 /= [<- _ I] [hp2 /= [<- S _]] D H.
by apply: cancel_sound; rewrite -(interp_subctx I S).
Qed.

(************)
(* Examples *)
(************)
Example ex0 x (v1 v2:nat):
          def (x :-> v1) -> x :-> v1 = x :-> v2 ->
          v1 = v2.
move=>D H.
Time set H' := (cancelR D H).
Time by rewrite (dyn_inj H').
Time Qed.

Set Printing Implicit.

Example ex1 x h (v1 v2:nat):
          def (x :-> v1 :+ h) -> x :-> v1 :+ h = x :-> v2 ->
          if v1 == v2 then true else false.
move=>D H.
by rewrite (dyn_inj (proj2 (cancelR D H))) eq_refl.
Qed.

Example ex2 h1 h2 h3 h4 x1 x2 (d1 d2 d3 d4 : nat) :
     def ((h3 :+ (x1 :-> d1)) :+ (h1 :+ empty) :+ (x2 :-> d2)) ->
     (h3 :+ (x1 :-> d1)) :+ (h1 :+ empty) :+ (x2 :-> d2) =
     (x2 :-> d3) :+ (h2 :+ empty :+ h3) :+ h4 :+ (x1 :-> d4) ->
     d1 = d4 /\ d2 = d3 /\ h1 = h2 :+ h4.
move=>D.
move/(cancelR D)=>/= [->][].
by move/dyn_inj=>->; move/dyn_inj=>->.
Qed.

Example ex1' x h (v1 v2:nat):
          def (x :-> v1 :+ h) -> x :-> v1 :+ h = x :-> v2 ->
          v1 = v2.
move=>D H.
set H' := cancelR D H.
simpl in H'.
by apply: (dyn_inj (proj2 (cancelR D H))).
Qed.

Example stress
     (h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 : heap)
     (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 : ptr) :
     def (h1 :+ h2 :+ h3 :+ h4 :+ h5 :+ h6 :+ h7 :+ h8 :+ h9 :+ h10 :+
     x1 :-> 1 :+ x2 :-> 2 :+ x3 :-> 3 :+ x4 :-> 4 :+ x5 :-> 5 :+
     x6 :-> 6 :+ x7 :-> 7 :+ x8 :-> 8 :+ x9 :-> 9 :+ x10 :-> 10) ->
     h1 :+ h2 :+ h3 :+ h4 :+ h5 :+ h6 :+ h7 :+ h8 :+ h9 :+ h10 :+
     x1 :-> 1 :+ x2 :-> 2 :+ x3 :-> 3 :+ x4 :-> 4 :+ x5 :-> 5 :+
     x6 :-> 6 :+ x7 :-> 7 :+ x8 :-> 8 :+ x9 :-> 9 :+ x10 :-> 10 =
     x1 :-> 1 :+ x2 :-> 2 :+ x3 :-> 3 :+ x4 :-> 4 :+ x5 :-> 5 :+
     h1 :+ h2 :+ h3 :+ h4 :+ h5 :+ h6 :+ h7 :+ h8 :+ h9 :+ h10 :+
     x6 :-> 6 :+ x7 :-> 7 :+ x8 :-> 8 :+ x9 :-> 9 :+ x10 :-> 10 ->
     True.
move=>D.
Time move/(cancelR D)=>/=.
by [].
Time Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr Yves.Bertot Frederique.Guilhot    *)
(*  &all    Inria, 2006                                      *)
(*************************************************************)

Require Export Reals.
Require Export Fourier.
Require Export PolTac.
Import PolAux.

Open Scope R_scope.

Theorem Rplus_pos_le :
  forall x y, 0 <= y -> x <= x + y.
intros; fourier.
Qed.

Theorem prod_pos_hyp : forall x y, 0 < x -> 0 <= x*y -> 0 <= y.
intros x y H [Hlt | Heq].
left; apply Rlt_sign_pos_pos_rev with (1:= H); auto.
right; replace y with ((x*y)*/x).
rewrite <- Heq; ring.
field; auto with real.
Qed.

Parameter Rpol : Set.

Bind Scope Rpol_scope with Rpol.
Delimit Scope Rpol_scope with P.

Parameter Pnorm : Rpol -> Rpol.

Parameter Rpol_mult : Rpol -> Rpol -> Rpol.

Parameter Rpol_plus : Rpol -> Rpol -> Rpol.

Parameter X : Rpol.

Parameter Pc : R -> Rpol.

Parameter P0 : Rpol.

Parameter Rpol_exp : Rpol -> nat -> Rpol.

Infix "^" := Rpol_exp : Rpol_scope.

Definition Rpol_decompose_Horner :
  forall P:Rpol,
    {c:R | Pnorm P = Pc c}+
    {c:R & { n:nat &
        { Q :Rpol | (0 < n)%nat /\ Pnorm P = Pnorm (Pc c + X^n * Q) /\
                   ~Pnorm Q = P0}}}.
Admitted.

Parameter smaller_degree : Rpol -> Rpol -> Prop.

Theorem smaller_degree_wf : well_founded smaller_degree.
Admitted.

Theorem smaller_degree_step :
 forall P Q c n, Pnorm P = Pnorm (Pc c + X^n * Q) ->
    Pnorm Q <> P0 -> smaller_degree Q P.
Admitted.

Parameter Rpol_eval : Rpol -> R -> R.

Infix "*" := Rpol_mult : Rpol_scope.
Infix "+" := Rpol_plus : Rpol_scope.

Axiom eval_X : forall x, Rpol_eval X x = x.

Axiom eval_c : forall x y, Rpol_eval (Pc x) y = x.

Axiom eval_mult : forall P1 P2 x, Rpol_eval (P1 * P2)%P x =
   Rpol_eval P1 x * Rpol_eval P2 x.

Axiom eval_plus : forall P1 P2 x, Rpol_eval (P1 + P2)%P x =
    Rpol_eval P1 x + Rpol_eval P2 x.

Axiom eval_exp : forall P n x, Rpol_eval (P^n) x = Rpol_eval P x^n.

Axiom Pnorm_ext : forall P Q, (forall x, Rpol_eval P x = Rpol_eval Q x) ->
  Pnorm P = Pnorm Q.

Parameter least_non_zero_coeff : Rpol -> R.

Theorem least_non_zero_P1 :
  forall P, Pnorm P <> P0 -> ~least_non_zero_coeff P = 0.
Admitted.

Theorem least_non_zero_P2 :
  forall P,
  exists n:nat, exists Q: Rpol,
    Pnorm P = Pnorm (X^n*(Pc (least_non_zero_coeff P) + X * Q)).
Admitted.

Theorem least_non_zero_P3 :
  forall P, Pnorm P = P0 -> least_non_zero_coeff P = 0.
Admitted.

Theorem least_non_zero_P4 :
  forall P b n Q, Pnorm P = Pnorm (X^n * (Pc b + X * Q)) -> ~b=0 ->
            least_non_zero_coeff P = b.
Admitted.

Axiom least_non_zero_P5 :
  forall P b, Pnorm P = Pc b -> least_non_zero_coeff P = b.

Axiom least_non_zero_P6 :
  forall n P Q a, Pnorm P = Pnorm (X^n * (Pc a + X * Q)) -> a = 0 ->
    least_non_zero_coeff P = least_non_zero_coeff Q.

Axiom Pnorm_cte : forall c, Pnorm (Pc c) = Pc c.

Theorem least_non_zero_P7 :
  forall b, least_non_zero_coeff (Pc b) = b.
intros b; apply least_non_zero_P5; trivial.
apply Pnorm_cte.
Qed.

Axiom least_non_zero_Pnorm :
  forall P Q, Pnorm P = Pnorm Q ->
  least_non_zero_coeff P = least_non_zero_coeff Q.

(* Parameter Rpol_degree : Rpol -> nat.

Theorem Rpol_decompose_degree :
  forall P c n Q, Pnorm P = Pnorm (Pc c + X^n * Q) ->
  Pnorm Q <> P0 -> Rpol_degree P = (Rpol_degree Q + n)%nat.
Admitted.
*)

Axiom Rpol_eval_Pnorm :
  forall P x, Rpol_eval (Pnorm P) x = Rpol_eval P x.

Axiom Pnorm_plus : forall a a' b b', Pnorm a = Pnorm a' ->
   Pnorm b = Pnorm b' -> Pnorm (a + b) = Pnorm (a' + b').

Axiom Pnorm_mult : forall a a' b b', Pnorm a = Pnorm a' ->
   Pnorm b = Pnorm b' -> Pnorm (a * b) = Pnorm (a' * b').

Axiom Pnorm_exp : forall a a' n, Pnorm a = Pnorm a' ->
  Pnorm (a^n)=Pnorm (a'^n).

Axiom Pnorm_exp1 : forall X n, Pnorm (X^n) = Pnorm X.

Hint Rewrite eval_mult eval_plus eval_c eval_X eval_exp Rpol_eval_Pnorm : Rpol.

Inductive no_alternation : Rpol -> Set :=
  no_alternation_c1 : forall c, no_alternation (Pc c)
| no_alternation_c2 :
    forall n a P Q,
      no_alternation Q -> a <> 0 -> 0 <= a*(least_non_zero_coeff Q) ->
      Pnorm P = Pnorm (X^n *(Pc a+X*Q)) -> no_alternation P.

Inductive one_alternation : Rpol -> Set :=
  one_alternation_here :
    forall P a n Q, (1 <= n)%nat ->
      Pnorm P = Pnorm (X^n *(Pc a + X * Q)) ->
      a * least_non_zero_coeff Q < 0 -> no_alternation Q ->
      one_alternation P
| one_alternation_step :
    forall P a n Q,
      Pnorm P = Pnorm (X^n * (Pc a + X * Q)) ->
      one_alternation Q -> 0 < a * least_non_zero_coeff Q ->
      one_alternation P.

Theorem no_alternation_increasing :
  forall P, 0 <= least_non_zero_coeff P -> no_alternation P ->
  forall x y, 0 <= x <= y -> 0 <= Rpol_eval P x <= Rpol_eval P y.
Admitted.

Theorem no_alternation_increasing' :
  forall P, 0 <= least_non_zero_coeff P -> no_alternation P ->
  forall x y, 0 <= x <= y -> Rpol_eval P x <= Rpol_eval P y.
intros; assert (0 <= Rpol_eval P x <= Rpol_eval P y).
apply no_alternation_increasing; auto.
intuition.
Qed.

Theorem no_alternation_positive :
  forall P, no_alternation P -> 0 <= least_non_zero_coeff P ->
  forall x, 0 <= x -> 0 <= Rpol_eval P x.
intros P Hna Hpos x Hposx.
elim (least_non_zero_P2 P); intros n [Q Heq].
apply Rle_trans with (Rpol_eval P 0).
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
destruct (zerop n) as [Hn0 | H0ltn].
subst n.
rewrite pow_O.
rewrite Rmult_1_l; rewrite Rmult_0_l; rewrite Rplus_0_r.
assumption.
rewrite pow_i;[fourier | assumption].
elim (no_alternation_increasing P Hpos Hna 0 x); intros; auto.
split; fourier.
Qed.

Theorem no_alternation_positive_st :
  forall P, no_alternation P -> 0 < least_non_zero_coeff P ->
  forall x, 0 < x -> 0 < Rpol_eval P x.
intros P' H; elim H.
intros; autorewrite with Rpol.
rewrite least_non_zero_P7 in H0; auto.
intros n a P Q HnaQ IHQ Ha Hprodpos Heq Hpos x Hxpos.

(* elim (Rlt_le_dec 0 a).
intros Ha'. *)
assert (least_non_zero_coeff P = a).
apply least_non_zero_P4 with (1:= Heq).
assumption.
assert (Hpartpos : 0 <= x * Rpol_eval Q x).
apply Rmult_le_pos.
fourier.
apply no_alternation_positive; auto.
apply prod_pos_hyp with a; auto.
fourier.
fourier.
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
apply Rmult_lt_0_compat.
apply pow_lt; auto.
fourier.
Qed.

Theorem Rmult_minus_distr_r :
  forall x y z, ((x - y)* z= x*z - y * z)%R.
intros; ring.
Qed.

Theorem exp_grows :
  forall u n, 1 <= u -> (1 <= n)%nat -> u <= u ^ n.
intros; pattern u at 1; replace u with (u^1).
apply Rle_pow; auto.
simpl; ring.
Qed.

Axiom intermediate_value_Rpol :
  forall P x y, x < y -> Rpol_eval P x * Rpol_eval P y < 0 ->
  exists z, x < z < y /\ Rpol_eval P z = 0.

Theorem increasing_pos_horner :
  forall a Q,
  a < 0 ->
  forall r,
  0 <= r ->
  (forall x y, r < x <= y -> 0 < Rpol_eval Q x <= Rpol_eval Q y) ->
  0 < Rpol_eval (Pc a + X * Q) (r+1 -a /Rpol_eval Q (r+1)).
intros a Q Halt0 r Hrpos HQincr.
assert (Hb1: r < r+1 <= r+1).
split;fourier.
assert (HQr1pos : 0 < Rpol_eval Q (r+1)).
generalize (HQincr _ _ Hb1); intuition.
assert (Hpos : 0 < -(a/Rpol_eval Q(r+1))).
unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse.
apply Rlt_mult_inv_pos.
fourier.
assumption.
assert (Hpos' : 0 < r+1 - a/Rpol_eval Q (r+1)).
fourier.
assert (Hlt : r < r+1 <= r+1 - a/Rpol_eval Q (r+1)).
split; fourier.
autorewrite with Rpol.
apply Rlt_le_trans with (a + (r+1-a/Rpol_eval Q (r+1))*(Rpol_eval Q (r+1))).
rewrite Rmult_minus_distr_r.
match goal with |- (0 < ?x) =>
   replace x with ((r + 1) * Rpol_eval Q (r + 1))
end.
apply Rlt_sign_pos_pos.
fourier.
assumption.
field.
auto with real.
pols.
apply Rmult_le_compat_l.
generalize (HQincr _ _ Hlt); intuition.
decompose [and] Hlt; fourier.
Qed.

Theorem no_alternation_tech :
  forall Q a, a < 0 -> 0 < least_non_zero_coeff Q -> no_alternation Q ->
  0 < 1 - a / Rpol_eval Q 1.
intros Q a Haneg HQpos Hna.
assert (HQpos' : 0 < Rpol_eval Q 1).
apply no_alternation_positive_st; auto with real.
apply Rlt_trans with (1+0).
fourier.
unfold Rminus, Rdiv; apply Rplus_lt_compat_l.
rewrite <- Ropp_mult_distr_l_reverse.
apply Rlt_mult_inv_pos.
fourier.
auto.
Qed.

Theorem alternation_here_pos_value :
  forall  Q a, a < 0 -> 0 < least_non_zero_coeff Q ->
    no_alternation Q ->
    0 < Rpol_eval (Pc a+X*Q) (1 - a / (Rpol_eval Q 1)).
intros Q a Haneg HposQ Hnoalt.
replace (1-a/Rpol_eval Q 1) with (0 + 1 - a /Rpol_eval Q (0+1)).
apply increasing_pos_horner; auto with real.
intros x y [Hlt Hle]; split.
apply no_alternation_positive_st; auto with real.
apply no_alternation_increasing'; auto with real.
replace (0+1) with 1; trivial.
ring.
Qed.

Theorem alternation_here_root :
  forall Q a, a < 0 -> 0 < least_non_zero_coeff Q ->
    no_alternation Q ->
    (exists r, 0 < r /\ Rpol_eval (Pc a + X * Q) r = 0 /\
               (forall x y, r < x <= y ->
               0 < Rpol_eval (Pc a + X * Q) x <= Rpol_eval (Pc a + X * Q) y) /\
               forall x, 0 < x < r -> Rpol_eval (Pc a + X * Q) x < 0).
intros Q a Haneg HQpos Hna.
elim (intermediate_value_Rpol (Pc a + X * Q) 0 (1 - a/(Rpol_eval Q 1))).
intros r [Hintr Hroot].
exists r; split.
intuition.
split.
assumption.
split.
intros x y Hcmpxy.
autorewrite with Rpol.
split.
rewrite <- Hroot; autorewrite with Rpol.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (r*Rpol_eval Q x).
apply Rmult_le_compat_l.
apply no_alternation_increasing'; auto.
fourier.
split; intuition.
intuition.
apply Rmult_lt_compat_r.
apply no_alternation_positive_st; auto.
intuition; fourier.
intuition.
apply Rplus_le_compat_l.
assert (0 <= x).
intuition; fourier.
assert (0 <= y).
intuition; fourier.
apply Rle_trans with (x *  Rpol_eval Q y).
apply Rmult_le_compat_l; auto with real.
apply no_alternation_increasing'; auto.
fourier.
intuition.
apply Rmult_le_compat_r.
apply no_alternation_positive;auto.
fourier.
intuition.
intros x [Hxpos Hxltr]; rewrite <- Hroot.
autorewrite with Rpol.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (x*Rpol_eval Q r).
apply Rmult_le_compat_l; auto.
auto with real.
apply no_alternation_increasing'; auto with real.
intuition.
apply Rmult_lt_compat_r; auto with real.
apply no_alternation_positive_st; auto with real.
fourier.
apply no_alternation_tech; auto.
assert (0 < Rpol_eval(Pc a+X*Q)(1-a/Rpol_eval Q 1)).
apply alternation_here_pos_value;auto.
pattern 0 at 2; replace 0 with
   (0 * Rpol_eval (Pc a + X *Q) (1-a/Rpol_eval Q 1)).
apply Rmult_lt_compat_r.
apply alternation_here_pos_value; auto.
autorewrite with Rpol.
rewrite Rmult_0_l; rewrite Rplus_0_r; auto.
ring.
Qed.

Theorem increasing_horner_root :
 forall a r' Q, a < 0 -> 0 < r' -> Rpol_eval Q r' = 0 ->
 (forall x : R, 0 < x < r' -> Rpol_eval Q x < 0) ->
 (forall x y : R, r' < x <= y -> 0 < Rpol_eval Q x <= Rpol_eval Q y) ->
 exists r, 0 < r /\ Rpol_eval (Pc a + X * Q) r = 0 /\
   (forall x y:R, r < x <= y -> 0 < Rpol_eval (Pc a + X * Q) x <=
                                    Rpol_eval (Pc a + X * Q) y) /\
   (forall x : R, 0 < x < r -> Rpol_eval (Pc a + X * Q) x < 0).
intros a r' Q Halt0 Hr'pos Hroot' HQneg HQincr.
assert (Hr'pos' : 0 <= r').
intuition.
generalize (increasing_pos_horner a Q Halt0 r' Hr'pos' HQincr).
intros Hpos.
elim (intermediate_value_Rpol (Pc a + X * Q) r'
         (r' + 1 - a/(Rpol_eval Q (r'+1)))).
intros r [[Hr'ltr _] Hroot].
exists r.
split.
fourier.
split.
assumption.
split.
intros x y [Hrltx Hxley]; split.
rewrite <- Hroot.
autorewrite with Rpol.
pols.
apply Rlt_le_trans with (x*Rpol_eval Q r).
assert (Hb1 : r' < r <= r).
auto with real.
assert (0 < Rpol_eval Q r).
generalize (HQincr r r Hb1);intuition.
polf.
apply Rmult_le_compat_l.
assert (Hb2 : r' < r <= x).
split;fourier.
generalize (HQincr r x Hb2); intuition.
fourier.
assert (r' < x <= y).
split; fourier.
autorewrite with Rpol.
pols.
apply Rle_trans with (x*Rpol_eval Q y).
apply Rmult_le_compat_l.
assert (Hb :r' < x <= y).
split; fourier.
generalize (HQincr x y Hb);intuition.
fourier.
assert (Hb : r' < y <= y).
split; fourier.
apply Rmult_le_compat_r.
auto.
generalize (HQincr y y Hb); intuition.
auto.
intros x [Hxpos Hxltr].
autorewrite with Rpol.
elim (Rlt_le_dec x r').
intros Hxltr'.
polr Halt0.
fourier.
RSignTac.rsign_tac0.
intros [Hr'ltx | Hr'eqx].
rewrite <- Hroot.
autorewrite with Rpol.
pols.
apply Rle_lt_trans with (x * Rpol_eval Q r).
RSignTac.rsign_tac.
assert (Hb :r' < x <= r).
auto with real.
generalize (HQincr _ _ Hb); intuition.
assert (0 < Rpol_eval Q r).
assert (Hb: r' < r <= r).
auto with real.
generalize (HQincr _ _ Hb); intuition.
polf.
rewrite <- Hr'eqx; rewrite Hroot'; pols.
assumption.
pols.
assert (0 < -(a/Rpol_eval Q (r'+1))).
assert (0 < Rpol_eval Q (r'+1)).
assert (Hb: r' < r'+1 <= r'+1).
auto with real.
generalize (HQincr _ _ Hb);intuition.
unfold Rdiv.
rewrite <- Ropp_mult_distr_l_reverse.
apply Rlt_mult_inv_pos.
fourier.
assumption.
fourier.
RSignTac.rsign_tac0.
autorewrite with Rpol.
rewrite Hroot'.
pols.
assumption.
Qed.

Theorem one_alternation_root_main :
  forall P, one_alternation P -> least_non_zero_coeff P < 0 ->
    (exists a, 0 < a /\ Rpol_eval P a = 0 /\
               (forall x y, a < x <= y -> 0 < Rpol_eval P x <= Rpol_eval P y)
    /\
               forall x, 0 < x < a -> Rpol_eval P x < 0).
intros P H; elim H; clear H P.
intros P a n Q Hnnz Heq Hneg Hna Hneg_coeff.
assert (Halt0 : a < 0).
rewrite <- (least_non_zero_P4 P _ _ _ Heq).
assumption.
intros Heq0; rewrite Heq0 in Hneg; rewrite Rmult_0_l in Hneg.
elim (Rlt_irrefl 0); assumption.
assert (HlcQ : 0 < least_non_zero_coeff Q).
apply Rlt_sign_neg_pos_rev with a; auto.
elim (alternation_here_root Q a); auto.
intros r [Hrpos [Hroot [Hpos_part Hneg_part]]].
exists r; split.
auto.
split.
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
generalize Hroot; autorewrite with Rpol; intros Hroot'; rewrite Hroot'.
ring.
split.
intros x y [Hrltx Hxley]; split.
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
apply Rmult_lt_0_compat.
apply pow_lt; fourier.
rewrite <- Hroot; autorewrite with Rpol.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (r * Rpol_eval Q x).
apply Rmult_le_compat_l; auto with real.
apply no_alternation_increasing'; auto with real.
apply Rmult_lt_compat_r.
apply no_alternation_positive_st; auto with real.
fourier.
assumption.
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
rewrite <- (Rpol_eval_Pnorm P); rewrite Heq; autorewrite with Rpol.
apply Rmult_le_compat.
apply pow_le; fourier.
rewrite <- Hroot; autorewrite with Rpol.
apply Rplus_le_compat_l.
apply Rmult_le_compat.
fourier.
apply no_alternation_positive; auto with real.
auto with real.
apply no_alternation_increasing'; auto with real.
apply pow_incr; split; fourier.
apply Rplus_le_compat_l.
apply Rmult_le_compat.
fourier.
apply no_alternation_positive; auto with real.
fourier.
auto.
apply no_alternation_increasing'; auto with real.
split; auto; fourier.
intros x [Hxpos Hxltr].
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
replace 0 with (x^n*0).
apply Rmult_lt_compat_l.
apply pow_lt; auto.
rewrite <- Hroot; autorewrite with Rpol.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (x * Rpol_eval Q r).
apply Rmult_le_compat_l; auto with real.
apply no_alternation_increasing'; auto with real.
apply Rmult_lt_compat_r; auto with real.
apply no_alternation_positive_st; auto with real.
ring.

(* End of the case for an immediate alternation. *)
intros P a n Q Heq Hoa Hrec Hprodpos HlcPneg.
assert (Halt0 : a < 0).
rewrite <- (least_non_zero_P4 P _ _ _ Heq).
assumption.
intros Heq0; rewrite Heq0 in Hprodpos; rewrite Rmult_0_l in Hprodpos.
apply (Rlt_irrefl 0); assumption.
assert (HlcQ : least_non_zero_coeff Q < 0).
apply Rlt_sign_neg_neg_rev with a; auto.

elim Hrec; auto.
intros r' [Hr'pos [Hroot' [HQpos' HQneg']]].

elim (increasing_horner_root a r' Q Halt0 Hr'pos Hroot' HQneg' HQpos').
intros r [Hrpos [Hroot [HQpos Hneg]]].
exists r.
split.
assumption.
split.
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
generalize Hroot; autorewrite with Rpol; intros Hroot1; rewrite Hroot1.
ring.
split.
intros x y Hintxy.
rewrite <- Rpol_eval_Pnorm; rewrite Heq; autorewrite with Rpol.
generalize (HQpos x y Hintxy);autorewrite with Rpol.
intros [H1 H2].
rewrite <- (Rpol_eval_Pnorm P); rewrite Heq; autorewrite with Rpol.
assert (0 < x ^ n).
apply pow_lt.
decompose [and] Hintxy; fourier.
split.
RSignTac.rsign_tac0.
apply Rle_trans with (x^n*(a+y*Rpol_eval Q y)).
apply Rmult_le_compat_l; auto with real.
assert (0 < a+y*Rpol_eval Q y).
apply Rlt_le_trans with (a+x*Rpol_eval Q x); auto.
polf.
assert (0 <= x).
decompose [and] Hintxy; fourier.
apply pow_incr; intuition.
intros x Hintx.
rewrite <- (Rpol_eval_Pnorm P); rewrite Heq; autorewrite with Rpol.
generalize (Hneg _ Hintx); autorewrite with Rpol; intros Hnegx.
assert (0 < x^n).
apply pow_lt.
intuition.
RSignTac.rsign_tac0.
Qed.

Theorem one_alternation_non_zero :
  forall P, one_alternation P -> Pnorm P <> P0.
intros P H; induction H.
intro PnormPP0.
assert (H:~a=0).
intros Heqa.
rewrite Heqa in r.
rewrite Rmult_0_l in r.
elim (Rlt_irrefl 0).
assumption.
generalize (least_non_zero_P4 _ _ _ _ e H).
intros Heql.
elim H.
rewrite <- Heql.
apply least_non_zero_P3.
assumption.

intro PnormPP0.
assert (H':~a=0).
intros Heqa.
rewrite Heqa in r.
rewrite Rmult_0_l in r.
elim (Rlt_irrefl 0).
assumption.
generalize (least_non_zero_P4 _ _ _ _ e H').
intros Heql.
elim H'.
rewrite <- Heql.
apply least_non_zero_P3.
assumption.
Qed.

Theorem Pnorm_opp :
  forall P, least_non_zero_coeff (Pnorm ((Pc (-1)) * P))=
    -least_non_zero_coeff P.
intros P; elim P using (well_founded_ind smaller_degree_wf); clear P.
intros P Hrec; elim (Rpol_decompose_Horner P).
intros [c H].
rewrite (Pnorm_ext (Pc (-1)*P)(Pc (-c))).
rewrite (least_non_zero_P5 P c).
rewrite Pnorm_cte.
apply least_non_zero_P7.
assumption.
intros x; autorewrite with Rpol.
rewrite <- Rpol_eval_Pnorm.
rewrite H; autorewrite with Rpol.
ring.

intros [c [n [Q [Hnnz [HPeq HQnz]]]]].
elim (Req_dec c 0).
intros Heq.
replace (Pnorm (Pc (-1)*P) with (X^n *  (Pc (-1) * Q)).

Theorem one_alternation_root :
  forall P, one_alternation P ->
    (exists a, 0 < a /\ Rpol_eval P a = 0 /\
      forall x, 0 < x -> Rpol_eval P x <> 0).
intros P H.
elim (Rlt_le_dec 0 (least_non_zero_coeff P)).
intros Hlt.


(** Simple elimination + computation + uniqueness + coherence for W A B
        ->
    H-initiality of W A B
**)

Require Import HoTT.
Require Import w.
Require Import w_alg.

Local Open Scope path_scope.
Local Open Scope fibration_scope.
Local Open Scope equiv_scope.

Section AssumeFunext.
Context `{Funext}.

Theorem wSimpRules_impl_wHinit (A : Type) (B : A -> Type) (W : Type) (sup : forall (x : A), (B x -> W) -> W) :
  hasWSimpElimCompRules A B W sup *
  hasWSimpUniqCohRules A B W sup ->
  wHinit A B (W; sup).
Proof.
intro I.
destruct I as [P Q].
unfold wHinit.
intro.
destruct Y as [C c].
split with (P C c).
intro y.
destruct (P C c) as [srec p].
destruct y as [h q].
apply wCell2Path.
exact (Q C c srec p h q).
Defined.

Theorem wSimp_imp_WHinit (A : Type) (B : A -> Type) : WSimp A B -> WHinit A B.
intro I.
destruct I as [W [sup J]].
unfold WHinit.
split with ((W; sup) : WAlg A B).
apply wSimpRules_impl_wHinit.
assumption.
Defined.

End AssumeFunext.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

From Undecidability.PCP              Require Import PCP PCPb_iff_iPCPb.
From Undecidability.StackMachines    Require Import BSM iPCPb_to_BSM_HALTING.
From Undecidability.MinskyMachines   Require Import MM MM_sss BSM_MM.

Theorem PCPb_MM_HALTS_ON_ZERO : PCPb ⪯ MM_HALTS_ON_ZERO.
Proof.
  eapply reduces_transitive. exact PCPb_iff_iPCPb.reductionLR.
  eapply reduces_transitive. exact iPCPb_to_BSM_HALTING.
  apply BSM_MM_HALTS_ON_ZERO.
Qed.

Theorem PCPb_MM_HALTING : PCPb ⪯ Halt_MM.
Proof.
  eapply reduces_transitive. exact PCPb_iff_iPCPb.reductionLR.
  eapply reduces_transitive. exact iPCPb_to_BSM_HALTING.
  apply BSM_MM_HALTING.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import word.
Require Import lib.utils common.types.

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

Section CFI.

Context (mt : machine_types).
Context {ops : machine_ops mt}.

Local Notation word := (mword mt).

Class cfi_machine := {
  state : eqType;
  initial : state -> Prop;

  step : state -> state -> Prop;
  step_a : state -> state -> Prop;

  succ : state -> state -> bool;
  stopping : seq state -> Prop
}.

Context (cfim : cfi_machine).

(* Definitions regarding stepping relations for CFI *)
Definition cfi_step st st' := step_a st st' \/ step st st'.

Definition intermstep := interm cfi_step.

Definition intermrstep := intermr cfi_step.

(* Old definition of CFI (Abadi)
Definition trace_has_cfi' (trace : seq state) :=
  forall (si sj : state)
         (INTRACE : In2 si sj trace ),
             (step_a si sj /\ get_pc si = get_pc sj)
          \/ succ si sj.
*)

(* Our new CFI definition *)
Definition trace_has_cfi (trace : seq state) :=
  forall (si sj : state)
         (INTRACE : In2 si sj trace ),
           step si sj -> succ si sj.

Definition trace_has_at_most_one_violation (trace : seq state) :=
  trace_has_cfi trace \/
  exists si sj hs tl, trace = hs ++ si :: sj :: tl
                         /\ (step si sj /\ ~~ succ si sj)
                         /\ trace_has_cfi (rcons hs si)
                         /\ trace_has_cfi (sj :: tl)
                         /\ stopping(sj :: tl).

Definition cfi :=
  forall s s' xs
    (INIT : initial s)
    (INTERM : intermstep xs s s'),
    trace_has_at_most_one_violation xs.

End CFI.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import PreSheaf.PreSheaf.

Section Terminal.
  Context (C : Category).

  (** The terminal element of the category of presheaves. *)
  Program Definition PSh_Term_PreSheaf : Functor (C^op) Type_Cat :=
    {|
      FO := fun _ => unit
    |}.

  Local Hint Resolve NatTrans_eq_simplify.
  Local Hint Extern 1 =>
  match goal with
    [|- ?A = ?B] => try destruct A; try destruct B; trivial; fail
  end.

  (** The functor that maps to the unit type in coq is the terminal object
      of presheaves. *)
  Program Instance PSh_Terminal : (𝟙_ (PShCat C))%object :=
    {
      terminal := PSh_Term_PreSheaf;
      t_morph := fun _ => {|Trans := fun _ _ => tt|}
    }.

End Terminal.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal49.

From lfind Require Import LFind.
Require Import Arith.
Lemma lfind_state  (x:natural) (n:natural) (n0:natural) (l:lst) (H:Bool.Is_true (eqb x n)) (IHl:forall _ : @eq bool (orb (eqb x n) (mem x l)) true,
or (@eq natural x n) (@eq bool (mem x l) true)):or (@eq natural x n) (@eq bool (orb (eqb x n0) (mem x l)) true).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal49_mem_cons_81_eqb_elim/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (n:natural) (n0:natural) (l:lst) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"n:" ++ "(" ++ show n ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"l:" ++ "(" ++ show l ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  n n0 l.
QuickChick collect_data.
Success.


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

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

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

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

Class bedrock2_unsaturated_solinas_scmul_func :=
  { carry_scmul_const : func }.

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

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

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

Record unsaturated_solinas_reified_ops
  {width BW word mem locals env ext_spec varname_gen error}
  {parameters_sentinel : @Types.parameters width BW word mem locals env ext_spec varname_gen error}
  {names : names_of_operations} {n s c} :=
  {
    reified_carry_mul :
      reified_op name_of_carry_mul
                 (Generic.UnsaturatedSolinas.carry_mul n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry_mul
                    n s c width);
    reified_carry_square :
      reified_op name_of_carry_square
                 (Generic.UnsaturatedSolinas.carry_square n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry_square
                    n s c width);
    reified_carry :
      reified_op name_of_carry
                 (Generic.UnsaturatedSolinas.carry n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry
                    n s c width);
    reified_add :
      reified_op name_of_add
                 (Generic.UnsaturatedSolinas.add n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.add
                    n s c width);
    reified_sub :
      reified_op name_of_sub
                 (Generic.UnsaturatedSolinas.sub n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.sub
                    n s c width);
    reified_opp :
      reified_op name_of_opp
                 (Generic.UnsaturatedSolinas.opp n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.opp
                    n s c width);
    reified_selectznz :
      reified_op name_of_selectznz
                 (Generic.UnsaturatedSolinas.selectznz n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.selectznz
                    n width);
    reified_to_bytes :
      reified_op name_of_to_bytes
                 (Generic.UnsaturatedSolinas.to_bytes n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.to_bytes
                    n s c width);
    reified_from_bytes :
      reified_op name_of_from_bytes
                 (Generic.UnsaturatedSolinas.from_bytes n s c)
                 (PushButtonSynthesis.UnsaturatedSolinas.from_bytes
                    n s c width) }.
Arguments unsaturated_solinas_reified_ops {_ _ _ _ _ _ _ _ _ _ _ } n s c.

Record unsaturated_solinas_reified_scmul
  {width BW word mem locals env ext_spec varname_gen error}
  {parameters_sentinel : @Types.parameters width BW word mem locals env ext_spec varname_gen error}
  {names : names_of_operations} {n s c} {x : Z} :=
  { scmul_params : Types.parameters;
    reified_carry_scmul_const :
      reified_op (varname_gen := varname_gen) (error:=error)
                 (name_of_carry_scmul_const x)
                 (Generic.UnsaturatedSolinas.carry_scmul_const
                    n s c x)
                 (PushButtonSynthesis.UnsaturatedSolinas.carry_scmul_const
                    n s c width x) }.
Arguments unsaturated_solinas_reified_scmul {_ _ _ _ _ _ _ _ _ _ _} n s c x.

(*** Helpers ***)

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

(*** Synthesis Tactics ***)

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

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

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

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

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

Ltac use_correctness_proofs p n s c :=
  match goal with
  | |- context [Generic.UnsaturatedSolinas.carry_mul] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.carry_mul_correct
  | |- context [Generic.UnsaturatedSolinas.carry_square] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.carry_square_correct
  | |- context [Generic.UnsaturatedSolinas.carry] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.carry_correct
  | |- context [Generic.UnsaturatedSolinas.add] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.add_correct
  | |- context [Generic.UnsaturatedSolinas.sub] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.sub_correct
  | |- context [Generic.UnsaturatedSolinas.opp] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.opp_correct
  | |- context [Generic.UnsaturatedSolinas.selectznz] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.selectznz_correct
  | |- context [Generic.UnsaturatedSolinas.to_bytes] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.to_bytes_correct
  | |- context [Generic.UnsaturatedSolinas.from_bytes] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.from_bytes_correct
  | |- context [Generic.UnsaturatedSolinas.carry_scmul_const] =>
    Coq.Program.Tactics.rapply @Generic.UnsaturatedSolinas.carry_scmul_const_correct
  end.

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

Ltac prove_correctness ops n s c :=
  let p := lazymatch type of ops with unsaturated_solinas_reified_ops(parameters_sentinel:=?p) _ _ _ => p end in
  let width := lazymatch type of ops with unsaturated_solinas_reified_ops(width:=?width) _ _ _ => width end in
  assert (UnsaturatedSolinas.check_args
            n s c width necessary_requests (ErrorT.Success tt) =
          ErrorT.Success tt) by abstract (native_compute; reflexivity);
  lazymatch goal with
    | |- bedrock2_unsaturated_solinas_correctness => econstructor end;
  change_with_computed_func ops; rewrite computed_bedrock_func_eq;
  use_correctness_proofs p n s c; try assumption;
  handle_easy_preconditions.

Ltac prove_correctness_scmul ops n s c :=
  let p := lazymatch type of ops with unsaturated_solinas_reified_scmul(parameters_sentinel:=?p) _ _ _ _ => p end in
  let width := lazymatch type of ops with unsaturated_solinas_reified_scmul(width:=?width) _ _ _ _ => width end in
  assert (UnsaturatedSolinas.check_args
            n s c width necessary_requests (ErrorT.Success tt) =
          ErrorT.Success tt) by abstract (native_compute; reflexivity);
  lazymatch goal with
  | |- bedrock2_unsaturated_solinas_scmul_correctness =>
    econstructor end;
  change_with_computed_func ops; rewrite computed_bedrock_func_eq;
  use_correctness_proofs p n s c; try assumption;
  handle_easy_preconditions.

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

Ltac make_reified_ops :=
  lazymatch goal with
    |- unsaturated_solinas_reified_ops ?n ?s ?c =>
    eapply Build_unsaturated_solinas_reified_ops
  end; prove_reified_op.

Ltac make_reified_scmul :=
  lazymatch goal with
    |- unsaturated_solinas_reified_scmul ?n ?s ?c ?x =>
    eapply Build_unsaturated_solinas_reified_scmul
  end;
  prove_reified_op.


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

(***
Modulus : 2^141 - 9
Base: 47
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 47;
    bitwidth := 64;
    s := 2^141;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 3); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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