Require Export Coq.ZArith.ZArith.
Require Import Coq.QArith.QArith_base Coq.QArith.Qround.
Require Export Coq.Strings.String.
Require Import Coq.Lists.List.
Require Crypto.ArithmeticCPS.Core.
Require Crypto.ArithmeticCPS.ModOps.
Require Crypto.ArithmeticCPS.Saturated.
Require Crypto.ArithmeticCPS.WordByWordMontgomery.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import Crypto.Util.Strings.ParseArithmetic.
Require Import Crypto.Util.Strings.ParseArithmeticToTaps.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.ListUtil.
Require Crypto.PushButtonSynthesis.WordByWordMontgomery.
Require Crypto.PushButtonSynthesis.UnsaturatedSolinas.
Require Import Crypto.PushButtonSynthesis.WordByWordMontgomeryReificationCache.
Require Import Crypto.PushButtonSynthesis.UnsaturatedSolinasReificationCache.
Require Import Crypto.BoundsPipeline.
Require Import Rewriter.Language.Language.
Require Import Crypto.Rewriter.All.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Stringification.C.
Require Import Crypto.Util.ZUtil.ModInv. (* Only needed for WBW Montgomery *)
Require Import Crypto.Util.Strings.Show.

Import ListNotations.
Global Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope option_scope.
Global Open Scope Z_scope.

(* replace this with vm_compute and the next fail with idtac to enable the precomputed versions *)
Declare Reduction precompute := cbv iota.
Ltac check_precomputed_enabled :=
  let v := (eval precompute in (id true)) in
  lazymatch v with
  | true => idtac
  | _ => fail 0 "Precomputed tests are disabled"
  end.

Import
  Language.Compilers
  AbstractInterpretation.Compilers
  Rewriter.All.Compilers.

Local Existing Instance Stringification.C.Compilers.ToString.C.OutputCAPI.
Local Existing Instance default_language_naming_conventions.
Local Existing Instance default_documentation_options.
Local Existing Instance default_output_options.
Local Existing Instance AbstractInterpretation.default_Options.
Local Instance : package_name_opt := None.
Local Instance : class_name_opt := None.
Local Instance : static_opt := true.
Local Instance : internal_static_opt := true.
Local Instance : inline_opt := true.
Local Instance : inline_internal_opt := true.
Local Instance : use_mul_for_cmovznz_opt := false.
Local Instance : emit_primitives_opt := true.
Local Instance : only_signed_opt := false.
Local Instance : no_select_opt := false.
Local Instance : should_split_mul_opt := false.
Local Instance : should_split_multiret_opt := false.
Local Instance : unfold_value_barrier_opt := true.
Local Instance : assembly_hints_lines_opt := [].
Local Instance : ignore_unique_asm_names_opt := false.
Local Instance : widen_bytes_opt := false.
Local Instance : widen_carry_opt := false.
Local Instance : tight_upperbound_fraction_opt := default_tight_upperbound_fraction.

Import API.

Local Set Primitive Projections.
Record Dyn := dyn { Ty : Type ; val :> Ty }.
Arguments dyn {_} _.

Module RT_ExtraAx := Core.RT_Extra Core.RuntimeAxioms.
Module ModOpsAx := ModOps.ModOps Core.RuntimeAxioms.
Module RT_ExtraDef := Core.RT_Extra Core.RuntimeDefinitions.
Module ModOpsDef := ModOps.ModOps Core.RuntimeDefinitions.
Module Import WordByWordMontgomeryAx := ArithmeticCPS.WordByWordMontgomery.WordByWordMontgomery Core.RuntimeAxioms.
Module Import WordByWordMontgomeryDef := ArithmeticCPS.WordByWordMontgomery.WordByWordMontgomery Core.RuntimeDefinitions.
Import Rewriter.Rewriter.ProofsCommon.Compilers.RewriteRules.GoalType.
Import Rewriter.Rewriter.ProofsCommon.Compilers.RewriteRules.GoalType.DefaultOptionType.

Ltac with_each_method tac :=
  tac precomputed_decision_tree;
  tac unreduced_decision_tree;
  tac unreduced_naive.

Module Import UnsaturatedSolinas.
  Class params :=
    { n : nat;
      s : Z;
      c : list (Z * Z);
      idxs : list nat;
      limbwidth := limbwidth n s c;
      machine_wordsize : Z }.

  Global Instance show_lvl_params : ShowLevel params
    := fun p => neg_wrap_parens ("{| n := " ++ show_lvl n term_lvl ++ "; s := " ++ show_lvl s term_lvl ++ "; c := " ++ show_lvl c term_lvl ++ "; idxs := " ++ show_lvl idxs term_lvl ++ "; machine_wordsize := " ++ show_lvl machine_wordsize term_lvl ++ "|}")%string.
  Global Instance show_params : Show params := show_lvl_params.

  Definition of_string (p : string) (bitwidth : Z) : list params
    := match parseZ_arith_to_taps p with
       | Some (sv, cv) => List.map
                            (fun nv => {| n := nv; s := sv; c := cv; machine_wordsize := bitwidth ; idxs := carry_chains nv sv cv |})
                            (firstn 2 (get_possible_limbs sv cv bitwidth))
       | None => nil
       end.

  Definition GallinaAxOf (p : params) : Dyn
    := dyn (fun f g : list Z => ModOpsAx.carry_mulmod (Qnum limbwidth) (Zpos (Qden limbwidth)) s c n idxs (RT_ExtraAx.expand_list 0 f n) (RT_ExtraAx.expand_list 0 g n)).
  Time Definition GallinaAxComputedOf := Eval precompute in GallinaAxOf.
  Definition GallinaDefOf (p : params) : Dyn
    := dyn (fun f g : list Z => ModOpsDef.carry_mulmod (Qnum limbwidth) (Zpos (Qden limbwidth)) s c n idxs (RT_ExtraDef.expand_list 0 f n) (RT_ExtraDef.expand_list 0 g n)).

  Definition PipelineFullOf : params * low_level_rewriter_method_opt -> Pipeline.ErrorT (Expr _)
    := fun '(p, method) => PushButtonSynthesis.UnsaturatedSolinas.carry_mul n s c machine_wordsize.
  Definition PipelineFullToStringsOf : params * low_level_rewriter_method_opt -> string * _
    := fun '(p, method) => PushButtonSynthesis.UnsaturatedSolinas.scarry_mul n s c machine_wordsize "".
  Section pipeline.
    Context (p_opts : params * low_level_rewriter_method_opt).
    Let p := fst p_opts.
    Let opts := @Pipeline.opts_of_method (snd p_opts).
    Local Existing Instance p.

    Let E := (reified_carry_mul_gen
                @ GallinaReify.Reify (Qnum limbwidth) @ GallinaReify.Reify (Z.pos (Qden limbwidth)) @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify n @ GallinaReify.Reify idxs)%Expr.

    Let E2 := let E := PartialEvaluateWithListInfoFromBounds E (Some (List.repeat None n), (Some (List.repeat None n), tt)) in
              let E := PartialEvaluate opts E in
              E.

    Definition PipelineNBEOf : Expr _
      := E2.

    Definition PipelineFlatNBEOf : GeneralizeVar.Flat.expr _
      := GeneralizeVar.ToFlat PipelineNBEOf.

    Definition PipelineArithOf : Expr _
      := let E := E2 in
         let E := Pipeline.RewriteAndEliminateDeadAndInline (RewriteRules.RewriteArith 0 opts) true (*with_dead_code_elimination*) false (*with_subst01*) true (* let_bind_return *) E in
         E.

    Definition PipelineFlatArithOf : GeneralizeVar.Flat.expr _
      := GeneralizeVar.ToFlat PipelineArithOf.
  End pipeline.

  Definition ForExtraction {R}
             (extr_descr : string)
             (seq : forall A B, (unit -> A) -> (unit -> B) -> R)
             (time : forall A, string -> (unit -> A) -> R)
             (prime : string) (bitwidth : string) (index : string)
             (error : list string -> R)
    : R
    := Eval cbv beta iota delta [List.map List.fold_right] in
        let str_bitwidth := bitwidth in
        let str_index := index in
        match parseZ_arith_strict bitwidth, parsenat_arith_strict index with
        | Some bitwidth, Some index
          => match List.nth_error (of_string prime bitwidth) index with
             | Some p
               => List.fold_right
                    (fun v1 v2 => seq _ _ (fun _ => v1) (fun _ => v2))
                    (seq _ _ id id)
                    (List.map
                       (fun method
                        => let make_descr := fun kind => ("Testing UnsaturatedSolinas " ++ prime ++ " (bitwidth = " ++ str_bitwidth ++ " ) (index = " ++ str_index ++ " ) (method = " ++ show method ++ " ) (params = " ++ show p ++ " ) " ++ kind ++ " with extraction " ++ extr_descr)%string in
                           (seq _ _)
                             (fun _ => time _ (make_descr "PipelineFullToStringsOf") (fun _ => PipelineFullToStringsOf (p, method)))
                             (fun _
                              => (seq _ _)
                                   (fun _ => time _ (make_descr "PipelineFlatNBEOf") (fun _ => PipelineFlatNBEOf (p, method)))
                                   (fun _ => time _ (make_descr "PipelineFlatArithOf") (fun _ => PipelineFlatArithOf (p, method)))))
                       [precomputed_decision_tree; unreduced_decision_tree; unreduced_naive])
             | None
               => error ["No such index"]
             end
        | None, None => error ["Could not parse bitwidth nor index"]
        | None, _ => error ["Could not parse bitwidth"]
        | _, None => error ["Could not parse index"]
        end.

  Tactic Notation "idtac_and_time" constr(prime) constr(bitwidth) constr(index) constr(p) constr(method) string(descr) tactic3(tac) :=
    idtac "Testing UnsaturatedSolinas" prime "(bitwidth =" bitwidth ") (index =" index ") (method =" method ") (params =" p ")" descr ":";
    time (idtac; tac ()).

  Tactic Notation "idtac_and_time2" constr(prime) constr(bitwidth) constr(index) constr(p) constr(method) string(descr) tactic3(tac) :=
    idtac "Testing UnsaturatedSolinas" prime "(bitwidth =" bitwidth ") (index =" index ") (method =" method ") (params =" p ")" descr "(1) :";
    time (idtac; tac ());
    idtac "Testing UnsaturatedSolinas" prime "(bitwidth =" bitwidth ") (index =" index ") (method =" method ") (params =" p ")" descr "(2) :";
    time (idtac; tac ()).

  Ltac compute_p prime bitwidth index :=
    let p := (eval vm_compute in (List.nth_error (of_string prime bitwidth) index)) in
    let __ := match p with
              | Some _ => idtac
              | None => idtac "No params" index "for prime" prime
              end in
    p.

  Ltac perfGallinaAxOf' prime bitwidth index p :=
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth index p (@None unit) "GallinaAxOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxOf p) in idtac);
         idtac_and_time2 prime bitwidth index p (@None unit) "GallinaAxOf with native_compute" (fun _ => let __ := eval native_compute in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxOf p) in idtac)
    | None => idtac
    end.
  Ltac perfGallinaAxOf prime bitwidth index :=
    let p := compute_p prime bitwidth index in perfGallinaAxOf' prime bitwidth index p.

  Ltac perfGallinaAxComputedOf' prime bitwidth index p :=
    check_precomputed_enabled;
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth index p (@None unit) "GallinaAxComputedOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxComputedOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxComputedOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxComputedOf p) in idtac)
    | None => idtac
    end.
  Ltac perfGallinaAxComputedOf prime bitwidth index :=
    check_precomputed_enabled;
    let p := compute_p prime bitwidth index in perfGallinaAxComputedOf' prime bitwidth index p.

  Ltac perfPipelineOf' prime bitwidth index p :=
    lazymatch p with
    | Some ?p
      => with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullToStringsOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineNBEOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineArithOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineFullOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineFullToStringsOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineNBEOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineArithOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullToStringsOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineNBEOf with cbv" (fun _ => let __ := eval cbv in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineArithOf with cbv" (fun _ => let __ := eval cbv in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullToStringsOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineNBEOf with lazy" (fun _ => let __ := eval lazy in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineArithOf with lazy" (fun _ => let __ := eval lazy in (PipelineArithOf (p, method)) in idtac))
    | None => idtac
    end.
  Ltac perfPipelineOf prime bitwidth index :=
    let p := compute_p prime bitwidth index in perfPipelineOf' prime bitwidth index p.

  Ltac perfGallinaDefOf' prime bitwidth index p :=
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth index p (@None unit) "GallinaDefOf with cbv_no_rt" (fun _ => let __ := eval cbv_no_rt in (GallinaDefOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaDefOf with lazy_no_rt" (fun _ => let __ := eval lazy_no_rt in (GallinaDefOf p) in idtac)
    | None => idtac
    end.
  Ltac perfGallinaDefOf prime bitwidth index :=
    let p := compute_p prime bitwidth index in perfGallinaDefOf' prime bitwidth index p.

  Ltac perf prime bitwidth index :=
    let p := (eval vm_compute in (List.nth_error (of_string prime bitwidth) index)) in
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth index p (@None unit) "GallinaAxOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxComputedOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxComputedOf p) in idtac);
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullToStringsOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineNBEOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineArithOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineArithOf (p, method)) in idtac));
         idtac_and_time2 prime bitwidth index p (@None unit) "GallinaAxOf with native_compute" (fun _ => let __ := eval native_compute in (GallinaAxOf p) in idtac);
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineFullOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineFullToStringsOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineNBEOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth index p method "PipelineArithOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineArithOf (p, method)) in idtac));
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxComputedOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaAxComputedOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaDefOf with cbv_no_rt" (fun _ => let __ := eval cbv_no_rt in (GallinaDefOf p) in idtac);
         idtac_and_time prime bitwidth index p (@None unit) "GallinaDefOf with lazy_no_rt" (fun _ => let __ := eval lazy_no_rt in (GallinaDefOf p) in idtac);
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullToStringsOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineNBEOf with cbv" (fun _ => let __ := eval cbv in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineArithOf with cbv" (fun _ => let __ := eval cbv in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineFullToStringsOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineNBEOf with lazy" (fun _ => let __ := eval lazy in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth index p method "PipelineArithOf with lazy" (fun _ => let __ := eval lazy in (PipelineArithOf (p, method)) in idtac))
    | None => idtac "No params" index "for prime" prime
    end.

  Global Set Printing Width 1000000.
End UnsaturatedSolinas.

Module Import WordByWordMontgomery.
  Local Coercion Z.of_nat : nat >-> Z.
  Local Coercion QArith_base.inject_Z : Z >-> Q.
  Local Coercion Z.pos : positive >-> Z.
  Class params :=
    { m : Z;
      machine_wordsize : Z;
      s := 2^Z.log2_up m;
      n : nat := Z.to_nat (Qceiling (Z.log2_up s / machine_wordsize));
      r := 2^machine_wordsize;
      m' := Z.modinv (-m) r }.

  Global Instance show_lvl_params : ShowLevel params
    := fun p => neg_wrap_parens ("{| m := " ++ show_lvl m term_lvl ++ "; machine_wordsize := " ++ show_lvl machine_wordsize term_lvl ++ "|}")%string.
  Global Instance show_params : Show params := show_lvl_params.

  Definition of_string (p : string) (bitwidth : Z) : option params
    := match parseZ_arith_strict p with
       | Some v => Some {| m := v ; machine_wordsize := bitwidth |}
       | None => None
       end.

  Definition GallinaAxOf (p : params) : Dyn
    := dyn (fun f g : list Z => WordByWordMontgomeryAx.mulmod machine_wordsize n m m' (RT_ExtraAx.expand_list 0 f n) (RT_ExtraAx.expand_list 0 g n)).
  Time Definition GallinaAxComputedOf := Eval precompute in GallinaAxOf.
  Definition GallinaDefOf (p : params) : Dyn
    := dyn (fun f g : list Z => WordByWordMontgomeryDef.mulmod machine_wordsize n m m' (RT_ExtraDef.expand_list 0 f n) (RT_ExtraDef.expand_list 0 g n)).

  Definition PipelineFullOf : params * low_level_rewriter_method_opt -> Pipeline.ErrorT (Expr _)
    := fun '(p, method) => PushButtonSynthesis.WordByWordMontgomery.mul m machine_wordsize.
  Definition PipelineFullToStringsOf : params * low_level_rewriter_method_opt -> string * _
    := fun '(p, method) => PushButtonSynthesis.WordByWordMontgomery.smul m machine_wordsize "".
  Section pipeline.
    Context (p_opts : params * low_level_rewriter_method_opt).
    Let p := fst p_opts.
    Let opts := @Pipeline.opts_of_method (snd p_opts).
    Local Existing Instance p.

    Let E := (reified_mul_gen
                @ GallinaReify.Reify machine_wordsize @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')%Expr.

    Let E2 := let E := PartialEvaluateWithListInfoFromBounds E (Some (List.repeat None n), (Some (List.repeat None n), tt)) in
              let E := PartialEvaluate opts E in
              E.

    Definition PipelineNBEOf : Expr _
      := E2.

    Definition PipelineFlatNBEOf : GeneralizeVar.Flat.expr _
      := GeneralizeVar.ToFlat PipelineNBEOf.

    Definition PipelineArithOf : Expr _
      := let E := E2 in
         let E := Pipeline.RewriteAndEliminateDeadAndInline (RewriteRules.RewriteArith 0 opts) true (*with_dead_code_elimination*) false (*with_subst01*) true (* let_bind_return *) E in
         E.

    Definition PipelineFlatArithOf : GeneralizeVar.Flat.expr _
      := GeneralizeVar.ToFlat PipelineArithOf.
  End pipeline.

  Definition ForExtraction {R}
             (extr_descr : string)
             (seq : forall A B, (unit -> A) -> (unit -> B) -> R)
             (time : forall A, string -> (unit -> A) -> R)
             (prime : string) (bitwidth : string)
             (error : list string -> R)
    : R
    := Eval cbv beta iota delta [List.map List.fold_right] in
        let str_bitwidth := bitwidth in
        match parseZ_arith_strict bitwidth with
        | Some bitwidth
          => match of_string prime bitwidth with
             | Some p
               => List.fold_right
                    (fun v1 v2 => seq _ _ (fun _ => v1) (fun _ => v2))
                    (seq _ _ id id)
                    (List.map
                       (fun method
                        => let make_descr := fun kind => ("Testing WordByWordMontgomery " ++ prime ++ " (bitwidth = " ++ str_bitwidth ++ " ) (method = " ++ show method ++ " ) (params = " ++ show p ++ " ) " ++ kind ++ " with extraction " ++ extr_descr)%string in
                           (seq _ _)
                             (fun _ => time _ (make_descr "PipelineFullToStringsOf") (fun _ => PipelineFullToStringsOf (p, method)))
                             (fun _
                              => (seq _ _)
                                   (fun _ => time _ (make_descr "PipelineFlatNBEOf") (fun _ => PipelineFlatNBEOf (p, method)))
                                   (fun _ => time _ (make_descr "PipelineFlatArithOf") (fun _ => PipelineFlatArithOf (p, method)))))
                       [precomputed_decision_tree; unreduced_decision_tree; unreduced_naive])
             | None
               => error ["Invalid prime"]
             end
        | None => error ["Could not parse bitwidth"]
        end.

  Tactic Notation "idtac_and_time" constr(prime) constr(bitwidth) constr(p) constr(method) string(descr) tactic3(tac) :=
    idtac "Testing WordByWordMontgomery" prime "(bitwidth =" bitwidth ") (method =" method ") (params =" p ")" descr ":";
    time (idtac; tac ()).

  Tactic Notation "idtac_and_time2" constr(prime) constr(bitwidth) constr(p) constr(method) string(descr) tactic3(tac) :=
    idtac "Testing WordByWordMontgomery" prime "(bitwidth =" bitwidth ") (method =" method ") (params =" p ")" descr "(1) :";
    time (idtac; tac ());
    idtac "Testing WordByWordMontgomery" prime "(bitwidth =" bitwidth ") (method =" method ") (params =" p ")" descr "(2) :";
    time (idtac; tac ()).

  Ltac compute_p prime bitwidth :=
    let p := (eval vm_compute in (of_string prime bitwidth)) in
    let __ := match p with
              | Some _ => idtac
              | None => idtac "No params for prime" prime
              end in
    p.

  Ltac perfGallinaAxOf' prime bitwidth p :=
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth p (@None unit) "GallinaAxOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxOf p) in idtac);
         idtac_and_time2 prime bitwidth p (@None unit) "GallinaAxOf with native_compute" (fun _ => let __ := eval native_compute in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxOf p) in idtac)
    | None => idtac
    end.
  Ltac perfGallinaAxOf prime bitwidth :=
    let p := compute_p prime bitwidth in perfGallinaAxOf' prime bitwidth p.

  Ltac perfGallinaAxComputedOf' prime bitwidth p :=
    check_precomputed_enabled;
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth p (@None unit) "GallinaAxComputedOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxComputedOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxComputedOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxComputedOf p) in idtac)
    | None => idtac
    end.
  Ltac perfGallinaAxComputedOf prime bitwidth :=
    check_precomputed_enabled;
    let p := compute_p prime bitwidth in perfGallinaAxComputedOf' prime bitwidth p.

  Ltac perfPipelineOf' prime bitwidth p :=
    lazymatch p with
    | Some ?p
      => with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullToStringsOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineNBEOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineArithOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineFullOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineFullToStringsOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineNBEOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineArithOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullToStringsOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineNBEOf with cbv" (fun _ => let __ := eval cbv in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineArithOf with cbv" (fun _ => let __ := eval cbv in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullToStringsOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineNBEOf with lazy" (fun _ => let __ := eval lazy in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineArithOf with lazy" (fun _ => let __ := eval lazy in (PipelineArithOf (p, method)) in idtac))
    | None => idtac
    end.
  Ltac perfPipelineOf prime bitwidth :=
    let p := compute_p prime bitwidth in perfPipelineOf' prime bitwidth p.

  Ltac perfGallinaDefOf' prime bitwidth p :=
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth p (@None unit) "GallinaDefOf with cbv_no_rt" (fun _ => let __ := eval cbv_no_rt in (GallinaDefOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaDefOf with lazy_no_rt" (fun _ => let __ := eval lazy_no_rt in (GallinaDefOf p) in idtac)
    | None => idtac
    end.
  Ltac perfGallinaDefOf prime bitwidth :=
    let p := compute_p prime bitwidth in perfGallinaDefOf' prime bitwidth p.

  Ltac perf prime bitwidth :=
    let p := (eval vm_compute in (of_string prime bitwidth)) in
    lazymatch p with
    | Some ?p
      => idtac_and_time prime bitwidth p (@None unit) "GallinaAxOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxComputedOf with vm_compute" (fun _ => let __ := eval vm_compute in (GallinaAxComputedOf p) in idtac);
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullToStringsOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineNBEOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineArithOf with vm_compute" (fun _ => let __ := eval vm_compute in (PipelineArithOf (p, method)) in idtac));
         idtac_and_time2 prime bitwidth p (@None unit) "GallinaAxOf with native_compute" (fun _ => let __ := eval native_compute in (GallinaAxOf p) in idtac);
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineFullOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineFullToStringsOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineNBEOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time2 prime bitwidth p method "PipelineArithOf with native_compute" (fun _ => let __ := eval native_compute in (PipelineArithOf (p, method)) in idtac));
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxComputedOf with cbv" (fun _ => let __ := eval cbv in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaAxComputedOf with lazy" (fun _ => let __ := eval lazy in (GallinaAxComputedOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaDefOf with cbv_no_rt" (fun _ => let __ := eval cbv_no_rt in (GallinaDefOf p) in idtac);
         idtac_and_time prime bitwidth p (@None unit) "GallinaDefOf with lazy_no_rt" (fun _ => let __ := eval lazy_no_rt in (GallinaDefOf p) in idtac);
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullToStringsOf with cbv" (fun _ => let __ := eval cbv in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineNBEOf with cbv" (fun _ => let __ := eval cbv in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineArithOf with cbv" (fun _ => let __ := eval cbv in (PipelineArithOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineFullToStringsOf with lazy" (fun _ => let __ := eval lazy in (PipelineFullToStringsOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineNBEOf with lazy" (fun _ => let __ := eval lazy in (PipelineNBEOf (p, method)) in idtac));
         with_each_method ltac:(fun method => idtac_and_time prime bitwidth p method "PipelineArithOf with lazy" (fun _ => let __ := eval lazy in (PipelineArithOf (p, method)) in idtac))
    | None => idtac "No params for prime" prime
    end.

  Global Set Printing Width 1000000.
End WordByWordMontgomery.
(*
Global Set Printing Width 1000000.
Goal True.
  UnsaturatedSolinas.perf "2^255-19" 64 0%nat.
  WordByWordMontgomery.perf "2^384 - 2^128 - 2^96 + 2^32 - 1" 32.
Abort.
*)
(*
Definition primes : list string :=
  [
    (* single-tap: *)

    "2^127 - 1"; (* "kummer strikes back" *)
      "2^129 - 25";
      "2^130 - 5"; (* poly1305 *)
      "2^137 - 13";
      "2^140 - 27";
      "2^141 - 9";
      "2^150 - 5";
      "2^150 - 3";
      "2^152 - 17";
      "2^158 - 15";
      "2^165 - 25";
      "2^166 - 5";
      "2^171 - 19";
      "2^174 - 17";
      "2^174 - 3";
      "2^189 - 25";
      "2^190 - 11";
      "2^191 - 19";
      "2^194 - 33";
      "2^196 - 15";
      "2^198 - 17";
      "2^206 - 5";
      "2^212 - 29";
      "2^213 - 3";
      "2^221 - 3";
      "2^222 - 117";
      "2^226 - 5";
      "2^230 - 27";
      "2^235 - 15";
      "2^243 - 9";
      "2^251 - 9";
      "2^255 - 765";
      "2^255 - 19"; (* curve25519 *)
      "2^256 - 189";
      "2^266 - 3";
      "2^285 - 9";
      "2^291 - 19";
      "2^321 - 9";
      "2^336 - 17";
      "2^336 - 3";
      "2^338 - 15";
      "2^369 - 25";
      "2^379 - 19";
      "2^382 - 105";
      "2^383 - 421";
      "2^383 - 187";
      "2^383 - 31";
      "2^384 - 317";
      "2^389 - 21";
      "2^401 - 31";
      "2^413 - 21";
      "2^414 - 17";
      "2^444 - 17";
      "2^452 - 3";
      "2^468 - 17";
      "2^488 - 17";
      "2^489 - 21";
      "2^495 - 31";
      "2^511 - 481";
      "2^511 - 187";
      "2^512 - 569";
      "2^521 - 1"; (* p512 *)

      (* two taps, golden ratio: *)

      "2^192 - 2^64 - 1";
      "2^216 - 2^108 - 1";
      "2^322 - 2^161 - 1";
      "2^416 - 2^208 - 1";
      "2^448 - 2^224 - 1"; (* goldilocks *)
      "2^450 - 2^225 - 1";
      "2^480 - 2^240 - 1"; (* ridinghood *)

      (* two or more taps *)

      "2^205 - 45*2^198 - 1";
      "2^224 - 2^96 + 1"; (* p224 *)
      "2^256 - 2^224 + 2^192 + 2^96 - 1"; (* p256 *)
      "2^256 - 2^32 - 977"; (* bitcoin *)
      "2^256 - 4294968273"; (* bitcoin, for 64-bit impl *)
      "2^384 - 2^128 - 2^96 + 2^32 - 1"; (* p384 *)

      (* Montgomery-Friendly *)

      "2^256 - 88*2^240 - 1";
      "2^254 - 127*2^240 - 1";
      "2^384 - 79*2^376 - 1";
      "2^384 - 5*2^368 - 1";
      "2^512 - 491*2^496 - 1";
      "2^510 - 290*2^496 - 1"
  ].
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Automatic Coercions Import.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Module_util.
Require Export Ring_facts.
Require Export Module_facts.
Section Hom_module_def.
Variable R : CRING.
Variable Mod1 Mod2 : MODULE R.

Definition add_hom_module : forall f g : Hom Mod1 Mod2, Hom Mod1 Mod2.
intros f0 g.
apply
 (BUILD_HOM_MODULE (R:=R) (Mod:=Mod1) (Mod':=Mod2)
    (ff:=fun x : Mod1 => sgroup_law Mod2 (f0 x) (g x))).
abstract auto with algebra.
abstract (intros x y;
           apply
            Trans
             with
               (sgroup_law (module_carrier Mod2)
                  (sgroup_law (module_carrier Mod2)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) y))
                  (sgroup_law (module_carrier Mod2)
                     (Ap
                        (sgroup_map (monoid_sgroup_hom (module_monoid_hom g)))
                        x)
                     (Ap
                        (sgroup_map (monoid_sgroup_hom (module_monoid_hom g)))
                        y))); auto with algebra).
abstract (apply
           Trans
            with
              (sgroup_law (module_carrier Mod2)
                 (monoid_unit (module_carrier Mod2))
                 (monoid_unit (module_carrier Mod2)));
           auto with algebra).
abstract (intros a x;
           apply
            Trans
             with
               (sgroup_law (module_carrier Mod2)
                  (module_mult a
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x))
                  (module_mult a
                     (Ap
                        (sgroup_map (monoid_sgroup_hom (module_monoid_hom g)))
                        x))); auto with algebra).
Defined.

Definition zero_hom_module : Hom Mod1 Mod2.
apply
 (BUILD_HOM_MODULE (R:=R) (Mod:=Mod1) (Mod':=Mod2)
    (ff:=fun x : Mod1 => monoid_unit Mod2)); abstract
 auto with algebra.
Defined.

Definition opp_hom_module : forall f : Hom Mod1 Mod2, Hom Mod1 Mod2.
intros f0.
apply
 (BUILD_HOM_MODULE (R:=R) (Mod:=Mod1) (Mod':=Mod2)
    (ff:=fun x : Mod1 => group_inverse Mod2 (f0 x))).
abstract auto with algebra.
abstract (intros x y;
           apply
            Trans
             with
               (group_inverse (module_carrier Mod2)
                  (sgroup_law (module_carrier Mod2)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) y)));
           auto with algebra;
           apply
            Trans
             with
               (group_inverse (module_carrier Mod2)
                  (sgroup_law (module_carrier Mod2)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) y)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x)));
           auto with algebra).
abstract (apply
           Trans
            with
              (group_inverse (module_carrier Mod2)
                 (monoid_unit (module_carrier Mod2)));
           auto with algebra).
abstract (intros a x;
           apply
            Trans
             with
               (group_inverse (module_carrier Mod2)
                  (module_mult a
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x)));
           auto with algebra).
Defined.

Definition mult_hom_module :
  forall (a : R) (f : Hom Mod1 Mod2), Hom Mod1 Mod2.
intros a f0.
apply
 (BUILD_HOM_MODULE (R:=R) (Mod:=Mod1) (Mod':=Mod2)
    (ff:=fun x : Mod1 => module_mult a (f0 x))).
abstract auto with algebra.
abstract (intros x y;
           apply
            Trans
             with
               (module_mult a
                  (sgroup_law (module_carrier Mod2)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x)
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) y)));
           auto with algebra).
abstract (apply
           Trans with (module_mult a (monoid_unit (module_carrier Mod2)));
           auto with algebra).
abstract (intros a0 x;
           apply
            Trans
             with
               (module_mult a
                  (module_mult a0
                     (Ap
                        (sgroup_map
                           (monoid_sgroup_hom (module_monoid_hom f0))) x)));
           auto with algebra;
           apply
            Trans
             with
               (module_mult (ring_mult a a0)
                  (Ap (sgroup_map (monoid_sgroup_hom (module_monoid_hom f0)))
                     x)); auto with algebra;
           apply
            Trans
             with
               (module_mult (ring_mult a0 a)
                  (Ap (sgroup_map (monoid_sgroup_hom (module_monoid_hom f0)))
                     x)); auto with algebra).
Defined.

Definition Hom_module : MODULE R.
apply
 (BUILD_MODULE (R:=R) (E:=Hom Mod1 Mod2) (genlaw:=add_hom_module)
    (e:=zero_hom_module) (geninv:=opp_hom_module)
    (gen_module_op:=mult_hom_module));
 try
  abstract (simpl in |- *; unfold Map_eq in |- *; simpl in |- *;
             auto with algebra).
Defined.
End Hom_module_def.


From sflib Require Import sflib.
From Paco Require Import paco.
From Coq Require Import Program.

From Fairness Require Export ITreeLib WFLib FairBeh NatStructs Any Event.

Set Implicit Arguments.

Module TIdSet := NatSet.

Definition program := list (fname * Any.t)%type.

Definition Val := nat.

Section TID.

  Definition nat_wf: WF := mk_wf Wf_nat.lt_wf.

  Definition tid_dec := PeanoNat.Nat.eq_dec.

  Lemma reldec_correct_tid_dec: RelDec.RelDec_Correct (RelDec.RelDec_from_dec eq tid_dec).
  Proof. eapply RelDec.RelDec_Correct_eq_typ. Qed.

  Definition tid_dec_bool :=
    fun t1 t2 => if (tid_dec t1 t2) then true else false.

  Definition sum_tid (_id: ID) := id_sum thread_id _id.

  Definition tids_fmap (tid: thread_id) (tidf: TIdSet.t): @fmap thread_id :=
    fun t => if (PeanoNat.Nat.eq_dec t tid) then Flag.success
          else if (NatMapP.F.In_dec tidf t) then Flag.fail
               else Flag.emp.

  Definition tids_fmap_all (tidf: TIdSet.t): @fmap thread_id :=
    fun t => if (NatMapP.F.In_dec tidf t) then Flag.fail
             else Flag.emp.

  Lemma tids_fmap_rm_same_eq
        tid tset
    :
    tids_fmap tid tset = tids_fmap tid (NatMap.remove tid tset).
  Proof.
    extensionality t. unfold tids_fmap. des_ifs.
    - exfalso. apply n0; clear n0. rewrite NatMapP.F.remove_neq_in_iff; eauto.
    - exfalso. apply n0; clear n0. rewrite <- NatMapP.F.remove_neq_in_iff; eauto.
  Qed.

  Lemma tids_fmap_add_same_eq
        tid tset
    :
    tids_fmap tid tset = tids_fmap tid (NatMap.add tid () tset).
  Proof.
    extensionality t. unfold tids_fmap. des_ifs.
    - exfalso. apply n0; clear n0. rewrite NatMapP.F.add_neq_in_iff; eauto.
    - exfalso. apply n0; clear n0. rewrite <- NatMapP.F.add_neq_in_iff; eauto.
  Qed.

  Definition kernel_tid: thread_id := 0.

  Definition kernel_success_fmap: @fmap thread_id :=
    fun t => if (tid_dec t kernel_tid)
             then Flag.success else Flag.emp.

  Definition initial_threads := TIdSet.add kernel_tid NatSet.empty.
End TID.

Module Mod.
  Record t: Type :=
    mk {
        state: Type;
        ident: ID;
        st_init: state;
        funs: fname -> option (ktree (programE ident state) Any.t Any.t);
      }.

  Program Definition wrap_fun {ident} {E} `{@eventE ident -< E} A R
          (f: ktree E A R):
    ktree E Any.t Any.t :=
    fun arg =>
      arg <- unwrap (arg↓);;
      ret <- f arg;; Ret ret↑
  .

  Fixpoint get_funs {ident} {E} `{@eventE ident -< E}
           (funs: list (fname * (ktree E Any.t Any.t)))
           (fn: fname):
    option (ktree E Any.t Any.t) :=
    match funs with
    | [] => None
    | (fn_hd, body_hd)::tl =>
        if string_dec fn fn_hd then Some body_hd else get_funs tl fn
    end.
End Mod.


(*** Interface part ***)

Require Import Subset
               Entropy
               reduction_semantics
               refocusing_semantics.
Require Export abstract_machine.

Module Type SLOPPY_REF_EVAL_APPLY_MACHINE (R : RED_REF_SEM) <: DET_ABSTRACT_MACHINE.

  Import R ST.

  Notation ick     := init_ckind.
  Definition term  := term.
  Definition value := value ick.
  Coercion   value_to_term (v : value) := (R.value_to_term v) : term.

  Inductive conf :=
  | c_eval  : term -> forall {k}, context init_ckind k -> conf
  | c_apply : forall {k}, context init_ckind k -> R.value k -> conf.

  Definition configuration := conf.
  Definition load t                    : configuration := c_eval t [.].
  Definition final (c : configuration) : option value :=
      match c with
      | c_apply [.] v => Some v
      | _             => None
      end.
  Definition decompile (c : configuration) : term :=
      match c with
      | c_eval t c  => c[t]
      | c_apply c v => c[v]
      end.
  Definition alive_state (st : configuration) :=
      match st with
      | @c_eval _ k _  => ~dead_ckind k
      | @c_apply k _ _ => ~dead_ckind k
      end.
  Definition is_final c := exists v, final c = Some v.

  Section S1.

  Local Reserved Notation "c1 → c2"                      (no associativity, at level 70).

  Inductive trans : configuration -> configuration -> Prop :=

  | t_red :                                        forall t {k} (c : context ick k) r t0,
        dec_term t k = in_red r ->
        contract r = Some t0 ->
        c_eval t c → c_eval t0 c

  | t_val :                                           forall t {k} (c : context ick k) v,
        dec_term t k = in_val v ->
        c_eval t c → c_apply c v

  | t_term :                                    forall t {k} (c : context ick k) {t0 ec},
        dec_term t k = in_term t0 ec ->
        c_eval t c → c_eval t0 (ec=:c)

  | t_cred :                                     forall ec {k} (c : context ick k) v r t,
        dec_context ec k v = in_red r ->
        contract r = Some t ->
        c_apply (ec=:c) v → c_eval t c

  | t_cval :                                      forall ec {k} (c : context ick k) v v0,
        dec_context ec k v = in_val v0 ->
        c_apply (ec=:c) v → c_apply c v0

  | t_cterm :                                  forall ec {k} (c : context ick k) v t ec0,
        dec_context ec k v = in_term t ec0 ->
        c_apply (ec=:c) v → c_eval t (ec0=:c)

  where "st1 → st2" := (trans st1 st2).
  Definition transition := trans.

  End S1.

  Definition dnext_conf (st : configuration) : option configuration :=
      match st with
      | @c_eval t k c  =>
            match dec_term t k with
            | in_red r     => option_map (fun t' => c_eval t' c) (contract r)
            | in_val v     => Some (c_apply c v)
            | in_term t ec => Some (c_eval t (ec=:c))
            | in_dead      => None
            end
      | c_apply (@ccons _ ec k c) v =>
            match dec_context ec k v with
            | in_red r     => option_map (fun t' => c_eval t' c) (contract r)
            | in_val v     => Some (c_apply c v)
            | in_term t ec => Some (c_eval t (ec=:c))
            | in_dead      => None
            end
      | c_apply [.] _ =>
            None
      end.
  Definition next_conf (_ : entropy) := dnext_conf.

  Instance rws : REWRITING_SYSTEM configuration :=
  { transition := transition }.

  Axioms
  (final_correct :                                                             forall st,
       final st <> None -> ~exists st', st → st')
  (trans_computable :                                                     forall st1 st2,
       st1 → st2 <-> exists e, next_conf e st1 = Some st2)
  (dnext_conf_alive :                                                     forall st1 st2,
      dnext_conf st1 = Some st2 -> alive_state st2)
  (trans_alive :                                                          forall st1 st2,
      st1 → st2 -> alive_state st2)
  (dnext_is_next :                                                            forall e c,
      next_conf e c = dnext_conf c).

  Class SafeRegion (P : configuration -> Prop) :=
  {
      preservation :                                                      forall st1 st2,
          P st1  ->  st1 → st2  ->  P st2;
      progress :                                                              forall st1,
          P st1  ->  is_final st1 \/ exists st2, st1 → st2
  }.

End SLOPPY_REF_EVAL_APPLY_MACHINE.

Module Type REF_EVAL_APPLY_MACHINE (R : PRECISE_RED_REF_SEM) <: DET_ABSTRACT_MACHINE.

  Import R ST.

  Declare Module RAW : SLOPPY_REF_EVAL_APPLY_MACHINE R.
  Export RAW.

  Notation   ick   := init_ckind.
  Definition term  := term.
  Definition value := RAW.value.
  Coercion   value_to_term (v : value) := (R.value_to_term v) : term.
  Notation   alive_state := RAW.alive_state.

  Instance alive_state_CompPred : CompPred _ alive_state :=
  {
      satisfyingness_comp := fun st =>
          match st with
          | @c_eval _ k _  => is_satisfied (fun k => ~dead_ckind k) k
          | @c_apply k _ _ => is_satisfied (fun k => ~dead_ckind k) k
          end
  }.

  Definition configuration := {S? RAW.configuration | alive_state}.

  Coercion conf_to_raw (st : configuration) := ¹st.

  Definition load t : configuration :=
      submember_by alive_state (RAW.c_eval t [.]) init_ckind_alive.

  Definition final (c : configuration)     : option value := RAW.final c.
  Definition decompile (c : configuration) : term         := RAW.decompile c.
  Definition transition (st1 st2 : configuration)         := RAW.transition st1 st2.
  Definition is_final c                                   := exists v, final c = Some v.

  Instance rws : REWRITING_SYSTEM configuration :=
  { transition := transition }.

  Definition dnext_conf (st : configuration) : option configuration :=

      match RAW.dnext_conf st                                                      as sto
                                   return RAW.dnext_conf st = sto -> option configuration
      with
      | Some st' => fun H => Some (submember_by _ st' (dnext_conf_alive st st' H))
      | None     => fun _ => None
      end eq_refl.

  Definition next_conf (_ : entropy) := dnext_conf.

  Axioms
  (final_correct :                                                             forall st,
       final st <> None -> ~exists st', st → st')
  (trans_computable :                                                     forall st1 st2,
       st1 → st2 <-> exists e, next_conf e st1 = Some st2)
  (*finals_are_vals :                                                        forall st v,
       final st = Some v <-> st = v*)
  (dnext_is_next :                                                            forall e c,
      next_conf e c = dnext_conf c).

  Class SafeRegion (P : configuration -> Prop) :=
  {
      preservation :                                                      forall st1 st2,
          P st1  ->  st1 → st2  ->  P st2;
      progress :                                                              forall st1,
          P st1  ->  is_final st1 \/ exists st2, st1 → st2
  }.

End REF_EVAL_APPLY_MACHINE.

(*
Module Type REF_PUSH_ENTER_MACHINE (R : RED_PE_REF_SEM R) <: DET_ABSTRACT_MACHINE.

  Import R.
  Import PERS.ST.

  Definition term  := term.
  Definition value := value init_ckind.

  Inductive conf : Set :=
  | c_eval  : term -> forall {k1 k2}, context k1 k2 -> conf
  | c_fin : forall {k}, R.value k                -> conf.
  Definition configuration := conf.

  Definition c_init t  := c_eval t [.](init_ckind).
  Definition c_final (v : value) := c_fin v.
  (*Definition final_of (st : configuration) : option value :=
      match st with
      | c_fin k v =>
          match is_initial k with
          | left H => match H in _ = k return R.value k -> option value with
                      | eq_refl => fun v => Some v
                      end v
          | _      => None
          end
      | _ => None
      end.
  Axiom final_of_correct : forall c v, final_of c = Some v <-> c_final v = c.*)

  Reserved Notation "c1 → c2" (at level 40, no associativity).

  Inductive trans : configuration -> configuration -> Prop :=

  | t_red  : forall t {k1 k2} (c : context k1 k2) {t0 r},
               dec_term t k2 = in_red r ->
               contract r = Some t0 ->
               c_eval t c → c_eval t0 c
  | t_cval : forall t {k} {v : R.value k},
               dec_term t k = in_val v ->
               c_eval t [.](k) → c_fin v
  | t_cred : forall t ec {t0} {k1 k2} (c : context k1 k2) {v r},
               dec_term t (k2+>ec) = in_val v ->
               dec_context ec k2 v = in_red r ->
               contract r = Some t0 ->
               c_eval t (ec=:c) → c_eval t0 c
  | t_crec : forall t ec {t0 ec0 k1 k2} (c : context k1 k2) {v},
               dec_term t (k2+>ec) = in_val v ->
               dec_context ec k2 v = in_term t0 ec0 ->
               c_eval t (ec=:c) → c_eval t0 (ec0=:c)
  | t_rec  : forall t {t0 ec k1 k2} (c : context k1 k2),
               dec_term t k2 = in_term t0 ec ->
               c_eval t c → c_eval t0 (ec=:c)

  where "c1 → c2" := (trans c1 c2).
  Definition transition := trans.
  Hint Unfold transition.

  Axiom final_correct : forall v st, ~ c_final v → st.

  Reserved Notation "c1 →+ c2" (at level 40, no associativity).
  Reserved Notation "c1 →* c2" (at level 40, no associativity).

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall c1 c2,     c1 → c2  ->  c1 →+ c2
  | multi_step : forall c1 c2 c3,  c1 → c2  ->  c2 →+ c3  ->  c1 →+ c3
  where "c1 →+ c2" := (trans_close c1 c2).

  Definition trans_ref_close c1 c2 := c1 = c2 \/ trans_close c1 c2.
  Notation "c1 →* c2" := (trans_ref_close c1 c2).

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall t v, trans_close (c_init t) (c_final v) -> eval t v.

  Definition next_conf st :=
      match st with
      | c_eval t _ k2 c  =>
            match dec_term t k2 with
            | in_red r => option_map (fun t' => c_eval t' c) (contract r)
            | in_val v => match c in context _ k2
                              return R.value k2 -> option configuration with
                          | [.]          => fun _ => Some (c_fin v)
                          | ccons ec k c => fun v =>
                                match dec_context ec k v with
                                | in_red r       => option_map (fun t' => c_eval t' c)
                                                               (contract r)
                                | in_term t' ec' => Some (c_eval t' (ec'=:c))
                                | _              => None
                                end
                          end v
            | in_term t ec => Some (c_eval t (ec=:c))
            | in_dead => None
            end
      | _ => None
      end.

  Axiom next_correct  : forall c1 c2, next_conf c1 = Some c2 <-> c1 → c2.

End REF_PUSH_ENTER_MACHINE.*)

(*** Implementation part ***)

Require Import Util
               reduction_languages_facts
               reduction_strategy_facts.

Module SloppyRefEvalApplyMachine (R : RED_REF_SEM) <: SLOPPY_REF_EVAL_APPLY_MACHINE R.

  Module RF := RED_LANG_Facts R.
  Module SF := RED_STRATEGY_STEP_Facts R R.ST.
  Import R RF ST SF.

  Notation   ick   := init_ckind.
  Definition term  := term.
  Definition value := value ick.
  Coercion   value_to_term (v : value) := (R.value_to_term v) : term.

  Inductive conf : Type :=
  | c_eval  : term -> forall {k}, context init_ckind k -> conf
  | c_apply : forall {k}, context init_ckind k -> R.value k -> conf.
  Definition configuration := conf.

  Definition load t                    : configuration := c_eval t [.].
  Definition final (c : configuration) : option value :=
      match c with
      | c_apply [.] v => Some v
      | _             => None
      end.
  Definition decompile (c : configuration) : term :=
      match c with
      | c_eval t c  => c[t]
      | c_apply c v => c[v]
      end.
  Definition alive_state (st : configuration) :=
      match st with
      | @c_eval _ k _  => ~dead_ckind k
      | @c_apply k _ _ => ~dead_ckind k
      end.
  Definition is_final c := exists v, final c = Some v.

  Section S1.

  Local Reserved Notation "c1 → c2" (no associativity, at level 70).

  Inductive trans : configuration -> configuration -> Prop :=

  | t_red :                                        forall t {k} (c : context ick k) r t0,
        dec_term t k = in_red r ->
        contract r = Some t0 ->
        c_eval t c → c_eval t0 c

  | t_val :                                           forall t {k} (c : context ick k) v,
        dec_term t k = in_val v ->
        c_eval t c → c_apply c v

  | t_term :                                    forall t {k} (c : context ick k) {t0 ec},
        dec_term t k = in_term t0 ec ->
        c_eval t c → c_eval t0 (ec=:c)

  | t_cred :                                     forall ec {k} (c : context ick k) v r t,
        dec_context ec k v = in_red r ->
        contract r = Some t ->
        c_apply (ec=:c) v → c_eval t c

  | t_cval :                                      forall ec {k} (c : context ick k) v v0,
        dec_context ec k v = in_val v0 ->
        c_apply (ec=:c) v → c_apply c v0

  | t_cterm :                                  forall ec {k} (c : context ick k) v t ec0,
        dec_context ec k v = in_term t ec0 ->
        c_apply (ec=:c) v → c_eval t (ec0=:c)

  where "st1 → st2" := (trans st1 st2).
  Definition transition := trans.

  End S1.

  Definition dnext_conf (st : configuration) : option configuration :=
      match st with
      | @c_eval t k c  =>
            match dec_term t k with
            | in_red r     => option_map (fun t' => c_eval t' c) (contract r)
            | in_val v     => Some (c_apply c v)
            | in_term t ec => Some (c_eval t (ec=:c))
            | in_dead      => None
            end
      | c_apply (@ccons _ ec k c) v =>
            match dec_context ec k v with
            | in_red r     => option_map (fun t' => c_eval t' c) (contract r)
            | in_val v     => Some (c_apply c v)
            | in_term t ec => Some (c_eval t (ec=:c))
            | in_dead      => None
            end
      | c_apply [.] _ =>
            None
      end.
  Definition next_conf (_ : entropy) := dnext_conf.

  Instance rws : REWRITING_SYSTEM configuration :=
  { transition := transition }.

  Lemma final_correct :                                                         forall c,
       final c <> None -> ~exists c', c → c'.

  Proof.
    intros c H [c' H0].
    inversion H0; subst;
        simpl in H;
    congruence.
  Qed.

  Lemma trans_computable0 :                                                 forall c1 c2,
       c1 → c2 <-> dnext_conf c1 = Some c2.

  Proof.
    intros c1 c2; split; intro H.

  (* -> *) {
      destruct H;
          simpl;
          match goal with H : @eq (interm_dec _) _ _ |- _ => rewrite H end;
      solve
      [ eauto
      | rewrite H0; eauto].
  }

  (* <- *) {
      destruct c1; simpl in H.
      - remember (dec_term t k) as dc.
        destruct dc.
        + remember (contract r) as opt.
          destruct opt.
          * inversion H; subst.
            eapply t_red; eauto.
          * inversion H.
        + inversion H; subst.
          apply t_term; auto.
        + inversion H; subst.
          apply t_val; auto.
        + inversion H.
      - destruct c; autof.
        remember (dec_context ec k2 v) as dc.
        destruct dc.
        + remember (contract r) as opt.
          destruct opt.
          * inversion H; subst.
            eapply t_cred; eauto.
          * inversion H.
        + inversion H; subst.
          apply t_cterm; auto.
        + inversion H; subst.
          apply t_cval; auto.
        + inversion H.
  }
  Qed.

  Lemma trans_computable :                                                  forall c1 c2,
       c1 → c2 <-> exists e, next_conf e c1 = Some c2.

  Proof with auto.
    intuition.
    - destruct (draw_fin_correct 1 Fin.F1) as [ent _].
      exists ent.
      apply trans_computable0...
    - destruct H as [ent H].
      apply trans_computable0...
  Qed.

  Lemma dnext_conf_alive :                                                forall st1 st2,
      dnext_conf st1 = Some st2 -> alive_state st2.

  Proof.
    intros st1 st2 H.
    destruct st1 as [t k c | k [ | ec c] v], st2;
    unfold dnext_conf in H; simpl in *;
    try discriminate;
    try match goal with
    | H : context [dec_term ?t ?k] |- _ =>
          remember (dec_term t k); symmetry in Heqi;
          destruct i; try discriminate;
          [ destruct (contract r); inversion H; dep_subst;
            auto using (proper_death2 [.])
          | inversion H; dep_subst;
            eauto using dec_term_next_alive, dec_term_val_alive ]
    | H : context [dec_context ?ec ?k ?v] |- _ =>
          remember (dec_context ec k v); symmetry in Heqi; destruct i;
          try discriminate;
          [ destruct (contract r); inversion H; dep_subst;
            auto using (proper_death2 [.])
          | inversion H; dep_subst;
            eauto using dec_context_next_alive, dec_context_val_alive ]
    end.
  Qed.

  Lemma trans_alive :                                                     forall st1 st2,
      st1 → st2 -> alive_state st2.

  Proof.
    intros st1 st2 H.
    inversion H; subst;
    simpl;
    eauto using (proper_death2 [.]), dec_term_val_alive, dec_term_next_alive,
                dec_context_val_alive, dec_context_next_alive.
  Qed.

  Lemma dnext_is_next :                                                      forall e c,
      next_conf e c = dnext_conf c.

  Proof.
    auto.
  Qed.

  Class SafeRegion (P : configuration -> Prop) :=
  {
      preservation :                                                      forall st1 st2,
          P st1  ->  st1 → st2  ->  P st2;
      progress :                                                              forall st1,
          P st1  ->  is_final st1 \/ exists st2, st1 → st2
  }.

End SloppyRefEvalApplyMachine.

Module RefEvalApplyMachine (R : PRECISE_RED_REF_SEM) <: REF_EVAL_APPLY_MACHINE R.

  Module RF := RED_LANG_Facts R.
  Import R RF ST.

  Module RAW := SloppyRefEvalApplyMachine R.
  Export RAW.

  Notation   ick   := init_ckind.
  Definition term  := term.
  Definition value := RAW.value.
  Coercion   value_to_term (v : value) := (R.value_to_term v) : term.
  Notation   alive_state := RAW.alive_state.

  Instance alive_state_CompPred : CompPred _ alive_state :=
  {
      satisfyingness_comp := fun st =>
          match st with
          | @c_eval _ k _  => is_satisfied (fun k => ~dead_ckind k) k
          | @c_apply k _ _ => is_satisfied (fun k => ~dead_ckind k) k
          end
  }.

  Definition configuration := {S? RAW.configuration | alive_state }.

  Coercion conf_to_raw (st : configuration) := ¹st.

  Definition load t : configuration :=
      submember_by alive_state (RAW.c_eval t [.]) init_ckind_alive.

  Definition value_to_conf (v : value) : configuration :=
      submember_by alive_state (RAW.c_apply [.] v) init_ckind_alive.
  Coercion value_to_conf : value >-> configuration.

  Definition final (c : configuration) : option value := RAW.final c.
  Definition decompile (c : configuration) : term     := RAW.decompile c.
  Definition transition (st1 st2 : configuration)     := RAW.transition st1 st2.
  Definition is_final c := exists v, final c = Some v.

  Instance rws : REWRITING_SYSTEM configuration :=
  { transition := transition }.

  Definition dnext_conf (st : configuration) : option configuration :=

      match RAW.dnext_conf st                                                      as sto
                                   return RAW.dnext_conf st = sto -> option configuration
      with
      | Some st' => fun H => Some (submember_by _ st' (dnext_conf_alive st st' H))
      | None     => fun _ => None
      end eq_refl.

  Definition next_conf (_ : entropy) := dnext_conf.

  Lemma final_correct :                                                         forall c,
      final c <> None -> ~exists c', c → c'.

  Proof.
    intros c H [c' H0].
    destruct c, c';
        compute in H0;
        inversion H0; dep_subst;
        compute in H;
    congruence.
  Qed.

  Lemma RAW_trans_computable0 :                           forall st1 st2 : configuration,
      st1 → st2 <-> RAW.dnext_conf st1 = Some (st2 : RAW.configuration).

  Proof.
    destruct st1, st2.
    apply RAW.trans_computable0.
  Qed.

  Lemma trans_computable0 :                                                 forall c1 c2,
      c1 → c2 <-> dnext_conf c1 = Some c2.

  Proof.
    intros c1 c2.

    rewrite (RAW_trans_computable0 c1 c2).
    unfold dnext_conf.
    generalize (eq_refl : RAW.dnext_conf c1 = RAW.dnext_conf c1) as H.
    intro H.
    set (RAW.dnext_conf c1) as sto in H at 2 |- * at 2.
    destruct sto.
    - destruct c as [t k c | k c v];
          rewrite H at 1; destruct c2;
          split; intro H0;
          inversion H0; dep_subst;
      solve
      [ repeat f_equal; apply (f_equal (submember _ _)); apply witness_unique ].
    - split; congruence.
  Qed.

  Lemma trans_computable :                                                  forall c1 c2,
      c1 → c2 <-> exists e, next_conf e c1 = Some c2.

  Proof with auto.
    intros c1 c2; split; intro H.
    - destruct entropy_exists as [e _].
      exists e.
      apply trans_computable0...
    - destruct H.
      apply trans_computable0...
  Qed.

  Lemma finals_are_vals :                                                    forall st v,
      final st = Some v <-> st = v.

  Proof.
    intros st v.
    destruct st as [[? ? ? | ? c ?] ?]; simpl.
    - intuition.
    - destruct c.
      + split; intro H;
            inversion H; dep_subst;
            unfold value_to_conf;
        solve [try apply (f_equal (submember _ _)); auto].
      + intuition.
  Qed.

  Lemma dnext_is_next :                                                      forall e c,
      next_conf e c = dnext_conf c.

  Proof.
    auto.
  Qed.

  Class SafeRegion (P : configuration -> Prop) :=
  {
      preservation :                                                      forall st1 st2,
          P st1  ->  st1 → st2  ->  P st2;
      progress :                                                              forall st1,
          P st1  ->  is_final st1 \/ exists st2, st1 → st2
  }.

End RefEvalApplyMachine.

(*Module RefPushEnterMachine (R : RED_LANG) (PERS : PE_RED_REF_SEM R)
                                                 <: REF_PUSH_ENTER_MACHINE R PERS.

  Import R.
  Import PERS.ST.

  Definition term  := term.
  Definition value := value init_ckind.

  Inductive conf : Set :=
  | c_eval : term -> forall {k1 k2}, context k1 k2 -> conf
  | c_fin  : forall {k}, R.value k                 -> conf.
  Definition configuration := conf.

  Definition c_init t            := c_eval t [.](init_ckind).
  Definition c_final (v : value) := c_fin v.

  Reserved Notation "c1 → c2" (at level 40, no associativity).

  Inductive trans : configuration -> configuration -> Prop :=

  | t_red  : forall t {k1 k2} (c : context k1 k2) {t0 r},
               dec_term t k2 = in_red r ->
               contract r = Some t0 ->
               c_eval t c → c_eval t0 c
  | t_cval : forall t {k} {v : R.value k},
               dec_term t k = in_val v ->
               c_eval t [.](k) → c_fin v
  | t_cred : forall t ec {t0} {k1 k2} (c : context k1 k2) {v r},
               dec_term t (k2+>ec) = in_val v ->
               dec_context ec k2 v = in_red r ->
               contract r = Some t0 ->
               c_eval t (ec=:c) → c_eval t0 c
  | t_crec : forall t ec {t0 ec0 k1 k2} (c : context k1 k2) {v},
               dec_term t (k2+>ec) = in_val v ->
               dec_context ec k2 v = in_term t0 ec0 ->
               c_eval t (ec=:c) → c_eval t0 (ec0=:c)
  | t_rec  : forall t {t0 ec k1 k2} (c : context k1 k2),
               dec_term t k2 = in_term t0 ec ->
               c_eval t c → c_eval t0 (ec=:c)

  where "c1 → c2" := (trans c1 c2).
  Definition transition := trans.
  Hint Unfold transition.

  Lemma final_correct : forall v st, ~ c_final v → st.
  Proof. inversion 1. Qed.

  Reserved Notation "c1 →+ c2" (at level 40, no associativity).
  Reserved Notation "c1 →* c2" (at level 40, no associativity).

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall c1 c2,     c1 → c2  ->  c1 →+ c2
  | multi_step : forall c1 c2 c3,  c1 → c2  ->  c2 →+ c3  ->  c1 →+ c3
  where "c1 →+ c2" := (trans_close c1 c2).

  Definition trans_ref_close c1 c2 := c1 = c2 \/ trans_close c1 c2.
  Notation "c1 →* c2" := (trans_ref_close c1 c2).

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall t v, trans_close (c_init t) (c_final v) -> eval t v.

  Definition next_conf st :=
      match st with
      | c_eval t _ k2 c  =>
            match dec_term t k2 with
            | in_red r => option_map (fun t' => c_eval t' c) (contract r)
            | in_val v => match c in context _ k2
                              return R.value k2 -> option configuration with
                          | [.]          => fun _ => Some (c_fin v)
                          | ccons ec k c => fun v =>
                                match dec_context ec k v with
                                | in_red r       => option_map (fun t' => c_eval t' c)
                                                               (contract r)
                                | in_term t' ec' => Some (c_eval t' (ec'=:c))
                                | _              => None
                                end
                          end v
            | in_term t ec => Some (c_eval t (ec=:c))
            | in_dead => None
            end
      | _ => None
      end.

  Lemma next_correct  : forall c1 c2, next_conf c1 = Some c2 <-> c1 → c2.

  Proof.
    intros c1 c2; split; intro H.

  (* -> *) {
      destruct c1; simpl in H.
      - remember (dec_term t k2) as dc.
        destruct dc.
        + remember (contract r) as opt.
          destruct opt.
          * inversion H; subst.
            eapply t_red; eauto.
          * inversion H.
        + inversion H; subst.
          apply t_rec; auto.
        + destruct c.
          * inversion H; subst.
            apply t_cval; auto.
          * remember (dec_context ec k2 v) as dc.
            destruct dc;
            inversion H.
            { remember (contract r) as opt.
              destruct opt;
              inversion H; subst.
              eapply t_cred; eauto. }
            { eapply t_crec; eauto. }
        + inversion H.
      - inversion H.
  }

  (* <- *) {
      destruct H;
          simpl;
          match goal with H : @eq (interm_dec _) _ _ |- _ => rewrite H end;
      try solve
      [ auto
      | rewrite H0; try rewrite H1; auto].
  }
  Qed.

End RefPushEnterMachine.*)