Require Import
        CertifiedExtraction.Extraction.Core
        CertifiedExtraction.Extraction.Basics.

(* Lemma CompileBinop: *)
(*   forall {av} name var1 var2 (val1 val2: W) ext op tenv, *)
(*     name ∉ ext -> *)
(*     NotInTelescope name tenv -> *)
(*     StringMap.MapsTo var1 (SCA av val1) ext -> *)
(*     StringMap.MapsTo var2 (SCA av val2) ext -> *)
(*     forall env, *)
(*     {{ tenv }} *)
(*       Assign name (Binop op (Var var1) (Var var2)) *)
(*     {{ [[name ->> (SCA _ (eval_binop (inl op) val1 val2)) as _]]::tenv }} ∪ {{ ext }} // env. *)
(* Proof. *)
(*   SameValues_Facade_t. *)
(* Qed. *)

Definition WrapOpInExpr op :=
  match op with
  | inl o => Binop o
  | inr t => TestE t
  end.

Lemma CompileBinopOrTest:
  forall {av} name var1 var2 (val1 val2: W) ext op (tenv: Telescope av),
    name ∉ ext ->
    NotInTelescope name tenv ->
    StringMap.MapsTo var1 (wrap val1) ext ->
    StringMap.MapsTo var2 (wrap val2) ext ->
    forall env,
    {{ tenv }}
      Assign name (WrapOpInExpr op (Var var1) (Var var2))
    {{ [[`name ->> (eval_binop op val1 val2) as _]]::tenv }} ∪ {{ ext }} // env.
Proof.
  destruct op;
  SameValues_Facade_t.
Qed.

(* Lemma CompileBinopB_util: *)
(*   forall {T} k1 k2 k3 {v1 v2 v3} (fmap: StringMap.t T), *)
(*     k1 <> k2 -> k2 <> k3 -> k1 <> k3 -> *)
(*     StringMap.Equal ([`k3 |> v3] ::[`k2 |> v2]::[`k1 |> v1]::fmap) *)
(*                     ([`k1 |> v1] ::[`k2 |> v2]::[`k3 |> v3]::fmap). *)
(* Proof. *)
(*   unfold StringMap.Equal; intros; *)
(*   destruct (StringMap.E.eq_dec y k1); *)
(*   destruct (StringMap.E.eq_dec y k2); *)
(*   destruct (StringMap.E.eq_dec y k3); *)
(*   SameValues_Facade_t. *)
(* Qed. *)

(* Lemma CompileBinopB_util2: *)
(*   forall {av : Type} (var1 var2 var3 : StringMap.key) *)
(*     (val1 val2 val3 : _) (ext : StringMap.t (Value av)), *)
(*     var1 <> var2 -> *)
(*     var2 <> var3 -> *)
(*     var1 <> var3 -> *)
(*     var1 ∉ ext -> *)
(*     var2 ∉ ext -> *)
(*     var3 ∉ ext -> *)
(*     [`var1 |> val1] *)
(*       ::[`var2 |> val2] *)
(*       ::[`var3 |> val3]::ext *)
(*       ≲ [[`var1 ->> val1 as _]] *)
(*       ::[[`var2 ->> val2 as _]] *)
(*       ::[[`var3 ->> val3 as _]]::Nil ∪ ext. *)
(* Proof. *)
(*   intros. *)
(*   repeat apply Cons_PopExt; try decide_not_in. *)
(*   rewrite CompileBinopB_util by assumption. *)
(*   apply SameValues_Nil_always. *)
(* Qed. *)

(* Lemma CompileBinop_with_dealloc_USELESS: *)
(*   forall {av} name var1 var2 (val1 val2: W) env ext op p1 p2 p3, *)
(*     name ∉ ext -> *)
(*     var1 ∉ ext -> *)
(*     var2 ∉ ext -> *)
(*     var1 <> var2 -> *)
(*     var1 <> name -> *)
(*     var2 <> name -> *)
(*     {{ Nil }} *)
(*       p1 *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::Nil }} *)
(*       p2 *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::[[`var2 ->> SCA _ val2 as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::[[`var2 ->> SCA _ val2 as _]]::[[`name ->> (SCA av (eval_binop (inl op) val1 val2)) as _]]::Nil }} *)
(*       p3 *)
(*     {{ [[ret (SCA _ val1) as _]]::[[ret (SCA _ val2) as _]]::[[`name ->> (SCA av (eval_binop (inl op) val1 val2)) as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ Nil }} *)
(*       (Seq p1 (Seq p2 (Seq (Assign name (Binop op (Var var1) (Var var2))) p3))) *)
(*     {{ [[`name ->> (SCA av (eval_binop (inl op) val1 val2)) as _]]::Nil }} ∪ {{ ext }} // env. *)
(* Proof. *)
(*   Time SameValues_Facade_t; *)
(*  *)
(*   assert ([`name |> SCA av (IL.evalBinop op val1 val2)]::st'0 *)
(*         ≲ [[`var1 ->> SCA av val1 as _]] *)
(*           ::[[`var2 ->> SCA av val2 as _]] *)
(*             ::[[`name ->> SCA av (eval_binop (inl op) val1 val2) as _]]::Nil *)
(*             ∪ ext) by (repeat apply Cons_PopExt; *)
(*                         try decide_not_in; *)
(*                         simpl; *)
(*                         SameValues_Facade_t); *)
(*  *)
(*   SameValues_Facade_t. *)
(* Qed. *)

(* Lemma CompileBinop_left: *)
(*   forall {av} name var1 var2 (val1 val2: W) env ext op p2, *)
(*     name ∉ ext -> *)
(*     StringMap.MapsTo var1 (SCA av val1) ext -> *)
(*     var2 ∉ ext -> *)
(*     var1 <> var2 -> *)
(*     var2 <> name -> *)
(*     {{ Nil }} *)
(*       p2 *)
(*     {{ [[`var2 ->> SCA _ val2 as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ Nil }} *)
(*       (Seq p2 (Assign name (Binop op (Var var1) (Var var2)))) *)
(*     {{ [[`name ->> (SCA av (eval_binop (inl op) val1 val2)) as _]]::Nil }} ∪ {{ ext }} // env. *)
(* Proof. *)
(*   Time SameValues_Facade_t. *)
(*  *)
(*   rewrite (add_redundant_cancel H0) in H19; SameValues_Facade_t. *)
(*   apply Cons_PopExt; [ SameValues_Facade_t | ]. *)
(*  *)
(*   cut (st' ≲ Nil ∪ ext); *)
(*   repeat match goal with *)
(*          | _ => reflexivity *)
(*          | _ => solve [simpl; SameValues_Facade_t] *)
(*          | _ => apply WeakEq_pop_SCA; [decide_not_in|] *)
(*          | [ H: WeakEq ?a ?st |- ?st ≲ _ ∪ _ ] => rewrite <- H *)
(*          | _ => progress simpl *)
(*          end. *)
(* Qed. *)

Lemma CompileBinopOrTest_left:
  forall {av} name var1 var2 (val1 val2: W) env ext op p2 (tenv: Telescope av),
    name ∉ ext ->
    NotInTelescope name tenv ->
    StringMap.MapsTo var1 (wrap val1) ext ->
    var2 ∉ ext ->
    var1 <> var2 ->
    var2 <> name ->
    {{ tenv }}
      p2
    {{ [[`var2 ->> val2 as _]]::tenv }} ∪ {{ ext }} // env ->
    {{ tenv }}
      (Seq p2 (Assign name (WrapOpInExpr op (Var var1) (Var var2))))
    {{ [[`name ->> (eval_binop op val1 val2) as _]]::tenv }} ∪ {{ ext }} // env.
Proof.
  repeat hoare.
  destruct op; SameValues_Facade_t.
Qed.

(* Lemma CompileBinop_right: *)
(*   forall {av} name var1 var2 (val1 val2: W) env ext op p2, *)
(*     name ∉ ext -> *)
(*     var1 ∉ ext -> *)
(*     StringMap.MapsTo var2 (SCA av val2) ext -> *)
(*     var1 <> var2 -> *)
(*     var1 <> name -> *)
(*     {{ Nil }} *)
(*       p2 *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ Nil }} *)
(*       (Seq p2 (Assign name (Binop op (Var var1) (Var var2)))) *)
(*     {{ [[`name ->> (SCA av (eval_binop (inl op) val1 val2)) as _]]::Nil }} ∪ {{ ext }} // env. *)
(* Proof. *)
(*   Time SameValues_Facade_t. *)
(*  *)
(*   rewrite (add_redundant_cancel H1) in H19; SameValues_Facade_t. *)
(*   apply Cons_PopExt; [ SameValues_Facade_t | ]. *)
(*  *)
(*   cut (st' ≲ Nil ∪ ext); *)
(*   repeat match goal with *)
(*          | _ => reflexivity *)
(*          | _ => solve [simpl; SameValues_Facade_t] *)
(*          | _ => apply WeakEq_pop_SCA; [decide_not_in|] *)
(*          | [ H: WeakEq ?a ?st |- ?st ≲ _ ∪ _ ] => rewrite <- H *)
(*          | _ => progress simpl *)
(*          end. *)
(* Qed. *)

Lemma CompileBinopOrTest_right:
  forall {av} name var1 var2 (val1 val2: W) env ext op p2 (tenv: Telescope av),
    name ∉ ext ->
    NotInTelescope name tenv ->
    StringMap.MapsTo var2 (wrap val2) ext ->
    var1 ∉ ext ->
    var1 <> var2 ->
    var1 <> name ->
    {{ tenv }}
      p2
    {{ [[`var1 ->> val1 as _]]::tenv }} ∪ {{ ext }} // env ->
    {{ tenv }}
      (Seq p2 (Assign name (WrapOpInExpr op (Var var1) (Var var2))))
    {{ [[`name ->> (eval_binop op val1 val2) as _]]::tenv }} ∪ {{ ext }} // env.
Proof.
  repeat hoare.
  destruct op; SameValues_Facade_t.
Qed.

(* Lemma CompileBinop_full: *)
(*   forall {av} name var1 var2 (val1 val2: W) env ext op p1 p2, *)
(*     name ∉ ext -> *)
(*     var1 ∉ ext -> *)
(*     var2 ∉ ext -> *)
(*     var1 <> var2 -> *)
(*     var1 <> name -> *)
(*     var2 <> name -> *)
(*     {{ Nil }} *)
(*       p1 *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::Nil }} *)
(*       p2 *)
(*     {{ [[`var1 ->> SCA _ val1 as _]]::[[`var2 ->> SCA _ val2 as _]]::Nil }} ∪ {{ ext }} // env -> *)
(*     {{ Nil }} *)
(*       (Seq p1 (Seq p2 (Assign name (Binop op (Var var1) (Var var2))))) *)
(*     {{ [[`name ->> (SCA av (eval_binop (inl op) val1 val2)) as _]]::Nil }} ∪ {{ ext }} // env. *)
(* Proof. *)
(*   Time SameValues_Facade_t. *)
(*   apply Cons_PopExt; [ SameValues_Facade_t | ]. *)
(*  *)
(*   cut (st'0 ≲ Nil ∪ ext); *)
(*   repeat match goal with *)
(*          | _ => reflexivity *)
(*          | _ => solve [simpl; SameValues_Facade_t] *)
(*          | _ => apply WeakEq_pop_SCA; [decide_not_in|] *)
(*          | [ H: WeakEq ?a ?st |- ?st ≲ _ ∪ _ ] => rewrite <- H *)
(*          | _ => progress simpl *)
(*          end. *)
(* Qed. *)

Opaque Word.natToWord.

Lemma CompileBinopOrTest_full:
  forall {av} name var1 var2 (val1 val2: W) env ext op p1 p2 (tenv: Telescope av),
    name ∉ ext ->
    NotInTelescope name tenv ->
    var1 ∉ ext ->
    var2 ∉ ext ->
    var1 <> var2 ->
    var1 <> name ->
    var2 <> name ->
    {{ tenv }}
      p1
    {{ [[`var1 ->> val1 as _]]::tenv }} ∪ {{ ext }} // env ->
    {{ [[`var1 ->> val1 as _]]::tenv }}
      p2
    {{ [[`var1 ->> val1 as _]]::[[`var2 ->> val2 as _]]::tenv }} ∪ {{ ext }} // env ->
    {{ tenv }}
      (Seq p1 (Seq p2 (Assign name ((match op with inl o => Binop o | inr o => TestE o end) (Var var1) (Var var2)))))
    {{ [[`name ->> (eval_binop op val1 val2) as _]]::tenv }} ∪ {{ ext }} // env.
Proof.
  repeat hoare.
  destruct op; SameValues_Facade_t.

  apply (SameValues_Pop_Both (H := FacadeWrapper_SCA)); eauto 2.
  apply SameValues_not_In_Telescope_not_in_Ext_remove; eauto 2.
  eapply SameValues_forget_Ext.
  2:eapply SameValues_forget_Ext; try eassumption.
  eauto with SameValues_db.
  eauto with SameValues_db.

  apply (SameValues_Pop_Both (H := FacadeWrapper_SCA)); eauto 2.
  apply SameValues_not_In_Telescope_not_in_Ext_remove; eauto 2.
  eapply SameValues_forget_Ext.
  2:eapply SameValues_forget_Ext; try eassumption.
  eauto with SameValues_db.
  eauto with SameValues_db.
Qed.                               (* NOTE why doesn't eauto suffice here? *)

Lemma CompileBinopOrTest_right_inPlace:
  forall {av} op name var2 (val1 val2: W) env ext (tenv: Telescope av),
    name ∉ ext ->
    NotInTelescope name tenv ->
    StringMap.MapsTo var2 (wrap val2) ext ->
    {{ [[`name ->> val1 as _]]::tenv }}
      (Assign name (WrapOpInExpr op (Var name) (Var var2)))
    {{ [[`name ->> (eval_binop op val1 val2) as _]]::tenv }} ∪ {{ ext }} // env.
Proof.
  destruct op; SameValues_Facade_t.
Qed.

Lemma CompileBinopOrTest_right_inPlace_tel:
  forall {av} op vret varg (val1 val2: W) env ext (tenv: Telescope av),
    PreconditionSet tenv ext [[[vret; varg]]] ->
    {{ [[`vret ->> val1 as _]]::[[`varg ->> val2 as _]]::tenv }}
      Assign vret (WrapOpInExpr op (Var vret) (Var varg))
    {{ [[`vret ->> (eval_binop op val1 val2) as _]]::tenv }} ∪ {{ ext }} // env.
Proof.
  repeat hoare.
  move_to_front varg.
  apply CompileDeallocW_discretely; try compile_do_side_conditions.
  apply ProgOk_Chomp_Some; try compile_do_side_conditions.
  intros; apply CompileBinopOrTest_right_inPlace; try compile_do_side_conditions.
Qed.

Lemma CompileBinopOrTest_right_inPlace_tel_generalized:
  forall {av} op vret varg (val1 val2: W) env ext (tenv tenv': Telescope av) pCoda,
    PreconditionSet tenv ext [[[vret; varg]]] ->
    {{ [[`vret ->> (eval_binop op val1 val2) as _]]::[[`varg ->> val2 as _]]::tenv }}
      pCoda
    {{ [[`vret ->> (eval_binop op val1 val2) as _]]::tenv' }} ∪ {{ ext }} // env ->
    {{ [[`vret ->> val1 as _]]::[[`varg ->> val2 as _]]::tenv }}
      (Seq (Assign vret (WrapOpInExpr op (Var vret) (Var varg))) pCoda)
    {{ [[`vret ->> (eval_binop op val1 val2) as _]]::tenv' }} ∪ {{ ext }} // env.
Proof.
  repeat hoare.
  move_to_front varg.
  apply ProgOk_Chomp_Some; try compile_do_side_conditions.
  intros; apply CompileBinopOrTest_right_inPlace; try compile_do_side_conditions.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

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

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export computation_mark.

Lemma computes_to_val_like_iff_hasvalue_like {o} :
  forall lib (t : @NTerm o),
    hasvalue_like lib t <=> {v : NTerm & computes_to_val_like lib t v}.
Proof.
  introv; unfold hasvalue_like, computes_to_val_like, reduces_to, computes_to_val_like_in_max_k_steps;
  split; intro k; exrepnd.
  - exists v k; sp.
  - exists v; sp.
    exists k; sp.
Qed.

Lemma isvalue_like_isvalue {o} :
  forall t : @NTerm o,
    isvalue t -> isvalue_like t.
Proof.
  introv isv.
  inversion isv; subst; eauto with slow.
Qed.
Hint Resolve isvalue_like_isvalue : slow.

Lemma hasvalue_like_if_hasvalue {o} :
  forall lib (t : @NTerm o),
    hasvalue lib t
    -> hasvalue_like lib t.
Proof.
  introv hv.
  unfold hasvalue in hv; exrepnd.
  unfold computes_to_value in hv0; repnd.
  exists t'; dands; eauto with slow.
Qed.
Hint Resolve hasvalue_like_if_hasvalue : slow.

Lemma hasvalue_like_if_raises_exception {o} :
  forall lib (t : @NTerm o),
    raises_exception lib t
    -> hasvalue_like lib t.
Proof.
  introv hv.
  unfold raises_exception in hv; exrepnd.
  unfold computes_to_exception in hv1; repnd.
  eexists; dands; eauto with slow.
Qed.
Hint Resolve hasvalue_like_if_raises_exception : slow.

(*
Lemma reduces_in_atmost_k_steps_implies_marks {p} :
  forall lib (a b : @NTerm p) k,
    reduces_in_atmost_k_steps lib a b k
    -> ismrk lib b
    -> isprogram b
    -> marks lib a.
Proof.
  introv r ism isp.
  apply ismrk_implies in ism; auto; exrepnd; subst.
  exists s.
  unfold computes_to_marker, reduces_to.
  exists k; auto.
Qed.
*)

(*
Lemma marker_in_atmost_k_steps_alpha {p} :
  forall lib (t1 t2 : @NTerm p),
    alpha_eq t1 t2
    -> forall k m,
         computes_to_marker_in_max_k_steps lib t1 m k
         -> computes_to_marker_in_max_k_steps lib t2 m k.
Proof.
  introv Hal.
  introv.
  revert m t1 t2 Hal.
  induction k as [| k Hind]; introv aeq comp;
  allunfold @computes_to_marker_in_max_k_steps; repnd; dands; auto.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    apply alpha_eq_marker in aeq; exrepnd; subst; auto.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    eapply compute_step_alpha in comp0; eauto; exrepnd.
    pose proof (Hind m u t2') as h.
    repeat (autodimp h hyp); repnd; GC.
    eexists; dands; eauto.
Qed.

Theorem compute_to_marker_alpha {p} :
  forall lib (t1 t2 : @NTerm p) m,
    alpha_eq t1 t2
    -> computes_to_marker lib t1 m
    -> computes_to_marker lib t2 m.
Proof.
  introv aeq comp.
  allunfold @computes_to_marker; allunfold @reduces_to; exrepnd.
  pose proof (marker_in_atmost_k_steps_alpha lib t1 t2 aeq k m) as h.
  unfold computes_to_marker_in_max_k_steps in h.
  autodimp h hyp; repnd.
  eexists; dands; eauto.
Qed.
 *)

Lemma reduces_to_if_split2 {p} :
  forall lib (t : @NTerm p) u v,
  compute_step lib t = csuccess u
  -> reduces_to lib u v
  -> reduces_to lib t v.
Proof.
  unfold reduces_to; sp; exists (S k).
  rw @reduces_in_atmost_k_steps_S.
  exists u; sp.
Qed.

Lemma reduces_to_if_split3 {p} :
  forall lib (t : @NTerm p) u v,
  computes_in_1step lib t u
  -> reduces_to lib u v
  -> reduces_to lib t v.
Proof.
  introv c r.
  inversion c; subst; clear c.
  - eapply reduces_to_if_split2; eauto.
  - eapply reduces_to_if_split2; eauto.
Qed.

(*
Lemma computes_in_kstep_alpha_implies_mrk {p} :
  forall lib k (t : @NTerm p) m,
    is_mrk lib m
    -> computes_in_kstep_alpha lib k t (mk_marker m)
    -> computes_to_marker lib t m.
Proof.
  induction k as [ | k Hind]; introv ism Hcka; unfolds_base; dands; auto.
  - invertsn Hcka.
    apply alpha_eq_sym in Hcka; apply alpha_eq_marker in Hcka; exrepnd; subst.
    apply reduces_to_symm.
  - inverts Hcka as HH HHH.
    apply Hind in HHH; auto.
    invertsn HH; repnd.
    apply (compute_to_marker_alpha _ _ x) in HHH; auto.
    allunfold @computes_to_marker; repnd.
    eapply reduces_to_if_split3; eauto.
Qed.

Lemma compute_to_marker_mrk {o} :
  forall (lib : @library o) m,
    is_mrk lib m -> computes_to_marker lib (mk_marker m) m.
Proof.
  introv ism; unfold computes_to_marker; dands; auto.
  exists 0.
  rw @reduces_in_atmost_k_steps_0; auto.
Qed.

Lemma computes_to_marker_alpha {p} :
  forall lib (t1 t2 : @NTerm p) m,
    alpha_eq t1 t2
    -> computes_to_marker lib t1 m
    -> computes_to_marker lib t2 m.
Proof.
  introv aeq comp.
  unfold computes_to_marker, reduces_to in comp; exrepnd.
  unfold computes_to_marker; dands; auto.
  exists k.
  revert dependent t2.
  revert dependent t1.
  induction k; introv r aeq.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    allrw @alpha_eq_marker; subst; auto.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    eapply compute_step_alpha in r1; eauto; exrepnd.
    exists t2'; dands; auto.
    eapply IHk; eauto.
Qed.

Lemma reduces_to_computes_to_marker {p} :
  forall lib a b m,
    @reduces_to p lib a b
    -> computes_to_marker lib b m
    -> computes_to_marker lib a m.
Proof.
  introv redto compex.
  allunfold @computes_to_marker; repnd; dands; auto.
  eapply reduces_to_trans; eauto.
Qed.

Lemma reduces_to_marker_eq {p} :
  forall lib (t u : @NTerm p) m,
    computes_to_marker lib t m
    -> reduces_to lib t u
    -> computes_to_marker lib u m.
Proof.
  unfold computes_to_marker; introv Hcv Hcr; repnd; dands; auto.
  apply @reduces_to_or with (u := u) in Hcv0; auto.
  repndors; tcsp.
  apply reduces_to_marker in Hcv0; auto; subst.
  apply reduces_to_symm.
Qed.

Lemma exception_doesnt_mark {o} :
  forall lib a (e : @NTerm o) m,
    computes_to_marker lib (mk_exception a e) m -> False.
Proof.
  introv comp.
  unfold computes_to_marker, reduces_to in comp; exrepnd.
  induction k.
  - allrw @reduces_in_atmost_k_steps_0; ginv.
  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp1; allsimpl; ginv; sp.
Qed.
*)

Definition mk_vid {p} (v : NVar) : @NTerm p := mk_lam v (mk_var v).

Lemma reduces_in_atmost_k_steps_apply_vid {o} :
  forall lib (t : @NTerm o) v u k,
    isvalue_like u
    -> reduces_in_atmost_k_steps lib (mk_apply (mk_vid v) t) u k
    -> {n : nat
        & k = S n
        # reduces_in_atmost_k_steps lib t u n }.
Proof.
  introv isv r.
  destruct k.

  - rw @reduces_in_atmost_k_steps_0 in r; subst.
    apply isvalue_like_ncan in isv; sp.

  - rw @reduces_in_atmost_k_steps_S in r; exrepnd.
    exists k; dands; auto.
    csunf r1; allsimpl; ginv.
    unfold apply_bterm, lsubst in r0; allsimpl; boolvar; auto.
Qed.

Lemma reduces_in_atmost_k_steps_vbot {o} :
  forall lib v (u : @NTerm o) k,
    isvalue_like u
    -> reduces_in_atmost_k_steps lib (mk_vbot v) u k
    -> False.
Proof.
  introv isv r.
  induction k as [k ind] using comp_ind_type.
  destruct k.

  - rw @reduces_in_atmost_k_steps_0 in r; subst.
    apply isvalue_like_ncan in isv; sp.

  - rw @reduces_in_atmost_k_steps_S in r; exrepnd.
    csunf r1; simpl in r1; ginv; auto; fold_terms.
    destruct k.

    + rw @reduces_in_atmost_k_steps_0 in r0; subst.
      apply isvalue_like_ncan in isv; sp.

    + apply reduces_in_atmost_k_steps_apply_vid in r0; exrepnd; ginv; auto.
      apply ind in r1; auto.
Qed.

Lemma reduces_to_vbot_if_isvalue_like {o} :
  forall lib v (u : @NTerm o),
    isvalue_like u
    -> reduces_to lib (mk_vbot v) u
    -> False.
Proof.
  introv isv r.
  unfold reduces_to in r; exrepnd.
  apply reduces_in_atmost_k_steps_vbot in r0; sp.
Qed.


From stdpp Require Import base numbers.

(*
The spec of a "differentail" equation

Defining what differentiation means is difficilt.

We're better off with difference equations

This is a matter of spec choice. If your spec TRULY requires a differential equation rather than a difference equation of dt = 10^-100000000, I am very suspicious that you are in a physically relevant regime of that differential equation.

Differential equations are only used in physics and engineering so far as they are usefl. They compactly describe systems and have occasional useful closed form solutions. Other times they are discretized in some manner for numerical simulation.

If the differential equation is not numerically simulatable, then it is highly suspicious.

For the purspoes of usage inside a system like Coq, the differential equation is no longer convenenitn. To explcility state what differentiation means makes things very difficult.

A mathemticaitica may be interested in a differential equaiton for it's own sake

Ok

I really want somewhat autmated lia/lra.
But

Q can be basically fixed point arithmetic. If the denominator is static and the numerator is dynamic.

I'd have to overload all the operations.
And then I'd use lia to discharge facts.
Maybe sometimes one could use lra too.

Record Qa := {  nominal : Q; err : nat }.

I feel like we kind of want err to be a Qa also...?

Maybe err is with resepct to the same system of denominatrs. That makes sense.

Qa.plus (x y)

It would be kind of nice for a good denominator to be inferred.

The error term would then also be static.

We'd also probably want to be able to bound

This seems fun. MetaOcaml for fixed poit

The point of Qc is
1. keep the numbers from getting out of control
2. Being able to use actual equality

1. Could build a correspondence system of some kinf/ reflection between Q and Qc.
2.
3.

The analog in Z3 might be to use an Int64 symbol with a python int as a denominator

The python in lives at the meta level and can be lifted to z3 level but not vice versa.

Yeah, If you make x dynamic and err static, then err is related to uniform continuity, unifrom error bounds.

 *)

(*
Definition example (x : bool) : nat := 4 + (if x then 2 else 3).
Definition example_cps (b : Type) (x : bool) (k : nat -> b) : b :=
  let k' := fun n => k (4 + n) in                                                         if x then k' 2 else k' 3.

Eval cbv in example.
  (*   = λ x : bool, S (S (S (S (if x then 2 else 3))))
     : bool → nat *)

Eval cbv in example_cps.
*)

(*
     = λ (b : Type) (x : bool) (k : nat → b), if x then k 6 else k 7
     : ∀ b : Type, bool → (nat → b) → b
*)

(*
Inductive my_gadt (o : Type) : Type :=
  | myint : nat -> my_gadt nat
  | mybool : bool -> my_gadt bool.

Definition thing {a} (x : my_gadt a) :=
  match x in my_gadt a  return (a -> a) -> a with
  | myint x => fun f => f x
  | mybool x => fun f => f x
  end.

Definition thing {a} (x : my_gadt a) (f : a -> a) : a:=
  match x in my_gadt b return nat with
  | myint x => f (x + 1)
  | mybool x => f (negb x)
  end.
*)
Require Import QArith.
Require Import QArith.Qcanon.
Search Qc.
Print Scope Q_scope.

(*Print Scope Qc_scope.*)
Check Q2Qc.

Require Import Ascii.
Print ascii.

Require Import ZArith.

Open Scope Z_scope.

Goal forall x, x < x + 1. lia. Qed.

Compute 1 / 2.
Compute 2/2.

(* Goal forall x, 2 * (x / 2) <= x. Aborted. *)
Print Scope Q_scope.
Print Qle.
Goal forall (x y : Z) (z : positive),  (x <= y) -> ((x # z) <= (y # z))%Q. intros.  unfold Qle. simpl. nia. Qed.
Search "div".
Compute -8 / 4.
Search Z.div.
Print Hint *.
Goal forall n m c, n > 0 -> m <= c * n ->  (m / n) <= c. intros.  Search ((_ / _) <= _). apply Z.div_le_upper_bound. lia. lia. Qed.

Search (positive -> Z).
Definition approx ( x : Q) (d : positive) : Q := ((x.(Qnum) * (Zpos d)) / Zpos (x.(Qden))) # d.
| _ =>
Compute approx (1 # 4) 8.
Compute approx (1 # 4) 13.
Search Z.div.

Lemma div_lemma : forall x y z, y > 0 -> z * y <= x + y ->  z  <= 1 + x / y. intros. pose Z.mul_div_le.

Lemma appox_lemma : forall x d, (x - (1 # d)  <= (approx x d) <= x )%Q.
Proof.
  intros. split. Focus 2.
  unfold approx. unfold Qle. simpl. Search Z.div.  Search ( _ * _  = _ * _ ). rewrite ( Z.mul_comm _ (Z.pos (Qden x))).

Require Import Psatz.
  Search ( _ * (_ / _) ).  apply Z.mul_div_le. Search (0 < Zpos _). auto with zarith.
  Search Qle. assert ( forall x y z, x <= z + y  ->  x - y <= z)%Q. intros. lra. apply H. unfold Qle. unfold approx. simpl . clear H.  assert ((((Qnum x) * Z.pos d) `div` Z.pos (Qden x)) * Z.pos (Qden x) <= ((Qnum x) * Z.pos d)). Search Z.div.

   Check Z.div_le_lower_bound. pose (Z.div_le_lower_bound  (x.(Qnum) * (Zpos d))  (Zpos (x.(Qden)))      . unfold Qle. unfold Qge. split. simpl.

Compute (div 1 2).

forall x,

Open Scope Q_scope.
Print Q.
Locate positive.

Require Import Ring.
Print Scope positive_scope.
(*  If you need more than 1/ 2^128 sized dt, what are you even doing?   *)
Print Module QArith.
Definition dt_spec := Eval cbv in Qinv (Qmake (Z.shiftl 1 128) 1).
Print dt_spec.
(* Definition dt_spec : Q := ( 1  # 100 ). *)
Print dt_spec.
(* The differnetial equations xdot = x *)
Definition next_spec (x : Q) := (1 + dt_spec) * x.
Definition step2 (x : Q) : Q := next_spec (next_spec x).
Search (Q -> Q).
Definition approx (x : Q) : Q :=  (Pos.shiftl 1 128) * x

Definition step2' (x : Q) : {z : Q|  exists e, 0 <= e /\  z <= (step2 x) + e /\ (step2 x) - e  <= z }.  {| Qnum :=  _  ; Qden := (Pos.shiftl 1 128) |}.
Compute next_spec 1.
Eval cbn in  fun x => next_spec (next_spec x).

Check  {x : Q | x.(Qden) = 100%positive}.

Definition Fixed n := {x : Q | x.(QDen) = n}.

Definition approx_add (x y : Fixed 100) : {z : Fixed 100 | exists e,
                                                           x + y == z * (1 + e)}.

Definition approx_add (x y : Q) (p : x.(Qden) = 100%positive): {z : Q | exists e, x + y == z * (1 + e) (* /\ z.(Qden) = 100%positive *) }. eexists. exists 0. cbn. ring_simplify. auto. unfold "==". auto. Qed.

Definition approx_add x y : {z : Q | exists e, x + y == z * (1 + e) }.

Print Z.
Print Q.

Search (Z -> _ -> Z).
Eval cbv in Z.shiftl 1 8.
Definition dt_spec := Eval cbv in Qinv (Qmake (Z.shiftl 1 8) 1).
Print dt_spec.
Definition dt_spec : Q := ( 1  # 100 ).

Print Q.
Require Import Ascii.

let branch t = if t = 'a' then 'a'
                else if t = 'b' then 'b'
                else if t = 'c' then b
                else failwith "unexpected token"
let fast_branch = if ('a' <= t  && t <= 'c' the return t else failwith "unexpected token"

(* The differnetial equations xdot = x *)
Definition next_spec (x : Q) := x + x * dt_spec.

(* This is the recursion principle for nat *)
Fixpoint iterate {a} (n : nat) (f : a -> a) (x0 : a) :=
  match n with
  | O => x0
  | S n' => iterate n' f (f x0)
  end.

Eval vm_compute in iterate 9 next_spec 1. (* getting slow around 10
    The exponential is doubling with every op. *)

Close Scope Q_scope.

Definition dt_spec : Q := ( 1  # 100 ).

Print Q.

(* The differnetial equations xdot = x *)
Definition next_spec (x : Q) := x + x * dt_spec.

(* This is the recursion principle for nat *)
Fixpoint iterate {a} (n : nat) (f : a -> a) (x0 : a) :=
  match n with
  | O => x0
  | S n' => iterate n' f (f x0)
  end.

Eval vm_compute in iterate 9 next_spec 1. (* getting slow around 10
    The exponential is doubling with every op. *)

Close Scope Q_scope.
Open Scope Qc_scope.

Definition dt_spec : Qc := Q2Qc ( 1  # 100 ).

(* The differnetial equations xdot = x *)
Definition next_spec (x : Qc) := x + x * dt_spec.

(* This is the recursion principle for nat *)
Fixpoint iterate {a} (n : nat) (f : a -> a) (x0 : a) :=
  match n with
  | O => x0
  | S n' => iterate n' f (f x0)
  end.

Search (nat -> (_ -> _) -> _).
Search (Q -> Q).

Eval vm_compute in decide (0 <= dt_spec).
Eval vm_compute in decide (0 = dt_spec).

Require  Import Psatz.

Goal (0 <= 1)%Q. lra. Qed.
Goal (0 <= 1). fourier.  Abort. (* lra doesn't work on Qc? That super sucks. *)

Definition myabs x := if decide (0 <= x) then x else - x.
Search Qc.

Goal forall x, (myabs (myabs x)) = x. intros. unfold myabs. destruct (decide (0 <= x)). destruct (decide (0 <= x)). auto. apply n in q. destruct q. destruct (decide (0 <= -x)). Search (- _ <= - _).  apply Qcopp_le_compat in q. Search (- 0). Search (- - _). rewrite Qcopp_involutive in q.

(*

Approximate by epsilon
Qabs

*)

(* If we parametrize over dt, we are in some ense allowing the differential limit

*)

                                 p_count_as_opt =
(λ (st : () * ()) (input : stream (ocaml_stream ascii) ascii),
   let
   '(_, m_st', st') :=
    ocaml_peek (ascii * () * ocaml_stream ascii) (let (state, _, _, _) := input in state)
      (λ ot : option ascii,
         match ot with
         | Some t =>
             if ocaml_eq t "a"%char
             then
              ocaml_drop (ascii * () * ocaml_stream ascii) (let (state, _, _, _) := input in state)
                (λ state_str : ocaml_stream ascii, ("a"%char, let (x, _) := st in x, state_str))
             else failwith "parse_exact: Unexpected Token!"
         | None => failwith "Unexpected EOF!"
         end) in
    (fix
     rec_v (n : nat) (H : Type) (k' : nat → () → option as_tok * () * ocaml_stream ascii → H)
           (m_st : ()) (stream_st : option as_tok * () * ocaml_stream ascii) {struct n} : H :=
       match n with
       | 0 => failwith "out of gas!"
       | S m =>
           match stream_st with
           | (Some t, _, _) =>
               if ocaml_eq t A
               then
                let
                '(_, m_st'0, st'0) :=
                 let
                 '(_, m_st0, str') := stream_st in
                  ocaml_peek (as_tok * () * (option as_tok * () * ocaml_stream ascii)) str'
                    (λ ot : option ascii,
                       match ot with
                       | Some _ =>
                           let
                           '(_, m_st'0, st'0) :=
                            ocaml_peek (ascii * () * ocaml_stream ascii) st'
                              (λ ot0 : option ascii,
                                 match ot0 with
                                 | Some t1 =>
                                     if ocaml_eq t1 "a"%char
                                     then
                                      ocaml_drop (ascii * () * ocaml_stream ascii) st'
                                        (λ state_str : ocaml_stream ascii,
                                           ("a"%char, m_st0, state_str))
                                     else failwith "parse_exact: Unexpected Token!"
                                 | None => failwith "Unexpected EOF!"
                                 end) in (A, m_st, (Some A, m_st'0, st'0))
                       | None => (A, m_st, (None, m_st0, str'))
                       end) in
                 let
                 '(o2, m_st'1, st'1) :=
                  rec_v m (nat * () * (option as_tok * () * ocaml_stream ascii))%type
                    (λ (o2 : nat) (m_st'1 : ()) (st'1 : option as_tok * () * ocaml_stream ascii),
                       (o2, m_st'1, st'1)) m_st'0 st'0 in k' (S o2) m_st'1 st'1
               else k' 0 m_st stream_st
           | (None, _, _) => k' 0 m_st stream_st
           end
       end) max_int nat (λ (o0 : nat) (_ : ()) (_ : option as_tok * () * ocaml_stream ascii), o0)
      (let (_, y) := st in y) (Some A, m_st', st'))


Require Import Crypto.Compilers.Named.PositiveContext.
Require Import Crypto.Compilers.Named.InterpretToPHOASWf.
Require Import Crypto.Compilers.Named.CompileWf.
Require Import Crypto.Compilers.Named.WfFromUnit.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.RewriteAddToAdc.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Bool.

Section language.
  Local Hint Resolve internal_base_type_dec_lb internal_base_type_dec_lb dec_rel_of_bool_dec_rel : typeclass_instances.

  Lemma Wf_RewriteAdc {t} (e : Expr t) (Hwf : Wf e)
  : Wf (RewriteAdc e).
  Proof.
    unfold RewriteAdc, option_map; break_innermost_match;
      [ .. | solve [ intros var1 var2; destruct (Hwf var1 var2); auto with wf ] ];
      repeat first [ eapply @Wf_InterpToPHOAS with (t:=Arrow _ _)
                   | progress split_andb
                   | congruence
                   | intros;
                     match goal with
                     | [ |- ContextDefinitions.ContextOk _ ]
                       => eapply @PositiveContextOk
                     end
                   | solve [ auto | eapply @BinPos.Pos.eqb_eq ]
                   | eapply @Wf_from_unit
                   | eapply @dec_rel_of_bool_dec_rel
                   | eapply @internal_base_type_dec_lb
                   | eapply @internal_base_type_dec_bl
                   | intros var1 var2; specialize (Hwf var1 var2); destruct Hwf;
                     constructor; assumption ].
  Qed.
End language.

Hint Resolve Wf_RewriteAdc : wf.