Require Import Recdef.
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.PeanoNat.
Require Import Common.Common.
Require Import LambdaBoxMut.compile.
Require Import LambdaBoxMut.term.
Require Import LambdaBoxMut.wcbvEval.

Require Import TemplateExtraction.EAst Template.kernel.univ.

Local Open Scope string_scope.
Local Open Scope bool.
Local Open Scope list.
Set Implicit Arguments.

Set Printing Width 80.
Set Printing Depth 1000.

Instance fuel : utils.Fuel := { fuel := 2 ^ 14 }.

Quote Recursively Definition p_Type := Type.
Print p_Type.
Definition P_Type := Eval cbv in (program_Program p_Type).
Print P_Type.

(** test eta expansion: constructor expecting 1 arg and 0 params **)
Inductive etaC01 := EtaC01 : forall b:bool, etaC01.
Quote Recursively Definition p_etaC01 := EtaC01.
Definition P_etaC01 := Eval cbv in (program_Program p_etaC01).
Print P_etaC01.

Inductive DD := D2: bool -> bool -> DD.
Quote Recursively Definition p_etaTst := (D2 true false).
Print p_etaTst.
Definition P_etaTst := Eval cbv in (program_Program p_etaTst).
Print P_etaTst.
Compute
  let env := (env P_etaTst) in
  let main := (main P_etaTst) in
  wcbvEval (env) 10 (main).
Quote Recursively Definition p_LetaTst := (fun (x:bool) => (D2 true x)).
Print p_LetaTst.
Definition P_LetaTst := Eval cbv in (program_Program p_LetaTst).
Print P_LetaTst.
Compute
  let env := (env P_LetaTst) in
  let main := (main P_LetaTst) in
  wcbvEval (env) 10 (main).

(** trivial example **)
Definition one := 1.
Quote Recursively Definition cbv_one := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (one)) in exact t).
Print cbv_one.
(* [Term] of Coq's answer *)
Definition ans_one := Eval cbv in (main (program_Program cbv_one)).
Print ans_one.
(* [program] of the program *)
Quote Recursively Definition p_one := one.
Print p_one.
Definition P_one := Eval cbv in (program_Program p_one).
Print P_one.
Goal
  let env := (env P_one) in
  let main := (main P_one) in
  wcbvEval (env) 100 (main) = Ret ans_one.
  vm_compute. reflexivity.
Qed.

Definition ten := 10.
Quote Recursively Definition cbv_ten := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (ten)) in exact t).
Print cbv_ten.
(* [Term] of Coq's answer *)
Definition ans_ten := Eval cbv in (main (program_Program cbv_ten)).
Print ans_ten.
(* [program] of the program *)
Quote Recursively Definition p_ten := ten.
Print p_ten.
Definition P_ten := Eval cbv in (program_Program p_ten).
Print P_ten.
Goal
  let env := (env P_ten) in
  let main := (main P_ten) in
  wcbvEval (env) 100 (main) = Ret ans_ten.
  vm_compute. reflexivity.
Qed.

Definition plus01 := (plus 0 1).
Quote Recursively Definition cbv_plus01 := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (plus01)) in exact t).
Print cbv_plus01.
(* [Term] of Coq's answer *)
Definition ans_plus01 := Eval cbv in (main (program_Program cbv_plus01)).
Print ans_plus01.
(* [program] of the program *)
Quote Recursively Definition p_plus01 := plus01.
Print p_plus01.
Definition P_plus01 := Eval cbv in (program_Program p_plus01).
Print P_plus01.
Goal
  let env := (env P_plus01) in
  let main := (main P_plus01) in
  wcbvEval (env) 10 (main) = Ret ans_plus01.
Proof.
  cbv. reflexivity.
Qed.

Definition plus10 := (plus 1 0).
Quote Recursively Definition cbv_plus10 := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (plus10)) in exact t).
Print cbv_plus10.
(* [Term] of Coq's answer *)
Definition ans_plus10 := Eval cbv in (main (program_Program cbv_plus10)).
Print ans_plus10.
(* [program] of the program *)
Quote Recursively Definition p_plus10 := plus10.
Print p_plus10.
Definition P_plus10 := Eval cbv in (program_Program p_plus10).
Print P_plus10.
Goal
  let env := (env P_plus10) in
  let main := (main P_plus10) in
  wcbvEval (env) 100 (main) = Ret ans_plus10.
Proof.
  cbv. reflexivity.
Qed.

(**********
Goal
  let env := (env P_plus10) in
  let main := (main P_plus10) in
  WcbvEval (env) (main) ans_plus10.
Proof.
  intros. unfold main, AstCommon.env, AstCommon.main, P_plus10, ans_plus10.
  eapply wConst.
  - unfold lookupDfn. cbn. reflexivity.
  - eapply wAppLam.
    + eapply wAppFix.
      * eapply wConst.
        -- unfold lookupDfn. cbn. reflexivity.
        -- apply wFix.
      * cbn. reflexivity.
      * eapply wAppLam.
        -- eapply wLam.
        -- eapply wConstruct. eapply wCons.
           ++ eapply wConstruct. eapply wNil.
           ++ eapply wNil.
        -- cbn. eapply wLam.
    + eapply wConstruct. eapply wNil.
    + cbn. eapply wCase.
      * eapply wConstruct. eapply wCons.
        -- eapply wConstruct. eapply wNil.
        -- eapply wNil.
      * unfold whCaseStep.Print bnth. unfold bnth.
      * cbn. reflexivity.

    + eapply wAppFix.
      * eapply wConst.
        -- unfold lookupDfn. cbn. reflexivity.
        -- apply wFix.
      * cbn. reflexivity.
      * eapply wAppLam.
        -- eapply wLam.
        -- eapply wConstruct. eapply wCons.
           ++ eapply wConstruct. eapply wNil.
           ++ eapply wNil.
        -- unfold whBetaStep, instantiate. eapply wLam.
    + eapply wConstruct. eapply wNil.
    + unfold whBetaStep, instantiate. unfold ans_plus10. eapply wCase.
      * cbn. eapply wConstruct. eapply wCons.
        -- eapply wConstruct. eapply wNil.
        -- eapply wNil.
      * cbn. reflexivity.
      *

Goal
  let env := (env P_plus10) in
  let main := (main P_plus10) in
  wcbvEval (env) 100 (main) = Ret ans_plus10.
Proof.
  cbv. reflexivity.
Qed.
 ********************)

Definition plus98 := (plus 9 8).
Quote Recursively Definition cbv_plus98 := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (plus98)) in exact t).
Print cbv_plus98.
(* [Term] of Coq's answer *)
Definition ans_plus98 := Eval cbv in (main (program_Program cbv_plus98)).
Print ans_plus98.
(* [program] of the program *)
Quote Recursively Definition p_plus98 := plus98.
Print p_plus98.
Definition P_plus98 := Eval cbv in (program_Program p_plus98).
Print P_plus98.
Goal
  let env := (env P_plus98) in
  let main := (main P_plus98) in
  wcbvEval (env) 100 (main) = Ret ans_plus98.
Proof.
  vm_compute. reflexivity.
Qed.

(** nested Let **)
Definition nestedLet := let x := 0 in let y := 1 in x.
Quote Recursively Definition cbv_nestedLet := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in nestedLet) in exact t).
Print cbv_nestedLet.
(* [Term] of Coq's answer *)
Definition ans_nestedLet := Eval cbv in (main (program_Program cbv_nestedLet)).
Print ans_nestedLet.
(* [program] of the program *)
Quote Recursively Definition p_nestedLet := nestedLet.
Print p_nestedLet.
Definition P_nestedLet := Eval cbv in (program_Program p_nestedLet).
Print P_nestedLet.
Goal
  let env := (env P_nestedLet) in
  let main := (main P_nestedLet) in
  wcbvEval (env) 100 (main) = Ret ans_nestedLet.
Proof.
  vm_compute. reflexivity.
Qed.
Goal  (* Why does this work? *)
  let env := (env P_nestedLet) in
  let main := (main P_nestedLet) in
  WcbvEval env main ans_nestedLet.
Proof.
  intros. unfold main, AstCommon.main, P_nestedLet.
  eapply wConst.
  - reflexivity.
  - eapply wLetIn.
    + eapply wConstruct. eapply wNil.
    + cbn. eapply wLetIn.
      * eapply wConstruct. eapply wCons.
        -- eapply wConstruct. eapply wNil.
        -- eapply wNil.
      * cbn. eapply wConstruct. eapply wNil.
Qed.

(** vector addition **)
Require Coq.Vectors.Vector.
Print Fin.t.
Print Vector.t.

Definition vplus (n:nat) :
  Vector.t nat n -> Vector.t nat n -> Vector.t nat n := (Vector.map2 plus).
Definition v01 : Vector.t nat 2 :=
  (Vector.cons nat 0 1 (Vector.cons nat 1 0 (Vector.nil nat))).
Definition v23 : Vector.t nat 2 :=
  (Vector.cons nat 2 1 (Vector.cons nat 3 0 (Vector.nil nat))).
Definition vplus0123 := (vplus v01 v23).
Quote Recursively Definition cbv_vplus0123 := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (vplus0123)) in exact t).
Print cbv_vplus0123.
(* [Term] of Coq's answer *)
Definition ans_vplus0123 := Eval cbv in (main (program_Program cbv_vplus0123)).
(* [program] of the program *)
Quote Recursively Definition p_vplus0123 := vplus0123.
Print p_vplus0123.
Definition P_vplus0123 := Eval cbv in (program_Program p_vplus0123).
Print P_vplus0123.
Goal
  let env := (env P_vplus0123) in
  let main := (main P_vplus0123) in
  wcbvEval (env) 100 (main) = Ret ans_vplus0123.
  vm_compute. reflexivity.
Qed.

(** Ackermann **)
Fixpoint ack (n m:nat) {struct n} : nat :=
  match n with
    | 0 => S m
    | S p => let fix ackn (m:nat) {struct m} :=
                 match m with
                   | 0 => ack p 1
                   | S q => ack p (ackn q)
                 end
             in ackn m
  end.
Definition ack35 := (ack 3 5).
Quote Recursively Definition cbv_ack35 :=
  ltac:(let t:=(eval cbv in ack35) in exact t).
Print cbv_ack35.
Definition ans_ack35 :=
  Eval cbv in (main (program_Program cbv_ack35)).
Print ans_ack35.
(* [program] of the program *)
Quote Recursively Definition p_ack35 := ack35.
Print p_ack35.
Definition P_ack35 := Eval cbv in (program_Program p_ack35).
Print P_ack35.
Goal
  let env := (env P_ack35) in
  let main := (main P_ack35) in
  wcbvEval (env) 2000 (main) = Ret ans_ack35.
  vm_compute. reflexivity.
Qed.

(** mutual recursion **)
Inductive tree (A:Set) : Set :=
  node : A -> forest A -> tree A
with forest (A:Set) : Set :=
     | leaf : A -> forest A
     | fcons : tree A -> forest A -> forest A.

Definition sf: forest bool := (fcons (node true (leaf false)) (leaf true)).
Quote Recursively Definition p_sf := sf.
Eval cbv in (program_Program p_sf).

Fixpoint tree_size (t:tree bool) : nat :=
  match t with
    | node a f => S (forest_size f)
  end
with forest_size (f:forest bool) : nat :=
       match f with
         | leaf b => 1
         | fcons t f1 => (tree_size t + forest_size f1)
       end.

Definition arden: forest bool :=
  fcons (node true (fcons (node true (leaf false)) (leaf true)))
        (fcons (node true (fcons (node true (leaf false)) (leaf true)))
               (leaf false)).
Quote Recursively Definition p_arden := arden.
Definition arden_size := (forest_size arden).
Quote Recursively Definition cbv_arden_size :=
  ltac:(let t:=(eval cbv in arden_size) in exact t).
Definition ans_arden_size :=
  Eval cbv in (main (program_Program cbv_arden_size)).
(* [program] of the program *)
Quote Recursively Definition p_arden_size := arden_size.
Print p_arden_size.
Definition P_arden_size := Eval cbv in (program_Program p_arden_size).
Print P_arden_size.
Eval cbv in (env P_arden_size).
Goal
  let env := (env P_arden_size) in
  let main := (main P_arden_size) in
  wcbvEval env 50 main = Ret ans_arden_size.
  vm_compute. reflexivity.
Qed.

(** SASL tautology function: variable arity **)
Fixpoint tautArg (n:nat) : Type :=
  match n with
    | 0 => bool
    | S n => bool -> tautArg n
  end.
Fixpoint taut (n:nat) : tautArg n -> bool :=
  match n with
    | 0 => (fun x => x)
    | S n => fun x => taut n (x true) && taut n (x false)
  end.
(* Pierce *)
Definition pierce := taut 2 (fun x y => implb (implb (implb x y) x) x).
Quote Recursively Definition cbv_pierce :=
  ltac:(let t:=(eval cbv in pierce) in exact t).
Print cbv_pierce.
Definition ans_pierce :=
  Eval cbv in (main (program_Program cbv_pierce)).
Print ans_pierce.
(* [program] of the program *)
Quote Recursively Definition p_pierce := pierce.
Print p_pierce.
Definition P_pierce := Eval cbv in (program_Program p_pierce).
Print P_pierce.
Goal
  let env := (env P_pierce) in
  let main := (main P_pierce) in
  wcbvEval (env) 200 (main) = Ret ans_pierce.
  vm_compute. reflexivity.
Qed.
(* S combinator *)
Definition Scomb := taut 3
         (fun x y z => implb (implb x (implb y z))
                             (implb (implb x y) (implb x z))).
Quote Recursively Definition cbv_Scomb :=
  ltac:(let t:=(eval cbv in Scomb) in exact t).
Print cbv_Scomb.
Definition ans_Scomb :=
  Eval cbv in (main (program_Program cbv_Scomb)).
Print ans_Scomb.
(* [program] of the program *)
Quote Recursively Definition p_Scomb := Scomb.
Print p_Scomb.
Definition P_Scomb := Eval cbv in (program_Program p_Scomb).
Print P_Scomb.
Goal
  let env := (env P_Scomb) in
  let main := (main P_Scomb) in
  wcbvEval (env) 200 (main) = Ret ans_pierce.
  vm_compute. reflexivity.
Qed.

(** Fibonacci **)
Fixpoint slowFib (n:nat) : nat :=
  match n with
    | 0 => 0
    | S m => match m with
               | 0 => 1
               | S p => slowFib p + slowFib m
             end
  end.
Definition slowFib3 := (slowFib 3).
Quote Recursively Definition cbv_slowFib3 :=
  ltac:(let t:=(eval cbv in slowFib3) in exact t).
Definition ans_slowFib3 :=
  Eval cbv in (main (program_Program cbv_slowFib3)).
(* [program] of the program *)
Quote Recursively Definition p_slowFib3 := slowFib3.
Definition P_slowFib3 := Eval cbv in (program_Program p_slowFib3).
Goal
  let env := (env P_slowFib3) in
  let main := (main P_slowFib3) in
  wcbvEval (env) 30 (main) = Ret ans_slowFib3.
  vm_compute. reflexivity.
Qed.

(* fast Fib *)
Fixpoint fibrec (n:nat) (fs:nat * nat) {struct n} : nat :=
  match n with
    | 0 => fst fs
    | (S n) => fibrec n (pair ((fst fs) + (snd fs)) (fst fs))
  end.
Definition fib : nat -> nat := fun n => fibrec n (pair 0 1).
Definition fib9 := fib 9.
Quote Recursively Definition cbv_fib9 :=
  ltac:(let t:=(eval cbv in fib9) in exact t).
Definition ans_fib9 :=
  Eval cbv in (main (program_Program cbv_fib9)).
(* [program] of the program *)
Quote Recursively Definition p_fib9 := fib9.
Definition P_fib9 := Eval cbv in (program_Program p_fib9).
Goal
  let env := (env P_fib9) in
  let main := (main P_fib9) in
  wcbvEval (env) 1000 (main) = Ret ans_fib9.
  vm_compute. reflexivity.
Qed.

(** Heterogenous datatypes, a la Matthes **)
Inductive PList : Set->Type:=  (* powerlists *)
| zero : forall A:Set, A -> PList A
| succ : forall A:Set, PList (A * A)%type -> PList A.

Definition myPList : PList nat :=
  succ (succ (succ (zero (((1,2),(3,4)),((5,6),(7,8)))))).

Fixpoint unzip (A:Set) (l:list (A*A)) {struct l} : list A :=
  match l return list A with
    | nil => nil
    | cons (a1,a2) l' => cons a1 (cons a2 (unzip l'))
  end.
Fixpoint PListToList (A:Set) (l:PList A) {struct l} : list A :=
  match l in PList A return list A with
    | zero a => cons a (nil )
    | succ l' => unzip (PListToList l')
  end.

Eval compute in PListToList myPList.

Fixpoint gen_sumPList (A:Set) (l:PList A) {struct l} : (A->nat)->nat :=
  match l in PList A return (A->nat)->nat with
    | zero a => fun f => f a
    | succ l' =>
      fun f => gen_sumPList l' (fun a => let (a1,a2) := a in f a1 + f a2)
  end.
Definition sumPList l := gen_sumPList l (fun x => x).
Definition sumPL_myPL := (sumPList myPList).
Quote Recursively Definition cbv_sumPL_myPL :=
  ltac:(let t:=(eval cbv in sumPL_myPL) in exact t).
Definition ans_sumPL_myPL :=
  Eval cbv in (main (program_Program cbv_sumPL_myPL)).
(* [program] of the program *)
Quote Recursively Definition p_sumPL_myPL := sumPL_myPL.
Definition P_sumPL_myPL := Eval cbv in (program_Program p_sumPL_myPL).
Goal
  let env := (env P_sumPL_myPL) in
  let main := (main P_sumPL_myPL) in
  wcbvEval (env) 1000 (main) = Ret ans_sumPL_myPL.
  vm_compute. reflexivity.
Qed.

Set Implicit Arguments.
Section List.
Variables X Y : Type.
Variable f : X -> Y -> Y.
Fixpoint fold (y : Y) (xs : list X) : Y :=
  match xs with
    | nil => y
    | cons x xr => fold (f x y) xr
  end.
End List.
Inductive Tree := T : list Tree -> Tree.
Fixpoint size (t : Tree) : nat :=
  match t with
    | T ts => S (fold (fun t a => size t + a) 0 ts)
  end.
Definition myTree :=
  (T (cons (T (unit (T nil))) (cons (T (unit (T nil))) nil))).
Eval cbv in size myTree.
Definition size_myTree := size myTree.
Quote Recursively Definition cbv_size_myTree :=
  ltac:(let t:=(eval cbv in size_myTree) in exact t).
Definition ans_size_myTree :=
  Eval cbv in (main (program_Program cbv_size_myTree)).
(* [program] of the program *)
Quote Recursively Definition p_size_myTree := size_myTree.
Definition P_size_myTree := Eval cbv in (program_Program p_size_myTree).
Goal
  let env := (env P_size_myTree) in
  let main := (main P_size_myTree) in
  wcbvEval (env) 100 (main) = Ret ans_size_myTree.
  vm_compute. reflexivity.
Qed.

Function provedCopy (n:nat) {wf lt n} :=
  match n with 0 => 0 | S k => S (provedCopy k) end.
Proof.
  - intros. constructor.
  - apply lt_wf.
Defined.
Print Assumptions provedCopy_tcc.
Quote Recursively Definition pCopy := provedCopy. (* program *)
Print provedCopy_tcc.
Definition x := 3.
Definition provedCopyx := provedCopy x.
Compute provedCopyx.  (** evals correctly in Coq **)
Quote Recursively Definition cbv_provedCopyx :=
  ltac:(let t:=(eval cbv in provedCopyx) in exact t).
Definition ans_provedCopyx :=
  Eval cbv in (main (program_Program cbv_provedCopyx)).
Quote Recursively Definition p_provedCopyx := provedCopyx. (* program *)
Definition P_provedCopyx :=                            (* Program *)
  Eval cbv in (program_Program p_provedCopyx).
Goal
  let env := (env P_provedCopyx) in
  let main := (main P_provedCopyx) in
  wcbvEval (env) 100 (main) = Ret ans_provedCopyx.
  vm_compute. reflexivity.
Qed.

Definition plusx := (plus 0).
Compute plusx.
Quote Recursively Definition cbv_plusx :=
  ltac:(let t:=(eval cbv in plusx) in exact t).
Definition ans_plusx :=
  Eval cbv in (main (program_Program cbv_plusx)).
Print ans_plusx.
(* [program] of the program *)
Quote Recursively Definition p_plusx := plusx.
Print plusx.
Definition P_plusx := Eval cbv in (program_Program p_plusx).
Goal
  let env := (env P_plusx) in
  let main := (main P_plusx) in
  wcbvEval (env) 90 (main) = Ret ans_plusx.
Proof.
  cbv. (** Coq cbv goes under lambda, but we don't **)
Admitted.

Section myplus.
  Variables (A:Type).
  Inductive myNat : Type :=
  | myZ: forall a:A, myNat.
  Definition myplus (m n: myNat) : A :=
    match m with
    | myZ a => a
    end.
End myplus.
Print myplus.
Definition myplusx := (myplus (myZ 0) (myZ 0)).
Compute myplusx.
Quote Recursively Definition cbv_myplusx :=
  ltac:(let t:=(eval cbv in myplusx) in exact t).
Definition ans_myplusx :=
  Eval cbv in (main (program_Program cbv_myplusx)).
Print ans_myplusx.
(* [program] of the program *)
Quote Recursively Definition p_myplusx := myplusx.
Print myplusx.
Definition P_myplusx := Eval cbv in (program_Program p_myplusx).
Goal  (** works in L1g **)
  let env := (env P_myplusx) in
  let main := (main P_myplusx) in
  wcbvEval (env) 90 (main) = Ret ans_myplusx.
Proof.
  vm_compute. reflexivity.
Qed.

Quote Recursively Definition p_and_rect := and_rect.
Eval cbv in (program_Program p_and_rect).
Definition and_rect_x :=
  (and_rect (fun (a:1=1) (b:True) => conj b a) (conj (eq_refl 1) I)).
Quote Recursively Definition p_and_rect_x := and_rect_x.
Print p_and_rect_x.
Definition P_and_rect_x := Eval cbv in (program_Program p_and_rect_x).
Print P_and_rect_x.
Quote Recursively Definition cbv_and_rect_x :=
  ltac:(let t:=(eval cbv in and_rect_x) in exact t).
Print cbv_and_rect_x.
Eval cbv in (main (program_Program cbv_and_rect_x)).
Definition ans_and_rect_x :=
  Eval cbv in (main (program_Program cbv_and_rect_x)).
Print ans_and_rect_x.
Goal
  let envx := env P_and_rect_x in
  let mainx := main P_and_rect_x in
  wcbvEval envx 25 mainx = Ret ans_and_rect_x.
  vm_compute. reflexivity.
Qed.

(****** veriStar benchmark **************)
Require Import Benchmarks.vs.
Quote Recursively Definition p_Valid := vs.VeriStar.Valid.
Definition valid := (AstCommon.main (program_Program p_Valid)).

Time Quote Recursively Definition p_ce_example_myent := vs.ce_example_myent.
Time Definition P_ce_example_myent :=
  Eval vm_compute in (program_Program p_ce_example_myent).
Definition P_env_ce_example_myent :=
  Eval vm_compute in (env P_ce_example_myent).
Definition P_main_ce_example_myent :=
  Eval vm_compute in (AstCommon.main P_ce_example_myent).
Time Definition eval_ce_example_myent :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example_myent 400 P_main_ce_example_myent).
Print eval_ce_example_myent.
Goal eval_ce_example_myent = ret valid.
  vm_compute. reflexivity.
Qed.

Time Quote Recursively Definition p_ce_example_ent := vs.ce_example_ent.
Time Definition P_ce_example_ent :=
  Eval vm_compute in (program_Program p_ce_example_ent).
Definition P_env_ce_example_ent :=
  Eval vm_compute in (env P_ce_example_ent).
Definition P_main_ce_example_ent :=
  Eval vm_compute in (AstCommon.main P_ce_example_ent).
Time Definition eval_ce_example_ent :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example_ent 2000 P_main_ce_example_ent).
Print eval_ce_example_ent.
Goal eval_ce_example_ent = ret valid.
  vm_compute. reflexivity.
Qed.

Time Quote Recursively Definition p_ce_example1_myent := vs.ce_example1_myent.
Time Definition P_ce_example1_myent :=
  Eval vm_compute in (program_Program p_ce_example1_myent).
Definition P_env_ce_example1_myent :=
  Eval vm_compute in (env P_ce_example1_myent).
Definition P_main_ce_example1_myent :=
  Eval vm_compute in (AstCommon.main P_ce_example1_myent).
Time Definition eval_ce_example1_myent :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example1_myent 400 P_main_ce_example1_myent).
Print eval_ce_example1_myent.
Goal eval_ce_example1_myent = ret valid.
  vm_compute. reflexivity.
Qed.

Time Quote Recursively Definition p_ce_example2_myent := vs.ce_example2_myent.
Time Definition P_ce_example2_myent :=
  Eval vm_compute in (program_Program p_ce_example2_myent).
Definition P_env_ce_example2_myent :=
  Eval vm_compute in (env P_ce_example2_myent).
Definition P_main_ce_example2_myent :=
  Eval vm_compute in (AstCommon.main P_ce_example2_myent).
Time Definition eval_ce_example2_myent :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example2_myent 1000 P_main_ce_example2_myent).
Print eval_ce_example2_myent.
Goal eval_ce_example2_myent = ret valid.
  vm_compute. reflexivity.
Qed.

Time Quote Recursively Definition p_ce_example1_myfail := vs.ce_example1_myfail.
Time Definition P_ce_example1_myfail :=
  Eval vm_compute in (program_Program p_ce_example1_myfail).
Definition P_env_ce_example1_myfail :=
  Eval vm_compute in (env P_ce_example1_myfail).
Definition P_main_ce_example1_myfail :=
  Eval vm_compute in (AstCommon.main P_ce_example1_myfail).
Time Definition eval_ce_example1_myfail :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example1_myfail 400 P_main_ce_example1_myfail).
Print eval_ce_example1_myfail.

Time Quote Recursively Definition p_ce_example2_myfail := vs.ce_example2_myfail.
Time Definition P_ce_example2_myfail :=
  Eval vm_compute in (program_Program p_ce_example2_myfail).
Definition P_env_ce_example2_myfail :=
  Eval vm_compute in (env P_ce_example2_myfail).
Definition P_main_ce_example2_myfail :=
  Eval vm_compute in (AstCommon.main P_ce_example2_myfail).
Time Definition eval_ce_example2_myfail :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example2_myfail 1000 P_main_ce_example2_myfail).
Print eval_ce_example1_myfail.

(**** cannot do in memory and time *****
Time Quote Recursively Definition p_ce_harder_ent := vs.ce_harder_ent.
Time Definition P_ce_harder_ent :=
  Eval vm_compute in (program_Program p_ce_harder_ent).
Definition P_env_ce_harder_ent :=
  Eval vm_compute in (env P_ce_harder_ent).
Definition P_main_ce_harder_ent :=
  Eval vm_compute in (AstCommon.main P_ce_harder_ent).
Time Definition eval_ce_harder_ent :=
  Eval vm_compute in
    (wcbvEval P_env_ce_harder_ent 5000 P_main_ce_harder_ent).
Print eval_ce_harder_ent.

Time Quote Recursively Definition p_myMain := vs.myMain.
Time Definition P_myMain :=
  Eval vm_compute in (program_Program p_myMain).
Definition P_env_myMain := env P_myMain.
Definition P_main_myMain := (AstCommon.main P_myMain).
Time Definition eval_myMain :=
  Eval vm_compute in (wcbvEval P_env_myMain 5000 P_main_myMain).
Print eval_myMain.
*************)

(***
Notation NN := (mkInd "Coq.Init.Datatypes.nat" 0).
Notation SS := (TConstruct NN 1 0).
Notation ZZ := (TConstruct NN 0 0).
Notation LL := (mkInd "Coq.Init.Datatypes.list" 0).
Notation CONS := (TConstruct LL 1 1).
Notation NIL := (TConstruct LL 0 1).
Notation VSR := (mkInd "Benchmarks.vs.VeriStar.veristar_result" 0).
Notation VSR_Val := (TConstruct VSR 0).
Notation VSR_Modl := (TConstruct VSR 1).
Notation VSR_Abrt := (TConstruct VSR 2).
Notation Lam := (TLambda).
Notation tLam := (tLambda).
Notation tPi := (tProd).
Notation tPROP := (tSort sProp).
Notation AND := (mkInd "Coq.Init.Logic.and" 0).
Notation CONJ := (TConstruct AND 0 4).
Notation TRUE := (mkInd "Coq.Init.Logic.True" 0).
Notation II := (TConstruct TRUE 0 0).
Notation EQ := (mkInd "Coq.Init.Logic.eq" 0).
Notation RFL := (TConstruct EQ 0 1).
Notation PROD := (mkInd "Coq.Init.Datatypes.prod" 0).
Notation PAIR := (TConstruct PROD 0 2).
Notation "^ x" := (nNamed x)  (at level 85).
Notation "^" := (nAnon).
Infix ":t:" := tcons  (at level 87, right associativity).
Notation "fn [| arg @ args |]" :=
  (TApp fn arg args)  (at level 90, left associativity).
Notation IND := (compile.TInd).
 ***)

Definition tstx := true.
Quote Recursively Definition cbv_tstx :=
  ltac:(let t:=(eval cbv in tstx) in exact t).
Definition ans_tstx :=
  Eval cbv in (main (program_Program cbv_tstx)).
(* [program] of the program *)
Quote Recursively Definition p_tstx := tstx.
Definition P_tstx := Eval cbv in (program_Program p_tstx).
Goal
  let env := (env P_tstx) in
  let main := (main P_tstx) in
  wcbvEval (env) 90 (main) = Ret ans_tstx.
  vm_compute. reflexivity.
Qed.

Fixpoint Plus1 (n : nat): nat :=
  match n with
    | 0 => 1
    | S p => S (Plus1 p)
  end.
Definition Plus1x := (Plus1 2).
Compute Plus1x.
Quote Recursively Definition cbv_Plus1x :=
  ltac:(let t:=(eval cbv in Plus1x) in exact t).
Print cbv_Plus1x.
Definition ans_Plus1x :=
  Eval cbv in (main (program_Program cbv_Plus1x)).
Print ans_Plus1x.
(* [program] of the program *)
Quote Recursively Definition p_Plus1x := Plus1x.
Definition P_Plus1x := Eval cbv in (program_Program p_Plus1x).
Print P_Plus1x.
Goal
  let env := (env P_Plus1x) in
  let main := (main P_Plus1x) in
  wcbvEval env 90 main = Ret ans_Plus1x.
  vm_compute. reflexivity.
Qed.

(**** very simple polymorphic match  **)
Section myplus.
  Variables (A:Type).
  Inductive myNat : Type :=
  | myZ: forall a:A, myNat.
  Definition myplus (m: myNat) : A :=
    match m with
    | myZ a => a
    end.
End myplus.
Print myplus.
Definition myplusx := (myplus (myZ true)).
Compute myplusx.
Quote Recursively Definition cbv_myplusx :=
  ltac:(let t:=(eval cbv in myplusx) in exact t).
Definition ans_myplusx :=
  Eval cbv in (main (program_Program cbv_myplusx)).
Print ans_myplusx.
(* [program] of the program *)
Quote Recursively Definition p_myplusx := myplusx.
Definition P_myplusx := Eval cbv in (program_Program p_myplusx).
Goal
  let env := (env P_myplusx) in
  let main := (main P_myplusx) in
  wcbvEval (env) 90 (main) = Ret ans_myplusx.
  vm_compute. reflexivity.
Qed.

(** list apprend **)
Fixpoint myapp (ls ts: list nat): list nat :=
  match ls with
  | nil => ts
  | cons b bs => cons b (myapp bs ts)
  end.
Definition myappx := (myapp (cons 0 nil) nil).
Compute myappx.
Quote Recursively Definition cbv_myappx :=
  ltac:(let t:=(eval cbv in myappx) in exact t).
Definition ans_myappx :=
  Eval cbv in (main (program_Program cbv_myappx)).
Print ans_myappx.
(* [program] of the program *)
Quote Recursively Definition p_myappx := myappx.
Definition P_myappx := Eval cbv in (program_Program p_myappx).
Goal
  let env := (env P_myappx) in
  let main := (main P_myappx) in
  wcbvEval (env) 90 (main) = Ret ans_myappx.
  vm_compute. reflexivity.
Qed.

(** list reverse **)
Fixpoint myrev (ls: list nat): list nat :=
  match ls with
  | nil => nil
  | cons b bs => (myrev bs) ++ (cons b nil)
  end.
Definition myrevx := (myrev (cons 0 nil)).
Compute myrevx.
Quote Recursively Definition cbv_myrevx :=
  ltac:(let t:=(eval cbv in myrevx) in exact t).
Definition ans_myrevx :=
  Eval cbv in (main (program_Program cbv_myrevx)).
Print ans_myrevx.
(* [program] of the program *)
Quote Recursively Definition p_myrevx := myrevx.
Definition P_myrevx := Eval cbv in (program_Program p_myrevx).
Goal
  let env := (env P_myrevx) in
  let main := (main P_myrevx) in
  wcbvEval (env) 90 (main) = Ret ans_myrevx.
  vm_compute. reflexivity.
Qed.

(*** testing eta and params ****)
Set Printing Width 80.
Quote Recursively Definition p_0 := 0.
Definition oldP_0 := Eval cbv in (main (L2d.compile.program_Program p_0)).
Print oldP_0.
Definition P_0 := Eval cbv in (main (program_Program p_0)).
Print P_0.

Quote Recursively Definition p_1 := 1.
Definition oldP_1 := Eval cbv in (main (L2d.compile.program_Program p_1)).
Print oldP_1.
Definition P_1 := Eval cbv in (main (program_Program p_1)).
Print P_1.

Quote Recursively Definition p_nil := @nil.
Definition oldP_nil := Eval cbv in (main (L2d.compile.program_Program p_nil)).
Print oldP_nil.
Definition P_nil := Eval cbv in (main (program_Program p_nil)).
Print P_nil.

Quote Recursively Definition p_nilb := (@nil bool).
Definition oldP_nilb :=
  Eval cbv in (main (L2d.compile.program_Program p_nilb)).
Print oldP_nilb.
Definition P_nilb := Eval cbv in (main (program_Program p_nilb)).
Print P_nilb.

Quote Recursively Definition p_cons := @cons.
Definition oldP_cons :=
  Eval cbv in (main (L2d.compile.program_Program p_cons)).
Print oldP_cons.
Definition P_cons := Eval cbv in (main (program_Program p_cons)).
Print P_cons.

Quote Recursively Definition p_lcons := (fun x => @cons x).
Definition P_lcons := Eval cbv in (main (program_Program p_lcons)).
Print P_lcons.

Quote Recursively Definition p_llcons := (fun x => fun y => @cons x y).
Definition P_llcons := Eval cbv in (main (program_Program p_llcons)).
Print P_llcons.

Quote Recursively Definition p_xx :=
  (fun (y:bool) => fun (z:list bool -> bool) => z (@cons bool y nil)).
Definition P_xx := Eval cbv in (main (program_Program p_xx)).
Print P_xx.

Quote Recursively Definition p_consb := (@cons bool).
Definition oldP_consb :=
  Eval cbv in (main (L2d.compile.program_Program p_consb)).
Print oldP_consb.
Definition P_consb := Eval cbv in (main (program_Program p_consb)).
Print P_consb.

Quote Recursively Definition p_consbt := (cons true).
Definition oldP_consbt :=
  Eval cbv in (main (L2d.compile.program_Program p_consbt)).
Print oldP_consbt.
Definition P_consbt := Eval cbv in (main (program_Program p_consbt)).
Print P_consbt.

Quote Recursively Definition p_underLam := (fun (x:bool) => (cons x)).
Definition P_underLam := Eval cbv in (main (program_Program p_underLam)).
Print P_underLam.

Quote Recursively Definition p_consbtbs := (cons true nil).
Definition oldP_consbtbs :=
  Eval cbv in (main (L2d.compile.program_Program p_consbtbs)).
Print oldP_consbtbs.
Definition P_consbtbs := Eval cbv in (main (program_Program p_consbtbs)).
Print P_consbtbs.

Fixpoint testEtaNA (l:nat) : nat :=
  match l with
  | 0 => 0
  | S x => S (testEtaNA x)
  end.
Quote Recursively Definition p_testEtaNAAns :=
    ltac:(let t:=(eval cbv in (testEtaNA 0)) in exact t).
Definition P_testEtaNAAns :=
  Eval cbv in (main (LambdaBoxMut.compile.program_Program p_testEtaNAAns)).
Print P_testEtaNAAns.
Quote Recursively Definition p_texNA := (testEtaNA 0).
Definition P_texNA := Eval cbv in (LambdaBoxMut.compile.program_Program p_texNA).
Print P_texNA.
Goal
  let envx := @env Term P_texNA in
  let mainx := main P_texNA in
  wcbvEval envx 90 mainx = Ret P_testEtaNAAns.
Proof.
  vm_compute. reflexivity.
Qed.

Goal
  let envx := env P_texNA in
  let mainx := main P_texNA in
  WcbvEval envx mainx P_testEtaNAAns.
Proof.
  intros. unfold envx, mainx, P_testEtaNAAns.
  unfold P_texNA at 2. unfold main.
  eapply wAppFix.
  - eapply wConst.
    + cbn. reflexivity.
    + eapply wFix.
  - unfold dnthBody. reflexivity.
  - unfold pre_whFixStep, dlength, list_to_zero, List.fold_left.
    unfold instantiate. unfold nat_compare. unfold mkApp.
    eapply wAppLam.
    + eapply wLam.
    + eapply wConstruct. eapply wNil.
    + unfold whBetaStep, instantiate, nat_compare, mkApp.
      eapply wCase.
      * eapply wConstruct. eapply wNil.
      * cbn. reflexivity.
      * unfold whCaseStep, bnth. reflexivity.
      * unfold mkApp. eapply wConstruct. eapply wNil.
Qed.

Fixpoint testEta (l:list bool) : list bool :=   (** copy **)
  match l with
  | nil => nil
  | x :: xs => x :: testEta xs
  end.
Quote Recursively Definition p_testEtaAns :=
    ltac:(let t:=(eval cbv in (testEta (true::nil))) in exact t).
Definition P_testEtaAns :=
  Eval cbv in (main (LambdaBoxMut.compile.program_Program p_testEtaAns)).
Print P_testEtaAns.
Quote Recursively Definition p_tex := (testEta (true::nil)).
Definition P_tex := Eval cbv in (LambdaBoxMut.compile.program_Program p_tex).
Print P_tex.

Goal
  let envx := env P_tex in
  let mainx := main P_tex in
  wcbvEval envx 90 mainx = Ret P_testEtaAns.
Proof.
  vm_compute. reflexivity.
Qed.

Definition testEta1 (bs:list nat) cs := bs ++ cs.
Definition testEta1x := testEta1 (0::nil) nil.
Quote Recursively Definition p_testEta1Ans :=
    ltac:(let t:=(eval cbv in testEta1x) in exact t).
Definition P_testEta1Ans := Eval cbv in (main (program_Program p_testEta1Ans)).
Print P_testEta1Ans.
Quote Recursively Definition p_tex1 := testEta1x.
Definition P_tex1:= Eval cbv in (program_Program p_tex1).
Print P_tex1.

Goal
  let envx := env P_tex1 in
  let mainx := main P_tex1 in
  wcbvEval envx 90 mainx = Ret P_testEta1Ans.
  vm_compute.  reflexivity.
Qed.

Definition testEta2 := Eval cbv in  (1 :: nil).
Quote Recursively Definition p_testEta2Ans :=
  ltac:(let t:=(eval cbv in testEta2) in exact t).
Definition P_testEta2Ans := Eval cbv in (main (program_Program p_testEta2Ans)).
Quote Recursively Definition p_testEta2 := testEta2.
Definition P_testEta2 := Eval cbv in (program_Program p_testEta2).
Goal
  let envx := env P_testEta2 in
  let mainx := main P_testEta2 in
  wcbvEval envx 90 mainx = Ret P_testEta2Ans.
  vm_compute. reflexivity.
Qed.

(** Abhishek's example of looping: in L2 we don't test the guard **)
Require Import Arith.
Axiom AAax: Acc gt 0.
Fixpoint loop (n:nat) (x:nat) (a:Acc gt n) {struct a} : nat :=
  match n with
  | _ => @loop (S n) x (Acc_inv a (S n) (gt_Sn_n n))
  end.
Fixpoint pool (n:nat) (a:Acc gt n) {struct a} : nat -> nat :=
  match n with
  | _ => @pool (S n) (Acc_inv a (S n) (gt_Sn_n n))
  end.
Definition loop02 := @loop O 2.
Eval vm_compute in loop02.    (** Coq does not loop **)
Recursive Extraction loop02.
Definition pool0AAax := @pool O AAax.
Eval vm_compute in pool0AAax.    (** Coq does not loop **)
Recursive Extraction pool0AAax.

Definition loop02AAax := @loop O 2 AAax.
Eval vm_compute in loop02AAax.
Recursive Extraction loop02AAax.
Definition pool0AAax2 := @pool O AAax 2.
Eval vm_compute in pool0AAax2.
Recursive Extraction pool0AAax2.

(***********
Inductive mlt (n:nat) : nat -> Prop := mlt_n: mlt n (S n).
Inductive Acc (y: nat) : Prop :=
  Acc_intro : (forall x: nat, mlt y x -> Acc x) -> Acc y.
Definition Acc_inv: forall (x:nat) (H:Acc x) (y:nat), mlt x y -> Acc y.
  intros. destruct H. apply H. apply H0.
  Defined.
Fixpoint loop (n:nat) (a:Acc n) {struct a} : nat :=
  match n with
    | _ => @loop (S n) (@Acc_inv _ a (S n) (mlt_n n))
  end.
Axiom Acc0Ax : Acc 0.
Definition loop0 := (@loop O Acc0Ax).
Eval vm_compute in loop0.   (** Coq does not loop **)

Quote Recursively Definition p_loop0 := loop0.
Definition P_loop0 := Eval vm_compute in (program_Program p_loop0).
Definition P_env := Eval vm_compute in (env P_loop0).
Definition P_main := Eval vm_compute in (main P_loop0).
(** wcbvEval raises exception "out of time": non-terminating **)
Eval vm_compute in wcbvEval P_env 1000 P_main.
*****************************)

Inductive P0: Prop := p0.
Inductive P1: Prop := p1.
Notation PP0 := (mkInd "P0" 0).
Notation pp0 := (TConstruct PP0 0 0).
Notation PP1 := (mkInd "P1" 0).
Notation pp1 := (TConstruct PP1 0 0).

Quote Recursively Definition p_and_rect := and_rect.
Print p_and_rect.
Eval cbv in (program_Program p_and_rect).

Definition and_rect_x :=
  (and_rect (fun (a:2=2) (b:True) => conj b a) (conj (eq_refl 2) I)).
Quote Recursively Definition p_and_rect_x := and_rect_x.
Definition P_and_rect_x := Eval cbv in (program_Program p_and_rect_x).
Print P_and_rect_x.
Quote Recursively Definition cbv_and_rect_x :=
  ltac:(let t:=(eval cbv in and_rect_x) in exact t).
Definition ans_and_rect_x :=
  Eval cbv in (main (program_Program cbv_and_rect_x)).
Definition envx := env P_and_rect_x.
Definition mainx := main P_and_rect_x.
Goal
  wcbvEval envx 90 mainx = Ret ans_and_rect_x.
  vm_compute. (******** fails HERE because of TProof
  reflexivity.
Qed.
               *****************)
Abort.

Definition and_rectx :=
  and_rect (fun (x0:P0) (x1:P1) => pair (conj x1 x0) 0) (conj p0 p1).
Eval cbv in and_rectx.
Quote Recursively Definition ans_and_rectx := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in and_rectx) in exact t).
Definition Ans_and_rectx :=
  Eval cbv in (wcbvEval (env (program_Program ans_and_rectx)) 1000
                        (main (program_Program ans_and_rectx))).
Print Ans_and_rectx.
Quote Recursively Definition p_and_rectx := and_rectx.
Print p_and_rectx.
Definition P_and_rectx := Eval cbv in (program_Program p_and_rectx).
Print P_and_rectx.
Definition P_envx := env P_and_rectx.
Definition P_mainx := main P_and_rectx.
Goal wcbvEval P_envx 100 P_mainx = Ans_and_rectx.
  vm_compute. reflexivity.
Qed.

Definition my_and_rect :=
  fun (A B : Prop) (P : Type) (f : A -> B -> P) (a : A /\ B) =>
    match a with conj x x0 => f x x0 end.
Quote Recursively Definition p_my_and_rect := my_and_rect.
Print p_my_and_rect.
Eval cbv in (program_Program p_my_and_rect).
Quote Recursively Definition p_my_and_rectx :=
  (and_rect (fun (x0:P0) (x1:P1) => pair (conj x1 x0) 0) (conj p0 p1)).
Definition P_my_and_rectx := Eval cbv in (program_Program p_and_rectx).
Definition P_my_envx := env P_my_and_rectx.
Definition P_my_mainx := main P_my_and_rectx.
Eval cbv in (wcbvEval P_my_envx 100 P_my_mainx).

Definition my_and_rect_x :=
  (my_and_rect (fun (a:2=2) (b:True) => conj b a) (conj (eq_refl 2) I)).
Quote Recursively Definition p_my_and_rect_x := my_and_rect_x.
Definition P_my_and_rect_x := Eval cbv in (program_Program p_my_and_rect_x).
Quote Recursively Definition cbv_my_and_rect_x :=
  ltac:(let t:=(eval cbv in my_and_rect_x) in exact t).
Definition ans_my_and_rect_x :=
  Eval cbv in (main (program_Program cbv_my_and_rect_x)).
Definition my_envx := env P_my_and_rect_x.
Definition my_mainx := main P_my_and_rect_x.
Eval cbv in (wcbvEval my_envx 30 my_mainx).

(** Fibonacci **)
Fixpoint slowFib (n:nat) : nat :=
  match n with
    | 0 => 0
    | S m => match m with
               | 0 => 1
               | S p => slowFib p + slowFib m
             end
  end.
Definition slowFib3 := (slowFib 3).
Compute slowFib3.
Quote Recursively Definition cbv_slowFib3 :=
  ltac:(let t:=(eval cbv in slowFib3) in exact t).
Eval cbv in (program_Program cbv_slowFib3).
Definition ans_slowFib3 :=
  Eval cbv in (main (program_Program cbv_slowFib3)).
Print ans_slowFib3.
(* [program] of the program *)
Quote Recursively Definition p_slowFib3 := slowFib3.
Print p_slowFib3.
Definition P_slowFib3 := Eval cbv in (program_Program p_slowFib3).
Print P_slowFib3.
Goal
  let env := (env P_slowFib3) in
  let main := (main P_slowFib3) in
  wcbvEval env 30 main = Ret ans_slowFib3.
  vm_compute. reflexivity.
Qed.

Definition div : forall x y, y > 0 -> { z | z*y <= x < (S z)*y }.
Proof.
  induction x as [x Hrec] using (well_founded_induction lt_wf).
  intros y Hy.
  case_eq (y <=? x); intros.  (* do we have y≤x or x<y ? *)
  (* first case: y≤x *)
  - pose proof (leb_complete _ _ H) as j1.
    assert (Hxy : x-y < x) by omega.
    destruct (Hrec (x-y) Hxy y Hy) as [z Hz]. (* ie: let z = div (x-y) y *)
    exists (S z); simpl in *; omega. (* ie: z+1 fits as (div x y) *)
  (* second case: x<y *)
  - pose proof (leb_complete_conv _ _ H).
    exists 0; omega.
Defined.
Print div.
Extraction div.

Definition funnyDiv: forall x y, { z | z*(S y) <= x < (S z)*(S y) }.
Proof.
  induction x as [x Hrec] using (well_founded_induction lt_wf).
  intros y.
  case_eq (S y <=? x); intros.
  - pose proof (leb_complete _ _ H) as j1.
    assert (Hxy : x-(S y) < x) by omega.
    destruct (Hrec (x- S y) Hxy y) as [z Hz]. (* ie: let z = div (x-y) y *)
    exists (S z); simpl in *; omega. (* ie: z+1 fits as (div x y) *)
  - pose proof (leb_complete_conv _ _ H).
    exists 0. cbn. omega.
Defined.
Print funnyDiv.
Extraction funnyDiv.

Function copy (n : nat) {wf lt n} : nat :=
  match n with
    | 0 => 0
    | S p => S (copy p)
  end.
Admitted.
Print Assumptions copy.

Compute (copy 2).
Print copy_terminate.
Check forall n : nat,
       {v : nat |
       exists p : nat,
         forall k : nat,
         p < k -> forall def : nat -> nat, Recdef.iter (nat -> nat) k copy_F def n = v}.
(* Transparent copy_terminate. *)
(****
- intros. constructor.
- apply lt_wf.
Defined.
Print copy_tcc.

Print copy.
Definition x := 2.
Definition copyx := copy x.
Set Printing Width 200.
Compute copyx.
Print copy_terminate.   (* Opaque, but printable *)
Check (forall n:nat, {v:nat | exists p:nat, forall k:nat, p < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def n = v}:Set).

Definition cp_term :=    (* Transparent *)
  (fun h:(forall n p:nat, n = S p -> p < S p) /\ well_founded lt =>
 let H := h:(forall n p:nat, n = S p -> p < S p) /\ well_founded lt in
 (fun _TmpHyp:(forall n p:nat, n = S p -> p < S p) /\ well_founded lt =>
  and_rec
    (fun (H0:forall n p:nat, n = S p -> p < S p) (H1:well_founded lt) (n:nat) =>
     let Acc_n := (let wf_R := H1:well_founded lt in wf_R n):Acc lt n in
     (fix hrec (n0:nat) (Acc_n0:Acc lt n0) {struct Acc_n0}:{v:nat | exists p:nat, forall k:nat, p < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def n0 = v} :=
        match n0 as n1 return (n0 = n1 -> {v:nat | exists p:nat, forall k:nat, p < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def n1 = v}) with
        | 0 =>
            fun _:n0 = 0 =>
            exist (fun v:nat => exists p:nat, forall k:nat, p < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def 0 = v) 0
              (ex_intro (fun p:nat => forall k:nat, p < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def 0 = 0) 1
                 (fun k:nat =>
                  match k as n1 return (1 < n1 -> forall def:nat -> nat, Recdef.iter (nat -> nat) n1 copy_F def 0 = 0) with
                  | 0 => fun h0:1 < 0 => False_ind (forall def:nat -> nat, Recdef.iter (nat -> nat) 0 copy_F def 0 = 0) (Nat.nlt_0_r 1 h0)
                  | S k0 => fun (_:1 < S k0) (def:nat -> nat) => eq_refl
                  end))
        | S p =>
            fun teq:n0 = S p =>
            sig_rec
              (fun _:{v:nat | exists p0:nat, forall k:nat, p0 < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def p = v} =>
               {v:nat | exists p0:nat, forall k:nat, p0 < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def (S p) = v})
              (fun (rec_res:nat) (p2:exists p0:nat, forall k:nat, p0 < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def p = rec_res) =>
               exist (fun v:nat => exists p0:nat, forall k:nat, p0 < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def (S p) = v) (S rec_res)
                 (ex_ind
                    (fun (x:nat) (H2:forall k:nat, x < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def p = rec_res) =>
                     max_type_ind 0 x (fun _:max_type 0 x => exists p0:nat, forall k:nat, p0 < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def (S p) = S rec_res)
                       (fun (v:nat) (_:0 <= v) (l0:x <= v) =>
                        ex_intro (fun p0:nat => forall k:nat, p0 < k -> forall def:nat -> nat, Recdef.iter (nat -> nat) k copy_F def (S p) = S rec_res) (S v)
                          (fun k:nat =>
                           match k as n1 return (S v < n1 -> forall def:nat -> nat, Recdef.iter (nat -> nat) n1 copy_F def (S p) = S rec_res) with
                           | 0 => fun h0:S v < 0 => False_ind (forall def:nat -> nat, Recdef.iter (nat -> nat) 0 copy_F def (S p) = S rec_res) (Nat.nlt_0_r (S v) h0)
                           | S k0 => fun (h':S v < S k0) (def:nat -> nat) => eq_ind_r (fun n1:nat => S n1 = S rec_res) eq_refl (H2 k0 (Nat.le_lt_trans x v k0 l0 (lt_S_n v k0 h')) def)
                           end)) (max 0 x)) p2)) (hrec p (Acc_inv Acc_n0 (eq_ind_r (fun n1:nat => p < n1) (H0 n0 p teq) teq)))
        end eq_refl) n Acc_n) _TmpHyp) H) copy_tcc.

Compute (let (x, _) := cp_term 2 in x).

Time Quote Recursively Definition pcopyx := copyx.
Time Definition Pcopyx :=
  Eval vm_compute in (LambdaBoxMut.compile.program_Program pcopyx).
Time Definition Penv_copyx := env Pcopyx.
Time Definition Pmain_copyx := main Pcopyx.
Time Definition ans_copyx :=
 Eval vm_compute in (wcbvEval Penv_copyx 1000 Pmain_copyx).
Print ans_copyx.
*****************)

Function Gcd (a b:nat) {wf lt a}:nat :=
match a with
 | O => b
 | S k => Gcd (b mod S k) (S k)
end.
Proof.
  - intros m n k Heq. subst. apply Nat.mod_upper_bound.
    intros h. discriminate.
  - exact lt_wf.
Defined.
Print Gcd_tcc.
Definition Gcdx := (Gcd 4 2).
Eval cbv in Gcdx.
(***** runs out of memory here  ****
Time Quote Recursively Definition pGcdx := Gcdx.
Time Definition PGcdx :=
  Eval vm_compute in (LambdaBoxMut.compile.program_Program pGcdx).
Time Definition Penv_Gcdx := env PGcdx.
Time Definition Pmain_Gcdx := main PGcdx.
Time Definition ans_Gcdx :=
 Eval vm_compute in (wcbvEval Penv_Gcdx 1000 Pmain_Gcdx).
Print ans_Gcdx.
***)

(***
(** Andrew's example **)
Function sqrt' (n x0 x diff: Z) {measure Z.to_nat diff}:Z :=
  (if diff =? 0 then x
   else let y := Z.div2 (x + Z.div n x)
        in if y =? x0 then Z.min x0 x
           else sqrt' n x y (y-x0))%Z.
Proof.
Admitted.

Quote Recursively Definition psqrt := sqrt'.
Definition Psqrt := Eval cbv in (program_Program psqrt).
****)

(** vector addition **)
Require Coq.Vectors.Vector.
Print Fin.t.
Print Vector.t.

Definition vplus (n:nat) :
  Vector.t nat n -> Vector.t nat n -> Vector.t nat n := (Vector.map2 plus).
Definition v01:Vector.t nat 2 :=
  (Vector.cons nat 0 1 (Vector.cons nat 1 0 (Vector.nil nat))).
Definition v23:Vector.t nat 2 :=
  (Vector.cons nat 2 1 (Vector.cons nat 3 0 (Vector.nil nat))).
Definition vplus0123 := (vplus v01 v23).
Quote Recursively Definition cbv_vplus0123 := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (vplus0123)) in exact t).
Print cbv_vplus0123.
(* [Term] of Coq's answer *)
Definition ans_vplus0123 := Eval cbv in (main (program_Program cbv_vplus0123)).
(* [program] of the program *)
Quote Recursively Definition p_vplus0123 := vplus0123.
Print p_vplus0123.
Definition P_vplus0123 := Eval cbv in (program_Program p_vplus0123).
Print P_vplus0123.
Goal
  let env := (env P_vplus0123) in
  let main := (main P_vplus0123) in
  wcbvEval (env) 100 (main) = Ret ans_vplus0123.
  vm_compute. reflexivity.
Qed.

Inductive pack (A:Prop):Prop := Pack: A -> A -> A -> A -> pack A.
Axiom packax: forall A, pack A -> pack A.
Definition pack_nat (A:Prop) (a:pack A):nat :=
  match packax a with
    | Pack b1 b2 b3 b4 => 0
  end.
Quote Recursively Definition p_pack_nat := (pack_nat (Pack I I I I)).
Check p_pack_nat.
Definition P_pack_nat := Eval cbv in (program_Program p_pack_nat).
Print P_pack_nat.

Inductive xxxx:Prop :=
| xxxxl: forall n:nat, n = 0 -> xxxx
| xxxxr: forall n:nat, n = 1 -> xxxx.
Axiom Xxxx:xxxx.
Definition yyyy (f:xxxx) := match f with xxxxl q => f | xxxxr q => f end.
Definition yyyyX := (yyyy Xxxx).
Quote Recursively Definition cbv_yyyyX := (* [program] of Coq's answer *)
  ltac:(let t:=(eval cbv in (yyyyX)) in exact t).
Print cbv_yyyyX.
(* [Term] of Coq's answer *)
Definition ans_yyyyX := Eval cbv in (main (program_Program cbv_yyyyX)).
Print ans_yyyyX.
(* [program] of the program *)
Quote Recursively Definition p_yyyyX := yyyyX.
Print p_yyyyX.
Definition P_yyyyX := Eval cbv in (program_Program p_yyyyX).
Print P_yyyyX.
(*********** what is the problem?
** axiom inside proof, but proofs haven't been stripped yet at LambdaBoxMut
 ***********
Goal WcbvEval xxxx_env xxxx_main ans_yyyyX.
Proof.
  unfold main. eapply wProof. eapply wConst.
  - unfold env. cbn. reflexivity.
  - eapply wProof. eapply wAppLam.
    + eapply wConst. cbn. reflexivity. eapply wProof. eapply wLam.
****************)
Goal
  let xxxx_env := (env P_yyyyX) in
  let xxxx_main := (main P_yyyyX) in
  wcbvEval xxxx_env 10 xxxx_main = Ret ans_yyyyX.
  vm_compute.
  (**********
reflexivity.
Qed.
   *************)
Abort.

(** mutual recursion **)
Set Implicit Arguments.
Inductive tree (A:Set):Set :=
  node:A -> forest A -> tree A
with forest (A:Set):Set :=
     | leaf:A -> forest A
     | fcons:tree A -> forest A -> forest A.

Fixpoint tree_size (t:tree bool):nat :=
  match t with
    | node a f => S (forest_size f)
  end
with forest_size (f:forest bool):nat :=
       match f with
         | leaf b => 1
         | fcons t f1 => (tree_size t + forest_size f1)
       end.

Definition arden: forest bool :=
  fcons (node true (fcons (node true (leaf false)) (leaf true)))
        (fcons (node true (fcons (node true (leaf false)) (leaf true)))
               (leaf false)).
Definition arden_size := (forest_size arden).
Quote Recursively Definition cbv_arden_size :=
  ltac:(let t:=(eval cbv in arden_size) in exact t).
Definition ans_arden_size :=
  Eval cbv in (main (program_Program cbv_arden_size)).
(* [program] of the program *)
Quote Recursively Definition p_arden_size := arden_size.
Print p_arden_size.
Definition P_arden_size := Eval cbv in (program_Program p_arden_size).
Print P_arden_size.
Goal
  let env := (env P_arden_size) in
  let main := (main P_arden_size) in
  wcbvEval (env) 100 (main) = Ret ans_arden_size.
  vm_compute. reflexivity.
Qed.

(** Ackermann **)
Fixpoint ackn (Ack:nat -> nat) (m:nat) {struct m}:nat :=
  match m with
  | 0 => Ack 1
  | S q => Ack (ackn Ack q)
  end.
Fixpoint Ack (n:nat) {struct n}:nat -> nat :=
  match n with
    | 0 => S
    | S p => ackn (Ack p)
  end.
Quote Recursively Definition p_Ack := Ack.
Print p_Ack.
Definition P_Ack := Eval cbv in (program_Program p_Ack).
Print P_Ack.
Time Compute Ack 3 7.

Fixpoint ACK (n:nat) {struct n}:nat -> nat :=
  match n with
    | 0 => S
    | S p => let fix ackn (m:nat) {struct m} :=
                 match m with
                   | 0 => ACK p 1
                   | S q => ACK p (ackn q)
                 end
             in ackn
  end.
Quote Recursively Definition p_ACK := ACK.
Print p_ACK.
Definition P_ACK := Eval cbv in (program_Program p_ACK).
Print P_ACK.
Compute ACK 3 7.

Fixpoint ack (n m:nat) {struct n}:nat :=
  match n with
    | 0 => S m
    | S p => let fix ackn (m:nat) {struct m} :=
                 match m with
                   | 0 => ack p 1
                   | S q => ack p (ackn q)
                 end
             in ackn m
  end.
Compute ack 3 7.
Definition ack35 := (ack 3 5).
Quote Recursively Definition cbv_ack35 :=
  ltac:(let t:=(eval cbv in ack35) in exact t).
Print cbv_ack35.
Definition ans_ack35 :=
  Eval cbv in (main (program_Program cbv_ack35)).
Print ans_ack35.
(* [program] of the program *)
Quote Recursively Definition p_ack35 := ack35.
Print p_ack35.
Definition P_ack35 := Eval cbv in (program_Program p_ack35).
Print P_ack35.
Goal
  let env := (env P_ack35) in
  let main := (main P_ack35) in
  wcbvEval (env) 2000 (main) = Ret ans_ack35.
  vm_compute. reflexivity.
Qed.

(** SASL tautology function: variable arity **)
Fixpoint tautArg (n:nat):Type :=
  match n with
    | 0 => bool
    | S n => bool -> tautArg n
  end.
Fixpoint taut (n:nat):tautArg n -> bool :=
  match n with
    | 0 => (fun x => x)
    | S n => fun x => taut n (x true) && taut n (x false)
  end.
(* Pierce *)
Definition pierce := taut 2 (fun x y => implb (implb (implb x y) x) x).
Quote Recursively Definition cbv_pierce :=
  ltac:(let t:=(eval cbv in pierce) in exact t).
Print cbv_pierce.
Definition ans_pierce :=
  Eval cbv in (main (program_Program cbv_pierce)).
Print ans_pierce.
(* [program] of the program *)
Quote Recursively Definition p_pierce := pierce.
Print p_pierce.
Definition P_pierce := Eval cbv in (program_Program p_pierce).
Print P_pierce.
Goal
  let env := (env P_pierce) in
  let main := (main P_pierce) in
  wcbvEval (env) 2000 (main) = Ret ans_pierce.
  vm_compute. reflexivity.
Qed.
(* S combinator *)
Definition Scomb := taut 3
         (fun x y z => implb (implb x (implb y z))
                             (implb (implb x y) (implb x z))).
Quote Recursively Definition cbv_Scomb :=
  ltac:(let t:=(eval cbv in Scomb) in exact t).
Print cbv_Scomb.
Definition ans_Scomb :=
  Eval cbv in (main (program_Program cbv_Scomb)).
Print ans_Scomb.
(* [program] of the program *)
Quote Recursively Definition p_Scomb := Scomb.
Print p_Scomb.
Definition P_Scomb := Eval cbv in (program_Program p_Scomb).
Print P_Scomb.
Goal
  let env := (env P_Scomb) in
  let main := (main P_Scomb) in
  wcbvEval (env) 2000 (main) = Ret ans_pierce.
  vm_compute. reflexivity.
Qed.

Inductive uuyy: Set := uu | yy.
Inductive wwzz: Set := ww (_:uuyy)| zz (_:nat) (_:uuyy) (_:bool).
Definition Foo:nat -> bool -> wwzz -> wwzz :=
  fun (n:nat) (b:bool) (x:wwzz) =>
    match n,x,b with
      | 0, _, true => ww uu
      | 0, _, false => ww yy
      | S m, ww x, b => zz m x b
      | S m, zz n x c, b => zz m x b
    end.
Definition Foo0ty := (Foo 0 true (ww uu)).
Quote Recursively Definition cbv_Foo0ty :=
  ltac:(let t:=(eval cbv in Foo0ty) in exact t).
Definition ans_Foo0ty :=
  Eval cbv in (main (program_Program cbv_Foo0ty)).
(* [program] of the program *)
Quote Recursively Definition p_Foo0ty := Foo0ty.
Definition P_Foo0ty := Eval cbv in (program_Program p_Foo0ty).
Goal
  let env := (env P_Foo0ty) in
  let main := (main P_Foo0ty) in
  wcbvEval (env) 30 (main) = Ret ans_Foo0ty.
  vm_compute. reflexivity.
Qed.

(* fast Fib *)
Fixpoint fibrec (n:nat) (fs:nat * nat) {struct n}:nat :=
  match n with
    | 0 => fst fs
    | (S n) => fibrec n (pair ((fst fs) + (snd fs)) (fst fs))
  end.
Definition fib:nat -> nat := fun n => fibrec n (pair 0 1).
Definition fib9 := fib 9.
Quote Recursively Definition cbv_fib9 :=
  ltac:(let t:=(eval cbv in fib9) in exact t).
Definition ans_fib9 :=
  Eval cbv in (main (program_Program cbv_fib9)).
(* [program] of the program *)
Quote Recursively Definition p_fib9 := fib9.
Definition P_fib9 := Eval cbv in (program_Program p_fib9).
Goal
  let env := (env P_fib9) in
  let main := (main P_fib9) in
  wcbvEval (env) 1000 (main) = Ret ans_fib9.
  vm_compute. reflexivity.
Qed.

(** Heterogenous datatypes, a la Matthes **)
Inductive PList:Set->Type:=  (* powerlists *)
| zero:forall A:Set, A -> PList A
| succ:forall A:Set, PList (A * A)%type -> PList A.

Definition myPList : PList nat := (succ (zero (0,1))).
(********
Definition myPList : PList nat :=
  succ (succ (succ (zero (((1,2),(3,4)),((5,6),(7,8)))))).
 **********)

Fixpoint unzip (A:Set) (l:list (A*A)) {struct l}:list A :=
  match l return list A with
    | nil => nil
    | cons (a1,a2) l' => cons a1 (cons a2 (unzip l'))
  end.
Fixpoint PListToList (A:Set) (l:PList A) {struct l}:list A :=
  match l in PList A return list A with
    | zero a => cons a (nil )
    | succ l' => unzip (PListToList l')
  end.

Eval compute in PListToList myPList.

Set printing width 150.
Fixpoint gen_sumPList (A:Set) (l:PList A) {struct l}:(A->nat)->nat :=
  match l in PList A return (A->nat)->nat with
    | zero a => fun f => f a
    | succ l' =>
      fun f => gen_sumPList l' (fun a => let (a1,a2) := a in f a1 + f a2)
  end.
Definition sumPList l := gen_sumPList l (fun x => x).
Definition sumPL_myPL := (sumPList myPList).
Quote Recursively Definition cbv_sumPL_myPL :=
  ltac:(let t:=(eval cbv in sumPL_myPL) in exact t).
Definition ans_sumPL_myPL :=
  Eval cbv in (main (program_Program cbv_sumPL_myPL)).
(* [program] of the program *)
Quote Recursively Definition p_sumPL_myPL := sumPL_myPL.
Definition P_sumPL_myPL := Eval cbv in (program_Program p_sumPL_myPL).
Goal
  let env := (env P_sumPL_myPL) in
  let main := (main P_sumPL_myPL) in
  wcbvEval (env) 1000 (main) = Ret ans_sumPL_myPL.
  vm_compute. reflexivity.
Qed.

Set Implicit Arguments.
Section List.
Variables X Y:Type.
Variable f:X -> Y -> Y.
Fixpoint fold (y:Y) (xs:list X):Y :=
  match xs with
    | nil => y
    | cons x xr => fold (f x y) xr
  end.
End List.
Inductive Tree := T:list Tree -> Tree.
Fixpoint size (t:Tree):nat :=
  match t with
    | T ts => S (fold (fun t a => size t + a) 0 ts)
  end.
Definition myTree := (T (cons (T (unit (T nil)))
                              (cons (T (unit (T nil))) nil))).
Eval cbv in size myTree.
Definition size_myTree := size myTree.
Quote Recursively Definition cbv_size_myTree :=
  ltac:(let t:=(eval cbv in size_myTree) in exact t).
Definition ans_size_myTree :=
  Eval cbv in (main (program_Program cbv_size_myTree)).
(* [program] of the program *)
Quote Recursively Definition p_size_myTree := size_myTree.
Definition P_size_myTree := Eval cbv in (program_Program p_size_myTree).
Goal
  let env := (env P_size_myTree) in
  let main := (main P_size_myTree) in
  wcbvEval (env) 1000 (main) = Ret ans_size_myTree.
  vm_compute. reflexivity.
Qed.

Require Import Benchmarks.vs.
Print Assumptions main.

(*** Exc: contains an axiom which is a proof, not stripped yet ******
Time Quote Recursively Definition p_ce_example_myent := vs.ce_example_myent.
Time Definition P_ce_example_myent :=
  Eval vm_compute in (program_Program p_ce_example_myent).
Definition P_env_ce_example_myent := env P_ce_example_myent.
Definition P_main_ce_example_myent := AstCommon.main P_ce_example_myent.
Time Definition eval_ce_example_myent :=
  Eval vm_compute in
    (wcbvEval P_env_ce_example_myent 500 P_main_ce_example_myent).
Set Printing Width 100.
Print eval_ce_example_myent.
**********************)

(********************
Time Quote Recursively Definition p_myMain := vs.myMain.
Time Definition P_myMain :=
  Eval vm_compute in (LambdaBoxMut.compile.program_Program p_myMain).
Definition P_env_myMain := env P_myMain.
Definition P_main_myMain := AstCommon.main P_myMain.
Time Definition eval_myMain :=
  Eval vm_compute in (wcbvEval P_env_myMain 7000 P_main_myMain).
Set Printing Width 100.
Print eval_myMain.
************)

(********************
Print Assumptions vs.main.
Time Quote Recursively Definition p_ce_example_ent := vs.ce_example_ent.
Time Definition P_ce_example_ent :=
  Eval vm_compute in (program_Program p_ce_example_ent).
Time Definition P_env_ce_example_ent := env P_ce_example_ent.
Time Definition P_main_ce_example_ent := AstCommon.main P_ce_example_ent.
Time Definition eval_ce_example_ent :=
  Eval vm_compute in (wcbvEval P_env_ce_example_ent 1000 P_main_ce_example_ent).
Print eval_ce_example_ent.
**********************)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a2_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ dom_ a7_)))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ dom_ A7)))))) -> p_ A1 A2 A3 A4 A5 A6 A7)).
Variable ax3_3 : (p_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma7_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import perm zmodp matrix.
Require Import Reals Fourier.
Require Import Rssr Reals_ext ssr_ext.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma iter_Rmax a b (Hb : b <= a) k : ssrnat.iter k (Rmax b) a = a.
Proof. elim: k => // k Hk; by rewrite iterS Hk Rmax_right. Qed.

Notation "\rmax_ ( a 'in' A ) F" := (\big[Rmax/0%R]_( a in A ) F)
  (at level 41, F at level 41, a, A at level 50,
    format "'[' \rmax_ ( a  'in'  A ) '/  '  F ']'") : R_scope.
Notation "\rmax_ ( i | P ) F" := (\big[Rmax/0%R]_( i | P) F)
  (at level 41, F at level 41, i at level 50,
    format "'[' \rmax_ ( i | P ) '/  '  F ']'") : R_scope.
Notation "\rmax_ ( i '<-' A | P ) F" := (\big[Rmax/0%R]_( i <- A | P ) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rmax_ ( i  '<-'  A  |  P ) '/  '  F ']'") : R_scope.
Notation "\rmax_ ( a '<-' A ) F" := (\big[Rmax/0%R]_( a <- A ) F)
  (at level 41, F at level 41, a, A at level 50,
    format "'[' \rmax_ ( a  '<-'  A ) '/  '  F ']'") : R_scope.
Reserved Notation "\rmax_ ( i : t ) F"
  (at level 41, F at level 41, i at level 50,
           only parsing).

Notation "\rmax_ ( i : I ) F" :=
  (\big[Rmax/R0]_(i : I) F) (only parsing) : R_scope.

Section bigrmax_sect.

Variables (A : eqType) (F : A -> R) (s : seq A).

Lemma Rle_bigRmax : forall m, m \in s -> F m <= \rmax_(m <- s) (F m).
Proof.
elim: s => // hd tl IH m; rewrite in_cons; case/orP.
- move/eqP => ->; rewrite big_cons; by apply Rmax_l.
- move/IH => H; rewrite big_cons.
  eapply Rle_trans; by [apply H | apply Rmax_r].
Qed.

Lemma Rle_0_bigRmax : (forall r, r \in s -> 0 <= F r) -> 0 <= \rmax_(m <- s) (F m).
Proof.
case: s => [_ | hd tl Hr].
- rewrite big_nil; by apply Rle_refl.
- apply Rle_trans with (F hd); last by rewrite big_cons; apply Rmax_l.
  apply Hr; by rewrite in_cons eqxx.
Qed.

End bigrmax_sect.

Lemma bigrmax_undup (I : eqType) g : forall (s : seq I),
   \rmax_(c <- s) g c = \rmax_(c <- undup s) g c.
Proof.
elim=> // hd tl IH /=.
rewrite big_cons.
case: ifP => Hcase.
- rewrite -IH Rmax_right //; by apply Rle_bigRmax.
- by rewrite big_cons IH.
Qed.

Lemma bigrmax_cat (I : eqType) g : forall (s1 s2 : seq I),
  (forall x, x \in s1 ++ s2 -> 0 <= g x) ->
  \rmax_(c <- s1 ++ s2) g c = Rmax (\rmax_(c <- s1) g c) (\rmax_(c <- s2) g c).
Proof.
elim => [s2 Hg /= | h1 t1 IH s2 Hg /=].
  rewrite big_nil Rmax_right //.
  by apply Rle_0_bigRmax.
rewrite 2!big_cons IH; last first.
  move=> x Hx; apply Hg.
  by rewrite /= in_cons Hx orbC.
by rewrite RmaxA.
Qed.

Lemma bigrmax_perm (I : eqType) g : forall (s1 s2 : seq I),
  (forall r, r \in s2 -> 0 <= g r) ->
  perm_eq s1 s2 -> uniq s1 -> uniq s2 ->
  \rmax_(c0 <- s1) g c0 = \rmax_(c0 <- s2) g c0.
Proof.
move=> s1.
move H : (size s1) => n1.
elim: n1 s1 H => //.
  case=> // _ s _ Hs.
  suff -> : s = [::].
    move=> _ _; by rewrite !big_nil.
  destruct s => //.
  move/allP : Hs.
  move/(_ s).
  by rewrite /= inE eqxx /= => /(_ Logic.eq_refl) /= add1n.
move=> n1 IH1 [|h1 t1] // [] H1 s2 Hg Hs2 K1 K2.
rewrite big_cons.
have [h2 [t2 ht2]] : exists h2 t2, s2 = h2 ++ h1 :: t2.
  apply in_cat; by rewrite -(perm_eq_mem Hs2) in_cons eqxx.
have Hs2' : perm_eq t1 (h2 ++ t2).
  rewrite ht2 in Hs2.
  rewrite -(perm_cons h1).
  eapply perm_eq_trans; first by apply Hs2.
  by rewrite perm_catC /= perm_cons perm_catC.
have Hg' r : r \in h2 ++ t2 -> 0 <= g r.
  move=> rs2; apply Hg.
  rewrite ht2 mem_cat in_cons.
  rewrite mem_cat in rs2.
  case/orP : rs2 => [-> // | -> /=].
  by rewrite orbA orbC.
rewrite (IH1 _ H1 _ Hg' Hs2'); last 2 first.
  by case/andP : K1.
  rewrite ht2 cat_uniq /= in K2.
  case/andP : K2 => K2 /andP [] K4 /andP [] _ K3.
  rewrite cat_uniq K2 K3 /= andbC /=.
  rewrite negb_or in K4.
  by case/andP : K4.
rewrite bigrmax_cat // RmaxA (RmaxC (g h1)) -RmaxA ht2 bigrmax_cat; last first.
  move=> x Hx; apply Hg; by rewrite ht2.
by rewrite big_cons.
Qed.

Lemma bigrmax_eqi (I : finType) g : forall (s1 s2 : seq I),
  (forall r : I, r \in s1 -> 0 <= g r) -> s1 =i s2 ->
  \rmax_(c0 <- s1) g c0 = \rmax_(c0 <- s2) g c0.
Proof.
move=> s1 s2 Hg s1s2.
rewrite (bigrmax_undup _ s1) (bigrmax_undup g s2).
apply bigrmax_perm; [ | | by rewrite undup_uniq | by rewrite undup_uniq].
- move=> r Hr; apply Hg.
  rewrite mem_undup in Hr.
  by rewrite s1s2.
- apply uniq_perm_eq; [by rewrite undup_uniq | by rewrite undup_uniq | ].
  move=> i; by rewrite !mem_undup.
Qed.

Lemma rmax_imset' {M : finType} (I : finType) h (g : I -> R) (s : seq M) :
  (forall r : I, r \in enum [set h x | x in s] -> 0 <= g r) ->
  \rmax_(c0 <- enum [set h x | x in s]) g c0 = \rmax_(m <- s) g (h m).
Proof.
elim: s.
  rewrite big_nil.
  set tmp := enum _.
  suff -> : tmp = [::] by rewrite big_nil.
  rewrite /tmp -[in X in _ = X]enum0.
  apply eq_enum => a.
  rewrite !inE.
  apply/imsetP. case => m.
  by rewrite in_nil.
move=> hd tl IH Hg /=.
rewrite big_cons -IH; last first.
  move=> r Hr.
  apply Hg.
  rewrite mem_enum.
  apply/imsetP.
  rewrite mem_enum in Hr.
  case/imsetP : Hr => x xtl Hr.
  exists x => //.
  by rewrite in_cons xtl orbC.
transitivity (\rmax_(c0 <- h hd :: enum [set h x | x in tl]) g c0).
apply bigrmax_eqi => // x.
rewrite inE !mem_enum.
move Hlhs : (x \in [set _ _ | _ in _]) => lhs.
destruct lhs.
  - case/imsetP : Hlhs => x0 Hx0 H.
    rewrite in_cons in Hx0.
    case/orP : Hx0 => Hx0.
      move/eqP : Hx0 => ?; subst x0.
      by rewrite H eqxx.
    symmetry.
    apply/orP; right.
    apply/imsetP; by exists x0.
  - symmetry.
    apply/negbTE.
    move/negbT : Hlhs.
    apply contra.
    case/orP => Hcase.
    + move/eqP in Hcase; subst x.
      apply/imsetP.
      exists hd => //.
      by rewrite inE eqxx.
    + apply/imsetP.
      case/imsetP : Hcase => x0 Hx0 ?; subst x.
      exists x0 => //.
      by rewrite inE Hx0 orbC.
by rewrite big_cons.
Qed.

Lemma rmax_imset {M : finType} (I : finType) h (g : I -> R) :
  (forall r : I, r \in [set h x | x in M] -> 0 <= g r) ->
  \rmax_(c0 in [set h x | x in M]) g c0 = \rmax_(m in M) g (h m).
Proof.
move=> Hg.
eapply trans_eq.
  eapply trans_eq; last first.
    apply (@rmax_imset' _ I h g (enum M)).
    move=> r; rewrite mem_enum; case/imsetP => x; rewrite mem_enum => Hx ->.
    apply Hg; apply/imsetP; by exists x.
  rewrite big_filter /=.
  apply congr_big => //.
  move=> i /=.
  move Hlhs : (i \in _) => lhs.
  destruct lhs.
  - case/imsetP : Hlhs => x Hx ?; subst i.
    symmetry; apply/imsetP.
    exists x => //.
    by rewrite mem_enum.
  - symmetry.
    apply/negbTE.
    move/negbT : Hlhs; apply contra.
    case/imsetP => m Hm ?; subst i.
    apply/imsetP.
    by exists m.
apply congr_big => //; by rewrite enumT.
Qed.

Lemma Rle_bigrmax_R {A : finType} (h : A -> R) (tl : seq A) hd :
  (forall r, 0 <= h r) ->
  (forall c : A, c \in tl -> h c <= h hd) ->
  \rmax_(j <- tl) h j <= h hd.
Proof.
elim: tl hd => [hd Hh _ | hd1 tl2 IH hd Hhpos Hh].
  rewrite big_nil; by apply Hh.
rewrite big_cons.
apply Rmax_lub.
- apply Hh.
  by rewrite in_cons eqxx.
- apply IH => // c0 Hc0; apply Hh.
  by rewrite in_cons Hc0 orbC.
Qed.

Lemma bigrmax_max_seq {A : finType} (h : A -> R) (s : seq A) a :
  a \in s ->
  (forall r, 0 <= h r) ->
  (forall c, c \in s -> h c <= h a) ->
  h a = \rmax_(c <- s) h c.
Proof.
elim: s a => // hd tl IH a; rewrite in_cons; case/orP.
- move/eqP => -> Hhpos Hh.
  rewrite big_cons.
  rewrite Rmax_left //.
  apply Rle_bigrmax_R => //.
  move=> c0 Hc0; apply Hh.
  by rewrite in_cons Hc0 orbC.
- move=> atl Hhpos Hh.
  rewrite big_cons Rmax_right //.
  + apply IH => //.
    move=> c0 Hc0; apply Hh.
    by rewrite in_cons Hc0 orbC.
  + rewrite -(IH a) //.
    * apply Hh.
      by rewrite in_cons eqxx.
    * move=> c0 Hc0.
      apply Hh.
      by rewrite in_cons Hc0 orbC.
Qed.

Lemma bigrmax_max {A : finType} (C : {set A}) a (h : A -> R):
  a \in C ->
  (forall r, 0 <= h r) ->
  (forall c, c \in C -> h c <= h a) ->
  h a = \rmax_(c | c \in C) h c.
Proof.
move=> aC Hhpos Hh.
rewrite -big_filter.
apply bigrmax_max_seq => //.
- by rewrite mem_filter aC /= mem_index_enum.
- move=> c0.
  rewrite mem_filter.
  case/andP => ? ?.
  by apply Hh.
Qed.

Lemma rmax_distrr I a (apos: 0 <= a) r (Q:pred I) F :
  ((a * \rmax_(i <- r | Q i) F i) = \rmax_(i <- r | Q i) (a * F i)).
Proof.
elim: r => [| h t IH].
  by rewrite 2!big_nil mulR0.
rewrite 2!big_cons.
case: ifP => Qh //.
by rewrite -IH RmaxRmult.
Qed.

Lemma rmax_distrl I a (apos: 0 <= a) r (Q:pred I) F :
  ((\rmax_(i <- r | Q i) F i) * a = \rmax_(i <- r | Q i) (F i * a)).
Proof.
rewrite mulRC rmax_distrr //.
by apply congr_big; auto using mulRC.
Qed.

Notation "\min^ b '_(' a 'in' A ) F" :=
((fun a => F) (arg_min b (fun x => x \in A) (fun a => F)))
  (at level 41, F at level 41, a, A at level 50,
    format "'[' \min^ b '_(' a  'in'  A ) '/  '  F ']'") : min_scope.

Local Open Scope min_scope.

Lemma bigminn_min {A : finType} (C : {set A}) (cnot0 : {c0 | c0 \in C}) a (Ha : a \in C) (h : A -> nat) :
  (\min^ (sval cnot0) _(c in C) h c <= h a)%nat.
Proof.
case: arg_minP.
by destruct cnot0.
move=> a0 a0C H.
by apply H.
Qed.

(* TODO: useless ? *)
Lemma big_rmax_bigminn_helper {A : finType} n (g : nat -> R) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall (C : {set n.-tuple A}) c'' (_ : c'' \in C) (d : n.-tuple A -> nat)
  (_ : forall c, c \in C -> (d c <= n)%nat)
  (cnot0 : {c0 | c0 \in C}),
  d c'' = \min^ (sval cnot0) _(c in C) d c ->
  g (d c'') = \rmax_(c in C) g (d c).
Proof.
move=> Hdecr Hr C c'' Hcc' d Hd cnot0 H.
apply (@bigrmax_max _ C c'' (fun a => g (d a))) => //.
move=> /= c0 c0C.
apply Hdecr.
apply/andP; split.
  rewrite H.
  by apply bigminn_min.
by apply Hd.
Qed.

Lemma big_rmax_bigminn {A M : finType} n (f : {ffun M -> n.-tuple A}) (g : nat -> R)
  (cnot0 : {c0 | c0 \in f @: M } ) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall m'' (d : n.-tuple A -> nat)
  (_ : forall c0 : n.-tuple A, c0 \in [set f x | x : M] -> (d c0 <= n)%nat),
  d (f m'') = \min^ (sval cnot0) _(c in [set f x | x in M]) d c ->
  g (d (f m'')) = \rmax_(m | m \in M) g (d (f m)).
Proof.
move=> n1n2 Hg m'' d H Hd.
transitivity (\rmax_(c in [set f x | x in M]) g (d c)); last by rewrite rmax_imset.
apply big_rmax_bigminn_helper with cnot0 => //.
apply/imsetP.
by exists m''.
Qed.

Lemma big_rmax_bigminn_helper_vec {A : finType} n (g : nat -> R) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall (C : {set 'rV[A]_n}) c'' (_ : c'' \in C) (d : 'rV[A]_n -> nat)
  (_ : forall c, c \in C -> (d c <= n)%nat)
  (cnot0 : {c0 | c0 \in C}),
  d c'' = \min^ (sval cnot0) _(c in C) d c ->
  g (d c'') = \rmax_(c in C) g (d c).
Proof.
move=> Hdecr Hr C c'' Hcc' d Hd cnot0 H.
apply (@bigrmax_max _ C c'' (fun a => g (d a))) => //.
move=> /= c0 c0C.
apply Hdecr.
apply/andP; split.
  rewrite H.
  by apply bigminn_min.
by apply Hd.
Qed.

Lemma big_rmax_bigminn_vec {A M : finType} n (f : {ffun M -> 'rV[A]_n}) (g : nat -> R)
  (cnot0 : {c0 | c0 \in f @: M } ) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall m'' (d : 'rV[A]_n -> nat)
  (_ : forall c0 : 'rV[A]_n, c0 \in f @: M -> (d c0 <= n)%nat),
  d (f m'') = \min^ (sval cnot0) _(c in f @: M) d c ->
  g (d (f m'')) = \rmax_(m in M) g (d (f m)).
Proof.
move=> n1n2 Hg m'' d H Hd.
transitivity (\rmax_(c in f @: M) g (d c)); last by rewrite rmax_imset.
apply big_rmax_bigminn_helper_vec with cnot0 => //.
apply/imsetP.
by exists m''.
Qed.


Require Import Coq.PArith.BinPos.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.HList.
Require Import MirrorCore.syms.SymPolyEnv.

(** Demo **)
Section Demo.
  Definition types' : types :=
    list_to_types (@Some Type nat :: @Some Type (list nat) :: nil).

  Definition all (T : Type) (P : T -> Prop) : Prop :=
    forall x, P x.

  Definition typD := typD types'.

  Let tyNat := tyType 1.

  Definition funcs' : functions typD.
  refine (from_list (
          F typD 0
             (tyArr tyNat (tyArr tyNat tyNat))
             plus ::
          F _ 1
             (tyArr (tyArr (tyVar 0) tyProp) tyProp)
             (fun x : Type => @ex x) ::
          F _ 1
             (tyArr (tyArr (tyVar 0) tyProp) tyProp)
             all ::
          F _ 1
             (tyArr (tyVar 0) (tyArr (tyVar 0) tyProp))
             (fun T : Type => @eq T) ::
          F typD 0 (tyType 1) 0 ::
          nil)).
  Defined.

  Definition App_list (f : expr (func typ)) (args : list (expr (func typ)))
  : expr (func typ) :=
    List.fold_left App args f.

  Goal
    let e :=
        @App_list (Inj (FRef 2%positive (tyType 1 :: nil)))
                  ((Abs tyNat (@App_list (Inj (FRef 4%positive (tyType 1 :: nil)))
                                         ((Var 0) :: Inj (FRef 5%positive nil) :: nil))) :: nil)
    in
    let rsym := RSym_func _ funcs' instantiate_typ (@type_apply _) (@type_apply_length_equal _) in
    match exprD (Expr := Expr_expr rsym) nil nil e tyProp with
      | None => False
      | Some p => p
    end.
  Proof.
    simpl. exists 0. reflexivity.
  Qed.

End Demo.


(** * keyslice_fun.v : Functional model of Key and Keyslices *)
Require Import VST.floyd.functional_base.
Import Coq.Lists.List.ListNotations.
Require Import DB.common.

Definition keyslice_length := Ptrofs.zwordsize / Byte.zwordsize.
Lemma keyslice_length_32: Archi.ptr64 = false -> keyslice_length = 4.
Proof using.
  intros H; first [discriminate H | reflexivity].
Qed.
Hint Rewrite keyslice_length_32 using reflexivity: rep_lia.
Lemma keyslice_length_64: Archi.ptr64 = true -> keyslice_length = 8.
Proof using.
  intros H; first [discriminate H | reflexivity].
Qed.
Hint Rewrite keyslice_length_64 using reflexivity: rep_lia.
Global Opaque keyslice_length.

Definition keyslice: Set := Z.
Instance EqDec_keyslice: EqDec keyslice := Z.eq_dec.
Definition keyslice_with_len: Set := Z * Z.
Instance EqDec_keyslice_with_len: EqDec keyslice_with_len.
Proof using.
  unfold EqDec.
  intros.
  destruct a.
  destruct a'.
  destruct (eq_dec z z1); destruct (eq_dec z0 z2); subst; auto; right; intro; inversion H; auto.
Qed.

Fixpoint get_keyslice_aux (key: string) (n: nat) (result: Z): keyslice :=
  match key, n with
  | _, O => result
  | [], S n' => get_keyslice_aux [] n' (result * Byte.modulus)
  | ch :: key', S n' => get_keyslice_aux key' n' (result * Byte.modulus + (Byte.unsigned ch))
  end.

Definition get_keyslice (key: string): keyslice :=
  get_keyslice_aux key (Z.to_nat keyslice_length) 0.

Definition get_suffix (key: string): string :=
  sublist keyslice_length (Zlength key) key.

Definition get_keyslice_with_len (key: string): keyslice_with_len :=
  (get_keyslice key, Z.min keyslice_length (Zlength key)).

(* A keypath is a sequence of keyslice with an optional suffix *)
Definition keypath_pred (keypath: list keyslice_with_len * option string) :=
  let (keyslice_list, suffix) := keypath in
  Zlength keyslice_list > 0 /\
  if suffix then
    Forall (fun k => snd k = 8) keyslice_list
  else
    Forall (fun k => snd k = 8) (sublist 0 (Zlength keyslice_list - 1) keyslice_list).

Definition keypath := sig keypath_pred.

Function reconstruct_keyslice_aux (slice: Z) (len: Z) {measure Z.to_nat len} :=
  if Z_gt_dec len 0 then
    reconstruct_keyslice_aux (slice / Byte.modulus) (len - 1) ++ [Byte.repr slice]
  else
    [].
Proof using.
  intros.
  rewrite <- Z2Nat.inj_lt; lia.
Defined.

Definition reconstruct_keyslice (slice_with_len: keyslice_with_len) :=
  let (slice, len) := slice_with_len in
  reconstruct_keyslice_aux (Z.shiftr slice (keyslice_length - len) * Byte.zwordsize) len.

Definition reconstruct_keypath (keypath: keypath): string :=
  let (keyslice_list, suffix) := proj1_sig keypath in
  match suffix with
  | Some s =>
    concat (map reconstruct_keyslice keyslice_list) ++ s
  | None =>
    concat (map reconstruct_keyslice keyslice_list)
  end.

Definition keypath_rep (keypath: keypath) (key: string): Prop :=
  reconstruct_keypath keypath = key.

Lemma get_keyslice_snoc: forall (key: string) (snoc: byte) (init: Z),
    get_keyslice_aux (key ++ [snoc]) (Z.to_nat (Zlength key + 1)) init = get_keyslice_aux (key) (Z.to_nat (Zlength key)) init * Byte.modulus + (Byte.unsigned snoc).
Proof using.
  intros.
  rewrite (ZtoNat_Zlength key).
  generalize dependent init.
  induction key; intros.
  - simpl.
    reflexivity.
  - simpl.
    rewrite Z2Nat.inj_add by list_solve.
    rewrite Nat.add_1_r.
    simpl.
    rewrite Zlength_cons.
    rewrite Z.add_1_r in IHkey.
    rewrite IHkey.
    reflexivity.
Qed.

Lemma get_keyslice_aux_gen: forall (key: string) (len: Z) (init: Z),
    0 <= len ->
    get_keyslice_aux key (Z.to_nat len) init = get_keyslice_aux (sublist 0 len key) (Z.to_nat len) init.
Proof using.
  induction key; intros; simpl.

  - unfold sublist. rewrite skipn_0.
    rewrite firstn_nil.
(*or perhaps:
  - unfold sublist.
    rewrite firstn_nil. rewrite skipn_nil.*)

    reflexivity.
  - destruct (Z_lt_dec len (Zlength (a :: key))); destruct (eq_dec len 0).
    + subst.
      reflexivity.
    + rewrite Zlength_cons in l.
      rewrite sublist_split with (mid := 1) by list_solve.
      rewrite sublist_len_1 by list_solve.
      rewrite Znth_0_cons.
      simpl.
      destruct (Z.to_nat len) eqn:Heqn.
      * assert (len = 0). {
          rewrite <- (Z2Nat.id len) by rep_lia.
          rewrite <- (Z2Nat.id 0) by rep_lia.
          f_equal.
          apply Heqn.
        }
        congruence.
      * simpl.
        rewrite sublist_1_cons.
        assert (n0 = Z.to_nat (len - 1)). {
          rewrite <- Nat2Z.id at 1.
          rewrite Z2Nat.inj_sub by rep_lia.
          rewrite Heqn.
          simpl.
          rewrite Nat.sub_0_r.
          rewrite Nat2Z.id.
          reflexivity.
        }
        rewrite H0.
        rewrite IHkey by list_solve.
        reflexivity.
    + subst.
      reflexivity.
    + rewrite sublist_same_gen by rep_lia.
      destruct (Z.to_nat len) eqn:Heqn.
      * assert (len = 0). {
          rewrite <- (Z2Nat.id len) by rep_lia.
          rewrite <- (Z2Nat.id 0) by rep_lia.
          f_equal.
          apply Heqn.
        }
        congruence.
      * reflexivity.
Qed.

Lemma get_keyslice_padding_aux: forall (init mult: Z) (i: nat),
    get_keyslice_aux [] i (init * mult) = get_keyslice_aux [] i init * mult.
Proof using.
  intros.
  generalize dependent mult.
  generalize dependent init.
  induction i; intros.
  - simpl.
    reflexivity.
  - simpl.
    repeat rewrite IHi.
    rewrite <- Z.mul_assoc.
    rewrite (Z.mul_comm mult Byte.modulus).
    rewrite Z.mul_assoc.
    reflexivity.
Qed.

Lemma get_keyslice_padding: forall (key: string) (init: Z) (i: Z),
    Zlength key <= i ->
    get_keyslice_aux (key) (Z.to_nat (i + 1)) init = get_keyslice_aux (key) (Z.to_nat i) init * Byte.modulus.
Proof using.
  intros.
  remember (Z.to_nat i) as n.
  replace (Z.to_nat (i + 1)) with (n + 1)%nat by (rewrite Heqn; rewrite Z2Nat.inj_add by rep_lia; reflexivity).
  assert (length key <= n)%nat. {
    rewrite Zlength_correct in H.
    rewrite <- Z2Nat.id in H by rep_lia.
    rewrite <- Heqn in H.
    apply Nat2Z.inj_le in H.
    assumption.
  }
  clear Heqn.
  clear H.
  generalize dependent key.
  generalize dependent init.
  induction n; intros.
  - destruct key; simpl.
    + reflexivity.
    + simpl in H0.
      list_solve.
  - simpl.
    rewrite IHn by (simpl; lia).
    destruct key.
    + reflexivity.
    + rewrite IHn.
      * reflexivity.
      * simpl in H0.
        lia.
Qed.

Lemma get_keyslice_aux_init_lt: forall k1 k2 init1 init2 len,
    init1 < init2 ->
    get_keyslice_aux k1 len init1 < get_keyslice_aux k2 len init2.
Proof using.
  intros.
  generalize dependent init1.
  generalize dependent init2.
  generalize dependent k1.
  generalize dependent k2.
  induction len; intros.
  - destruct k1; destruct k2; simpl; lia.
  - destruct k1; destruct k2; simpl;
      apply IHlen; rep_lia.
Qed.

Lemma get_keyslice_cons_inv: forall c1 c2 k1 k2 init len,
    0 < len ->
    get_keyslice_aux (c1 :: k1) (Z.to_nat len) init = get_keyslice_aux (c2 :: k2) (Z.to_nat len) init ->
    Byte.unsigned c1 = Byte.unsigned c2.
Proof using.
  intros.
  remember (Z.to_nat len) as n.
  assert (0 < n)%nat. {
    apply Nat2Z.inj_lt.
    rewrite Heqn.
    rewrite Z2Nat.id by rep_lia.
    rep_lia.
  }
  clear H Heqn len.
  generalize dependent k1.
  generalize dependent k2.
  generalize dependent c1.
  generalize dependent c2.
  generalize dependent init.
  induction n; intros.
  - rep_lia.
  - simpl in H0.
    destruct (eq_dec (Byte.unsigned c1) (Byte.unsigned c2)).
    + auto.
    + assert (Byte.unsigned c1 < Byte.unsigned c2 \/ Byte.unsigned c1 > Byte.unsigned c2) by rep_lia.
      destruct H;
        first [
            pose proof (get_keyslice_aux_init_lt
                          k1 k2
                          (init * Byte.modulus + Byte.unsigned c1) (init * Byte.modulus + Byte.unsigned c2) n
                          ltac:(rep_lia))
          | pose proof (get_keyslice_aux_init_lt
                          k2 k1
                          (init * Byte.modulus + Byte.unsigned c2) (init * Byte.modulus + Byte.unsigned c1) n
                          ltac:(rep_lia))
          ];
        rep_lia.
Qed.

Lemma get_keyslice_aux_eq_inv: forall k1 k2 init1 init2 len,
    get_keyslice_aux k1 len init1 = get_keyslice_aux k2 len init1 ->
    get_keyslice_aux k1 len init2 = get_keyslice_aux k2 len init2.
Proof using.
  intros.
  generalize dependent k1.
  generalize dependent k2.
  generalize dependent init1.
  generalize dependent init2.
  induction len; intros.
  - destruct k1; destruct k2; reflexivity.
  - destruct k1; destruct k2; simpl in H; simpl;
      first [
          eapply IHlen; apply H
        | let Heqn := fresh "Heqn" in
          destruct (eq_dec (init1 * Byte.modulus + Byte.unsigned i) (init1 * Byte.modulus)) as [Heqn | Heqn];
          first [
              let Hzero := fresh "Hzero" in
              assert (Hzero: Byte.unsigned i = 0) by rep_lia;
              rewrite Hzero in *;
              rewrite Z.add_0_r in *;
              eapply IHlen;
              apply H
            | let Hnzero := fresh "Hnzero" in
              assert (Hnzero: Byte.unsigned i <> 0) by rep_lia;
              match goal with
              | [H : get_keyslice_aux ?k2 _ (_ + _) = get_keyslice_aux ?k1 _ _ |- _] =>
                pose proof (get_keyslice_aux_init_lt
                              k1 k2 (init1 * Byte.modulus) (init1 * Byte.modulus + Byte.unsigned i) len
                              ltac:(rep_lia)); rep_lia
              | [H : get_keyslice_aux ?k1 _ _ = get_keyslice_aux ?k2 _ (_ + _) |- _] =>
                pose proof (get_keyslice_aux_init_lt
                              k1 k2 (init1 * Byte.modulus) (init1 * Byte.modulus + Byte.unsigned i) len
                              ltac:(rep_lia)); rep_lia
              end
            ]
        | let Heqn := fresh "Heqn" in
          destruct (eq_dec (Byte.unsigned i) (Byte.unsigned i0)) as [Heqn | ];
          first [
              rewrite Heqn in *;
              eapply IHlen;
              apply H
            | assert (Byte.unsigned i < Byte.unsigned i0 \/ Byte.unsigned i > Byte.unsigned i0) by rep_lia;
              destruct H0;
              first [
                  pose proof (get_keyslice_aux_init_lt
                                k1 k2
                                (init1 * Byte.modulus + Byte.unsigned i) (init1 * Byte.modulus + Byte.unsigned i0) len
                                ltac:(rep_lia))
                | pose proof (get_keyslice_aux_init_lt
                                k2 k1
                                (init1 * Byte.modulus + Byte.unsigned i0) (init1 * Byte.modulus + Byte.unsigned i) len
                                ltac:(rep_lia))
                ];
              rep_lia
            ]
        ].
Qed.

Lemma get_keyslice_aux_inrange_aux: forall (key: string) (len: nat) (init: Z),
    0 <= init ->
    0 <= get_keyslice_aux key len init < (init + 1) * Byte.modulus ^ (Z.of_nat len).
Proof using.
  intros.
  generalize dependent init.
  generalize dependent key.
  induction len; intros.
  - rewrite Z.pow_0_r.
    simpl.
    destruct key; lia.
  - destruct key.
    + simpl.
      assert (0 <= init * Byte.modulus) by rep_lia.
      specialize (IHlen [] (init * Byte.modulus) H0).
      split; try lia.
      destruct IHlen.
      apply (Z.lt_le_trans _ _ _ H2).
      rewrite Z.mul_add_distr_r.
      rewrite Z.mul_add_distr_r.
      apply Z.add_le_mono.
      * rewrite <- Z.mul_assoc.
        rewrite <- Z.pow_succ_r by apply Nat2Z.is_nonneg.
        rewrite <- Zpos_P_of_succ_nat.
        reflexivity.
      * rewrite Z.pow_pos_fold.
        rewrite Zpos_P_of_succ_nat.
        rewrite Z.pow_succ_r by apply Nat2Z.is_nonneg.
        rewrite (Z.mul_comm Byte.modulus).
        rewrite Z.mul_assoc.
        apply Z.le_mul_diag_r.
        -- rewrite Z.mul_1_l.
           apply Z.pow_pos_nonneg; [rep_lia | apply Nat2Z.is_nonneg].
        -- rep_lia.
    + simpl.
      simpl in IHlen.
      assert (0 <= (init * Byte.modulus + Byte.unsigned i)) by (rep_lia).
      specialize (IHlen key _ H0).
      split; try lia.
      destruct IHlen.
      apply (Z.lt_le_trans _ _ _ H2).
      rewrite <- Z.add_assoc.
      rewrite Z.mul_add_distr_r.
      rewrite (Z.mul_add_distr_r init 1).
      apply Z.add_le_mono.
      * rewrite <- Z.mul_assoc.
        rewrite <- Z.pow_succ_r by apply Nat2Z.is_nonneg.
        rewrite <- Zpos_P_of_succ_nat.
        reflexivity.
      * assert (Byte.unsigned i + 1 <= Byte.modulus). {
          pose proof (Byte.unsigned_range i).
          rep_lia.
        }
        rewrite Z.pow_pos_fold.
        rewrite Zpos_P_of_succ_nat.
        rewrite Z.pow_succ_r by apply Nat2Z.is_nonneg.
        rewrite Z.mul_assoc.
        rewrite Z.mul_1_l.
        apply Z.mul_le_mono_nonneg; try rep_lia.
        apply Z.pow_nonneg.
        rep_lia.
Qed.

Lemma get_keyslice_aux_inrange: forall (key: string) (len: Z),
    0 <= len <= keyslice_length ->
    0 <= get_keyslice_aux key (Z.to_nat len) 0 <= Ptrofs.max_unsigned.
Proof using.
  intros.
  pose proof (get_keyslice_aux_inrange_aux key (Z.to_nat len) 0 (Z.le_refl 0)).
  vm_compute (0 + 1) in H0.
  pose proof (Z.pow_le_mono_r Byte.modulus len keyslice_length).
  assert (0 < Byte.modulus) by rep_lia.
  assert (len <= keyslice_length) by lia.
  specialize (H1 H2 H3).
  rewrite Z2Nat.id in H0 by lia.
  change (Byte.modulus ^ keyslice_length) with Ptrofs.modulus in H1.
  rep_lia.
Qed.

Lemma get_keyslice_inrange: forall (key: string),
    0 <= get_keyslice key <= Ptrofs.max_unsigned.
Proof using.
  intros.
  unfold get_keyslice.
  simpl (Z.to_nat keyslice_length).
  pose proof (get_keyslice_aux_inrange_aux key (Z.to_nat keyslice_length) 0 (Z.le_refl 0)).
  change ((0 + 1) * _) with Ptrofs.modulus in H.
  rep_lia.
Qed.

Lemma get_keyslice_aux_len_eq: forall k1 k2 len init ,
    0 <= len ->
    get_keyslice_aux k1 (Z.to_nat len) init = get_keyslice_aux k2 (Z.to_nat len) init ->
    Zlength k1 = Zlength k2 ->
    Zlength k1 <= len ->
    k1 = k2.
Proof using.
  intros.
  remember (Z.to_nat len) as n.
  generalize dependent k1.
  generalize dependent k2.
  generalize dependent init.
  generalize dependent len.
  induction n; intros.
  - assert (len = 0). {
      rewrite <- (Nat2Z.id 0%nat) in Heqn.
      apply Z2Nat.inj in Heqn; rep_lia.
    }
    assert (k1 = []) by (apply Zlength_nil_inv; rep_lia).
    assert (k2 = []) by (apply Zlength_nil_inv; rep_lia).
    subst; reflexivity.
  - remember (len - 1) as len'.
    assert (n = Z.to_nat len'). {
      replace n with (S n - 1)%nat by lia.
      rewrite Heqn.
      rewrite Heqlen'.
      rewrite Z2Nat.inj_sub by rep_lia.
      reflexivity.
    }
    assert (1 <= len). {
      replace len with (Z.of_nat (S n)).
      - rewrite Nat2Z.inj_succ.
        rep_lia.
      - rewrite Heqn.
        rewrite Z2Nat.id; rep_lia.
    }
    specialize (IHn len' ltac:(rep_lia) ltac:(assumption)).
    destruct k1; destruct k2;
      first [
          reflexivity
        | replace (Zlength []) with 0 in H1 by list_solve;
          rewrite Zlength_cons in H1;
          rep_lia
        | idtac
        ].
    pose proof H0.
    rewrite Heqn in H0.
    apply get_keyslice_cons_inv in H0; [ | rep_lia].
    simpl in H5.
    rewrite H0 in H5.
    rewrite ?Zlength_cons in H2.
    rewrite ?Zlength_cons in H1.
    specialize (IHn _ _ _ H5 ltac:(list_solve) ltac:(list_solve)).
    f_equal; [ | assumption].
    assert (Byte.repr (Byte.unsigned i) = Byte.repr (Byte.unsigned i0)). {
      rewrite H0.
      reflexivity.
    }
    rewrite ?Byte.repr_unsigned in H6.
    trivial.
Qed.

Lemma keyslice_inj1: forall (k1 k2: string),
    k1 <> k2 ->
    get_keyslice k1 = get_keyslice k2 ->
    Zlength k1 <= keyslice_length \/ Zlength k2 <= keyslice_length ->
    Zlength k1 <> Zlength k2.
Proof using.
  intros.
  destruct (Z_le_dec (Zlength k2) keyslice_length).
  - intro.
    unfold get_keyslice in H0.
    pose proof (get_keyslice_aux_len_eq k1 k2 keyslice_length 0 ltac:(rep_lia) H0 H2 ltac:(lia)).
    auto.
  - destruct H1; lia.
Qed.

Lemma keyslice_inj2_aux: forall (k1 k2: string) init n,
    0 <= n ->
    get_keyslice_aux k1 (Z.to_nat n) init = get_keyslice_aux k2 (Z.to_nat n) init ->
    Zlength k1 > n /\ Zlength k2 > n ->
    sublist 0 n k1 = sublist 0 n k2.
Proof using.
  intros.
  generalize dependent k1.
  generalize dependent k2.
  generalize dependent init.
  remember (Z.to_nat n) as k.
  generalize dependent n.
  induction k; intros.
  - assert (n = 0). {
      rewrite <- Z2Nat.id by lia.
      simpl (Z.to_nat 0).
      rewrite Heqk.
      rewrite Z2Nat.id; rep_lia.
    }
    rewrite H2.
    rewrite ?sublist_nil.
    reflexivity.
  - destruct k1; destruct k2; subst; try (rewrite Zlength_nil in H1; rep_lia).
    pose proof H0.
    assert (0 < n). {
      destruct (eq_dec n 0).
      - subst.
        inversion Heqk.
      - lia.
    }
    rewrite Heqk in H2.
    apply get_keyslice_cons_inv in H2; [ | rep_lia].
    assert (i = i0). {
      rewrite <- (Byte.repr_unsigned i).
      rewrite <- (Byte.repr_unsigned i0).
      rewrite H2.
      reflexivity.
    }
    subst.
    simpl in H0.
    remember (n - 1) as n'.
    assert (k = Z.to_nat n'). {
      rewrite Heqn'.
      rewrite Z2Nat.inj_sub by rep_lia.
      rewrite <- Heqk.
      simpl.
      rewrite Nat.sub_0_r.
      reflexivity.
    }
    subst.
    rewrite ?Zlength_cons in H1.
    apply IHk with (n0 := n - 1) in H0; first [rep_lia | auto | idtac].
    rewrite sublist_split with (mid := 1) by list_solve.
    rewrite sublist_split with (mid := 1) (al := i0 :: k2) by list_solve.
    rewrite ?sublist_1_cons.
    rewrite H0.
    rewrite ?sublist_len_1 by list_solve.
    rewrite ?Znth_0_cons.
    reflexivity.
Qed.

Lemma keyslice_inj2: forall (k1 k2: string),
    get_keyslice k1 = get_keyslice k2 ->
    Zlength k1 > keyslice_length /\ Zlength k2 > keyslice_length ->
    sublist 0 keyslice_length k1 = sublist 0 keyslice_length k2.
Proof using.
  intros.
  unfold get_keyslice in H.
<<<<<<< HEAD
  destruct (zlt keyslice_length 0).
   rewrite !sublist_nil_gen by lia. auto.
=======
>>>>>>> origin/master
  apply keyslice_inj2_aux in H; first [rep_lia | auto].
Qed.

Lemma keyslice_inj3: forall (k1 k2: string),
    k1 <> k2 ->
    get_keyslice k1 = get_keyslice k2 ->
    Zlength k1 > keyslice_length /\ Zlength k2 > keyslice_length ->
    get_suffix k1 <> get_suffix k2.
Proof using.
  intros.
  assert (sublist 0 keyslice_length k1 = sublist 0 keyslice_length k2)
    by (apply keyslice_inj2; auto; rep_lia).
  unfold get_suffix.
  intro.
  assert (k1 = k2). {
    rewrite <- sublist_same with (lo := 0) (hi := Zlength k1) (al := k1) by rep_lia.
    rewrite <- sublist_same with (lo := 0) (hi := Zlength k2) (al := k2) by rep_lia.
<<<<<<< HEAD
    destruct (zlt keyslice_length 0).
    unfold sublist in H3.
    replace (Z.to_nat keyslice_length) with (Z.to_nat 0) in H3
     by (rewrite (Z2Nat_neg keyslice_length) by auto; auto).
    fold (sublist 0 (Zlength k1) k1) in H3.
    fold (sublist 0 (Zlength k2) k2) in H3.
    auto.
=======
>>>>>>> origin/master
    rewrite sublist_split with (mid := keyslice_length) by first [rep_lia | list_solve].
    rewrite sublist_split with (mid := keyslice_length) (al := k2) by first [rep_lia | list_solve].
    congruence.
  }
  auto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Mult.
Require Import BinNat.
Require Import Nnat.
Require Export Ring.
Set Implicit Arguments.

Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
 Proof.
  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
  exact mult_plus_distr_r.
 Qed.

Lemma nat_morph_N :
   semi_morph 0 1 plus mult (eq (A:=nat))
          0%N 1%N N.add N.mul N.eqb N.to_nat.
Proof.
  constructor;trivial.
  exact N2Nat.inj_add.
  exact N2Nat.inj_mul.
  intros x y H. apply N.eqb_eq in H. now subst.
Qed.

Ltac natcst t :=
  match isnatcst t with
    true => constr:(N.of_nat t)
  | _ => constr:(InitialRing.NotConstant)
  end.

Ltac Ss_to_add f acc :=
  match f with
  | S ?f1 => Ss_to_add f1 (S acc)
  | _ => constr:((acc + f)%nat)
  end.

(* For internal use only *)
Local Definition protected_to_nat := N.to_nat.

Ltac natprering :=
  match goal with
  |- context C [S ?p] =>
    match p with
      O => fail 1 (* avoid replacing 1 with 1+0 ! *)
    | p => match isnatcst p with
           | true => fail 1
           | false => let v := Ss_to_add p (S 0) in
                         fold v; natprering
           end
    end
  | _ => change N.to_nat with protected_to_nat
  end.

Ltac natpostring :=
  match goal with
  | |- context [N.to_nat ?x] =>
    let v := eval cbv in (N.to_nat x) in
    change (N.to_nat x) with v;
    natpostring
  | _ => change protected_to_nat with N.to_nat
  end.

Add Ring natr : natSRth
  (morphism nat_morph_N, constants [natcst],
   preprocess [natprering], postprocess [natpostring]).