From iris.algebra Require Import auth list.
From iris.program_logic Require Import adequacy ectxi_language.
From iris_examples.logrel.F_mu_ref_conc.binary Require Import soundness.
From iris_examples.logrel.F_mu_ref_conc.binary.examples Require Import lock.
From iris_examples.logrel.F_mu_ref_conc.binary.examples.stack Require Import
  CG_stack FG_stack stack_rules.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

Definition stackN : namespace := nroot .@ "stack".

Section Stack_refinement.
  Context `{heapIG Σ, cfgSG Σ}.
  Notation D := (persistent_predO (val * val) (iPropI Σ)).
  Implicit Types Δ : listO D.

  Lemma FG_CG_counter_refinement :
    ⊢ [] ⊨ FG_stack ≤log≤ CG_stack : TForall (TProd (TProd
           (TArrow (TVar 0) TUnit)
           (TArrow TUnit (TSum TUnit (TVar 0))))
           (TArrow (TArrow (TVar 0) TUnit) TUnit)).
  Proof.
    (* executing the preambles *)
    iIntros (Δ [|??]) "!# #[Hspec HΓ]"; iIntros (j K) "Hj"; last first.
    { iDestruct (interp_env_length with "HΓ") as %[=]. }
    iClear "HΓ". cbn -[FG_stack CG_stack].
    rewrite ?empty_env_subst /CG_stack /FG_stack.
    iApply wp_value; eauto.
    iExists (TLamV _); iFrame "Hj".
    clear j K. iModIntro. iIntros (τi j K) "Hj /=".
    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
    iApply wp_pure_step_later; auto. iNext.
    iMod (steps_newlock _ j (LetInCtx _ :: K) with "[$Hj]")
      as (l) "[Hj Hl]"; eauto.
    iMod (do_step_pure _ j K with "[$Hj]") as "Hj"; eauto.
    simpl. iAsimpl.
    iMod (step_alloc  _ j (LetInCtx _ :: K) with "[$Hj]")
      as (stk') "[Hj Hstk']"; eauto.
    simpl.
    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
    iAsimpl.
    iApply (wp_bind (fill [AllocCtx; AppRCtx (RecV _)]));
      iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
    iApply wp_alloc; first done. iNext; iIntros (istk) "Histk".
    iApply (wp_bind (fill [AppRCtx (RecV _)]));
      iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
    iApply wp_alloc; first done. iNext; iIntros (stk) "Hstk".
    simpl. iApply wp_pure_step_later; trivial. iNext. simpl.
    iAsimpl.
    iMod (mapsto_persist with "Histk") as "#Histk".
    (* establishing the invariant *)
    iAssert (StackLink τi (LocV istk, FoldV (InjLV UnitV))) with "[]" as "HLK".
    { rewrite StackLink_unfold.
      iExists _, _. iSplitR; simpl; trivial.
      iFrame "Histk". iLeft. iSplit; trivial. }
    iAssert ((∃ istk v, stk' ↦ₛ v
                      ∗ stk ↦ᵢ (LocV istk)
                      ∗ StackLink τi (LocV istk, v)
                      ∗ l ↦ₛ (#♭v false)
             )%I) with "[Hstk Hstk' HLK Hl]" as "Hinv".
    { iExists _, _. by iFrame "Hstk' Hstk Hl HLK". }
    iMod (inv_alloc stackN with "[Hinv]") as "#Hinv"; [iNext; iExact "Hinv"|].
    iClear (istk) "Histk HLK".
    (* splitting *)
    iApply wp_value; simpl; trivial.
    iExists (PairV (PairV (CG_locked_pushV _ _) (CG_locked_popV _ _)) (LamV _)).
    simpl. iAsimpl.
    rewrite CG_locked_push_of_val CG_locked_pop_of_val.
    Local Transparent CG_snap_iter. (* HACK *)
    iFrame "Hj".
    iExists (_, _), (_, _); iSplit; eauto.
    iSplit.
    (* refinement of push and pop *)
    - iExists (_, _), (_, _); iSplit; eauto. iSplit.
      + (* refinement of push *)
        iModIntro. clear j K. iIntros ( [v1 v2] ) "#Hrel". iIntros (j K) "Hj /=".
        rewrite -(FG_push_folding (Loc stk)).
        iLöb as "Hlat".
        rewrite {2}(FG_push_folding (Loc stk)).
        iApply wp_pure_step_later; auto using to_of_val.
        iNext.
        rewrite -(FG_push_folding (Loc stk)).
        iAsimpl.
        iApply (wp_bind (fill [LetInCtx _]));
          iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
        iInv stackN as (istk v) "[Hstk' [Hstk [HLK Hl]]]" "Hclose".
        iApply (wp_load with "Hstk"). iNext. iIntros "Hstk".
        iMod ("Hclose" with "[Hstk' HLK Hl Hstk]") as "_".
        { iNext. iExists _, _; by iFrame "Hstk' HLK Hl Hstk". }
        clear v.
        iApply wp_pure_step_later; auto using to_of_val.
        iModIntro. iNext. iAsimpl.
        iApply (wp_bind (fill [CasRCtx (LocV _) (LocV _); IfCtx _ _]));
          iApply wp_wand_l; iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
        iApply wp_alloc; simpl; trivial.
        iNext. iIntros (ltmp) "Hltmp".
        iApply (wp_bind (fill [IfCtx _ _]));
          iApply wp_wand_l; iSplitR; [iIntros (w) "H"; iExact "H"|].
        iInv stackN as (istk2 v) "[Hstk' [Hstk [HLK Hl]]]" "Hclose".
        (* deciding whether CAS will succeed or fail *)
        destruct (decide (istk = istk2)) as [|Hneq]; subst.
        * (* CAS succeeds *)
          (* In this case, the specification pushes *)
          iMod "Hstk'". iMod "Hl".
          iMod (steps_CG_locked_push _ j K with "[Hj Hl Hstk']")
            as "[Hj [Hstk' Hl]]"; first solve_ndisj.
          { rewrite CG_locked_push_of_val. by iFrame "Hspec Hstk' Hj". }
          iApply (wp_cas_suc with "Hstk"); auto.
          iNext. iIntros "Hstk".
          iMod (mapsto_persist with "Hltmp") as "#Hltmp".
          iMod ("Hclose" with "[-Hj]") as "_".
          { iNext. iExists ltmp, _.
            iFrame "Hstk' Hstk Hl".
            do 2 rewrite StackLink_unfold.
            rewrite -StackLink_unfold.
            iExists _, _. iSplit; trivial.
            iFrame "Hltmp". eauto 10. }
          iModIntro.
          iApply wp_pure_step_later; auto. iNext; iApply wp_value; trivial.
          iExists UnitV; eauto.
        * iApply (wp_cas_fail with "Hstk"); auto; first congruence.
          iNext. iIntros "Hstk". iMod ("Hclose" with "[-Hj]").
          { iNext. iExists _, _. by iFrame "Hstk' Hstk Hl". }
          iApply wp_pure_step_later; auto. iModIntro. iNext. by iApply "Hlat".
      + (* refinement of pop *)
        iModIntro. clear j K. iIntros ( [v1 v2] ) "[% %]".
        iIntros (j K) "Hj /="; simplify_eq/=.
        rewrite -(FG_pop_folding (Loc stk)).
        iLöb as "Hlat".
        rewrite {2}(FG_pop_folding (Loc stk)).
        iApply wp_pure_step_later; auto. iNext.
        rewrite -(FG_pop_folding (Loc stk)).
        iAsimpl.
        iApply (wp_bind (fill [LetInCtx _]));
          iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
        iInv stackN as (istk v) "[Hstk' [Hstk [#HLK Hl]]]" "Hclose".
        iApply (wp_load with "Hstk"). iNext. iIntros "Hstk".
        iPoseProof "HLK" as "HLK'".
        (* Checking whether the stack is empty *)
        rewrite {2}StackLink_unfold.
        iDestruct "HLK'" as (istk2 w) "[% [Hmpt [[% %]|HLK']]]"; simplify_eq/=.
        * (* The stack is empty *)
          rewrite CG_locked_pop_of_val.
          iMod (steps_CG_locked_pop_fail with "[$Hspec $Hstk' $Hl $Hj]")
             as "[Hj [Hstk' Hl]]"; first solve_ndisj.
          iMod ("Hclose" with "[-Hj Hmpt]") as "_".
          { iNext. iExists _, _. by iFrame "Hstk' Hstk Hl". }
          iModIntro.
          iApply wp_pure_step_later; auto. iNext. iAsimpl.
          iApply (wp_bind (fill [LetInCtx _]));
            iApply wp_wand_l; iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
          iClear "HLK".
          iInv stackN as (istk3 w) "[Hstk' [Hstk [HLK Hl]]]" "Hclose".
          iApply (wp_load with "Hmpt").
          iNext. iIntros "_". iMod ("Hclose" with "[-Hj]") as "_".
          { iNext. iExists _, _. iFrame "Hstk' Hstk HLK Hl". }
          iApply wp_pure_step_later; simpl; trivial.
          iModIntro. iNext. iAsimpl.
          iApply wp_pure_step_later; trivial.
          iNext. iApply wp_value; simpl; trivial. iExists (InjLV UnitV).
          iSplit; trivial. iLeft. iExists (_, _); repeat iSplit; simpl; trivial.
        * (* The stack is not empty *)
          iMod ("Hclose" with "[-Hj Hmpt HLK']") as "_".
          { iNext. iExists _, _. by iFrame "Hstk' Hstk HLK Hl". }
          iModIntro. iApply wp_pure_step_later; auto.
          iNext. iAsimpl.
          iApply (wp_bind (fill [LetInCtx _]));
            iApply wp_wand_l; iSplitR; [iIntros (w') "Hw"; iExact "Hw"|].
          iClear "HLK".
          iInv stackN as (istk3 w') "[Hstk' [Hstk [HLK Hl]]]" "Hclose".
          iApply (wp_load with "Hmpt"). iNext; iIntros "_".
          iMod ("Hclose" with "[-Hj Hmpt HLK']") as "_".
          { iNext. iExists _, _. by iFrame "Hstk' Hstk HLK Hl". }
          iApply wp_pure_step_later; auto.
          iModIntro. iNext. iAsimpl.
          iDestruct "HLK'" as (y1 z1 y2 z2) "[% HLK']". subst. simpl.
          iApply wp_pure_step_later; first done.
          iNext. iAsimpl.
          iApply (wp_bind (fill [UnfoldCtx; CasRCtx (LocV _) (LocV _); IfCtx _ _]));
            iApply wp_wand_l; iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
          iAsimpl. iApply wp_pure_step_later; auto.
          simpl. iNext. iApply wp_value.
          iApply (wp_bind (fill [CasRCtx (LocV _) (LocV _); IfCtx _ _]));
            iApply wp_wand_l; iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
          iAsimpl. iApply wp_pure_step_later; auto.
          simpl. iNext. iApply wp_value.
          iApply (wp_bind (fill [IfCtx _ _]));
            iApply wp_wand_l; iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
          clear istk3. iAsimpl.
          iInv stackN as (istk3 w) "[Hstk' [Hstk [#HLK Hl]]]" "Hclose".
          (* deciding whether CAS will succeed or fail *)
          destruct (decide (istk2 = istk3)) as [|Hneq]; subst.
          -- (* CAS succeeds *)
            (* In this case, the specification pushes *)
            iApply (wp_cas_suc with "Hstk"); simpl; auto.
            iNext. iIntros "Hstk {HLK'}". iPoseProof "HLK" as "HLK'".
            rewrite {2}StackLink_unfold.
            iDestruct "HLK'" as (istk4 w2) "[% [Hmpt' HLK']]"; simplify_eq/=.
            iDestruct (mapsto_agree with "Hmpt Hmpt'") as %<-.
            iDestruct "HLK'" as "[[% %]|HLK']"; simplify_eq/=.
            iDestruct "HLK'" as (yn1 yn2 zn1 zn2)
                                   "[% [% [#Hrel HLK'']]]"; simplify_eq/=.
             (* Now we have proven that specification can also pop. *)
             rewrite CG_locked_pop_of_val.
             iMod (steps_CG_locked_pop_suc with "[$Hspec $Hstk' $Hl $Hj]")
                as "[Hj [Hstk' Hl]]"; first solve_ndisj.
             iMod ("Hclose" with "[-Hj]") as "_".
             { iNext. iIntros "{Hmpt Hmpt' HLK}". rewrite StackLink_unfold.
               iDestruct "HLK''" as (istk5 w2) "[% [Hmpt HLK]]"; simplify_eq/=.
               iExists istk5, _. iFrame "Hstk' Hstk Hl".
               rewrite StackLink_unfold.
               iExists _, _; iSplitR; trivial.
               by iFrame "HLK". }
             iApply wp_pure_step_later; auto. iModIntro. iNext.
             iApply (wp_bind (fill [InjRCtx])); iApply wp_wand_l;
               iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
             iApply wp_pure_step_later; auto. iApply wp_value.
             iNext. iApply wp_value; simpl.
             iExists (InjRV _); iFrame "Hj".
             iRight. iExists (_, _). iSplit; trivial.
          -- (* CAS will fail *)
            iApply (wp_cas_fail with "Hstk"); [rewrite /= ?to_of_val //; congruence..|].
            iNext. iIntros "Hstk". iMod ("Hclose" with "[-Hj]") as "_".
            { iNext. iExists _, _. by iFrame "Hstk' Hstk HLK Hl". }
            iApply wp_pure_step_later; auto. iModIntro. iNext. by iApply "Hlat".
    - (* refinement of iter *)
      iModIntro. clear j K. iIntros ( [f1 f2] ) "/= #Hfs". iIntros (j K) "Hj".
      iApply wp_pure_step_later; auto using to_of_val. iNext.
      iMod (do_step_pure with "[$Hspec $Hj]") as "Hj"; eauto.
      iAsimpl.
      replace (FG_iter (of_val f1)) with (of_val (FG_iterV (of_val f1)))
        by (by rewrite FG_iter_of_val).
      replace (CG_iter (of_val f2)) with (of_val (CG_iterV (of_val f2)))
        by (by rewrite CG_iter_of_val).
      iApply (wp_bind (fill [FoldCtx; AppRCtx _])); iApply wp_wand_l;
        iSplitR; [iIntros (w) "Hw"; iExact "Hw"|].
      iInv stackN as (istk3 w) "[>Hstk' [>Hstk [#HLK >Hl]]]" "Hclose".
      iMod (steps_CG_snap _ _ (AppRCtx _ :: K)
            with "[Hstk' Hj Hl]") as "[Hj [Hstk' Hl]]"; first solve_ndisj.
      { rewrite ?fill_app. simpl. by iFrame "Hspec Hstk' Hl Hj". }
      iApply (wp_load with "[$Hstk]"). iNext. iIntros "Hstk".
      iMod ("Hclose" with "[-Hj]") as "_".
      { iNext. iExists _, _; by iFrame "Hstk' Hstk HLK Hl". }
      iModIntro.
      rewrite ?fill_app /= -FG_iter_folding.
      iLöb as "Hlat" forall (istk3 w) "HLK".
      rewrite {2}FG_iter_folding.
      iApply wp_pure_step_later; simpl; trivial.
      rewrite -FG_iter_folding. iAsimpl.
      iNext.
      iApply (wp_bind (fill [LoadCtx; CaseCtx _ _])); iApply wp_wand_l;
        iSplitR; [iIntros (v) "Hw"; iExact "Hw"|].
      iApply wp_pure_step_later; trivial. iApply wp_value. iNext.
      iApply (wp_bind (fill [CaseCtx _ _])); iApply wp_wand_l;
        iSplitR; [iIntros (v) "Hw"; iExact "Hw"|].
      rewrite StackLink_unfold.
      iDestruct "HLK" as (istk4 v) "[% [Hmpt HLK]]"; simplify_eq/=.
      iInv stackN as (istk5 v') "[Hstk' [Hstk [HLK' Hl]]]" "Hclose".
      iApply (wp_load with "Hmpt"). iNext. iIntros "_".
      iDestruct "HLK" as "[[% %]|HLK'']"; simplify_eq/=.
      * rewrite CG_iter_of_val.
        iMod (steps_CG_iter_end with "[$Hspec $Hj]") as "Hj"; first solve_ndisj.
        iMod ("Hclose" with "[-Hj]").
        { iNext. iExists _, _. by iFrame "Hstk' Hstk Hl". }
        iApply wp_pure_step_later; trivial.
        iModIntro. iNext. iApply wp_value; trivial. iExists UnitV; eauto.
      * iDestruct "HLK''" as (yn1 yn2 zn1 zn2)
                              "[% [% [#Hrel HLK'']]]"; simplify_eq/=.
        rewrite CG_iter_of_val.
        iMod (steps_CG_iter with "[$Hspec $Hj]") as "Hj"; first solve_ndisj.
        iMod ("Hclose" with "[-Hj HLK'']") as "_".
        { iNext. iExists _, _. by iFrame "Hstk' Hstk Hl". }
        simpl.
        iApply wp_pure_step_later; simpl; rewrite ?to_of_val; trivial.
        iAsimpl.
        iModIntro. iNext.
        iApply (wp_bind (fill [AppRCtx _; SeqCtx _]));
          iApply wp_wand_l; iSplitR; [iIntros (w') "Hw"; iExact "Hw"|].
        iApply wp_pure_step_later; simpl; rewrite ?to_of_val; trivial. iNext.
        iApply wp_value.
        iApply (wp_bind (fill [SeqCtx _]));
          iApply wp_wand_l; iSplitR; [iIntros (w') "Hw"; iExact "Hw"|].
        rewrite StackLink_unfold.
        iDestruct "HLK''" as (istk6 w') "[% HLK]"; simplify_eq/=.
        iSpecialize ("Hfs" $! (yn1, zn1) with "Hrel").
        iSpecialize ("Hfs" $! _ (SeqCtx _ :: K)).
        iApply wp_wand_l; iSplitR "Hj"; [|iApply "Hfs"; by iFrame "#"].
        iIntros (u) "/="; iDestruct 1 as (z) "[Hj [% %]]".
        simpl. subst. iAsimpl.
        iMod (do_step_pure with "[$Hspec $Hj]") as "Hj"; [done..|].
        iAsimpl.
        replace (CG_iter (of_val f2)) with (of_val (CG_iterV (of_val f2)))
          by (by rewrite CG_iter_of_val).
        iMod (step_snd _ _ (AppRCtx _ :: K) with "[$Hspec Hj]") as "Hj";
          [| | |simpl; by iFrame "Hj"|]; rewrite ?to_of_val; auto.
        iApply wp_pure_step_later; trivial.
        iNext. simpl.
        replace (FG_iter (of_val f1)) with (of_val (FG_iterV (of_val f1)))
          by (by rewrite FG_iter_of_val).
        iApply (wp_bind (fill [AppRCtx _]));
          iApply wp_wand_l; iSplitR; [iIntros (w'') "Hw"; iExact "Hw"|].
        iApply wp_pure_step_later; auto using to_of_val.
        simpl. iNext. rewrite -FG_iter_folding. iApply wp_value.
        iApply ("Hlat" $! istk6 zn2 with "[Hj] [HLK]"); trivial.
        rewrite StackLink_unfold; iModIntro; simpl.
        iDestruct "HLK" as "[Histk6 [HLK|HLK]]";
          iExists istk6, w'; iSplit; auto; iFrame "#".
        iRight. iDestruct "HLK" as (? ? ? ?) "(?&?&?&?)".
        iExists _, _, _, _; iFrame "#".
  Qed.
End Stack_refinement.

Theorem stack_ctx_refinement :
  [] ⊨ FG_stack ≤ctx≤ CG_stack : TForall (TProd (TProd
        (TArrow (TVar 0) TUnit)
        (TArrow TUnit (TSum TUnit (TVar 0))))
        (TArrow (TArrow (TVar 0) TUnit) TUnit)).
Proof.
  set (Σ := #[invΣ; gen_heapΣ loc val; soundness_binaryΣ]).
  set (HG := soundness.HeapPreIG Σ _ _).
  eapply (binary_soundness Σ); eauto using FG_stack_type, CG_stack_type.
  intros; apply FG_CG_counter_refinement.
Qed.


Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Setoids.Setoid
        Coq.Arith.PeanoNat
        Coq.omega.Omega
        Coq.setoid_ring.Ring
        Coq.setoid_ring.Ring_theory
        Matrix
        SparseMatrix
        DenseMatrix
        FiatHelpers
        MyHelpers
        MatrixLemmas
        optimize_ADT.

(* These operations need to be implemented. *)
(* log of the determinant of a matrix *)
Axiom logdet : forall {ME: MatrixElem} {n}, SDM n -> MEt.
(* log of 2*pi *)
Axiom log_two_pi : forall {ME: MatrixElem}, MEt.

Add Parametric Morphism ME n: (@logdet ME n)
    with signature (Meq (n:=n) (m:=n)) ==> (eq) as logdet_mor.
Admitted.

Definition Mplus {ME : MatrixElem} {M : Matrix} {m n : nat} :
  @Mt ME M m n -> @Mt ME M m n -> @Mt ME M m n := Melementwise_op MEplus.
Infix "@+" := Mplus.

Global Add Parametric Morphism {ME : MatrixElem} {M : Matrix} m n: (Mplus ) with
      signature (Meq (m:=m)(n:=n)) ==> (Meq (m:=m)(n:=n)) ==> (Meq (m:=m)(n:=n)) as Mplus_mor.
Admitted.

Section KalmanFilter.
  Variable m n : nat.
  Context {ME : MatrixElem}.

  Fixpoint nat_to_MEt (n : nat) : MEt :=
  match n with
  | 0 => e0
  | S n' => e1 +e nat_to_MEt n'
  end.

  Record KalmanState :=
    { x : Vt n;
      P : SDM n}.

  Definition KalmanSig : ADTSig :=
    ADTsignature {
      Constructor "Init" : KalmanState -> rep,
      Method "Predict"   : rep * (SDM n) * (SDM n) * (SDM n) * (Vt n) -> rep * KalmanState,
      Method "Update"    : rep * (SDM n) * (SDM n) * (Vt n) -> rep * MEt
    }.

  Definition KalmanSpec : ADT KalmanSig :=
    Def ADT {
      rep := KalmanState,

      Def Constructor1 "Init" (init_state: KalmanState): rep := ret init_state,,

      Def Method4 "Predict" (r : rep) (F: SDM n) (B: SDM n) (Q: SDM n) (u: Vt n) : rep * KalmanState :=
        x' <<- F &* r.(x) &+ B &* u;
        p' <<- F @* r.(P) @* (transpose F) @+ Q;
        xx <- {X | X @= x'};
        pp <- {P | P @= p'};
        ret (r, {|x := xx; P := pp|}),

      Def Method3 "Update" (r : rep) (H: Mt (Matrix := DenseMatrix) m n) (R: SDM n) (z: Vt m) : rep * MEt :=
        y' <<- z &- H @* r.(x);
        S' <<- H @* r.(P) @* transpose(H) @+ R;
        K' <<- r.(P) @* transpose(H) @* inversion(S');
        x' <<- r.(x) &+ K' @* y';
        p' <<- (Id @- K' @* H) @* r.(P);
        (*garbage <<- K' @* K' @+ S';*)
        ret ({| x := x'; P := p' |}, e0 -e (e1 /e (e1 +e e1)) *e (Mget (transpose y' @* inversion S' @* y') 0 0 +e logdet S' +e nat_to_MEt n *e log_two_pi))
    }%methDefParsing.

  Record SparseKalmanState :=
    { Sx : Vt n;
      SP : SSM n }.

  Definition use_a_sparse_P (or : KalmanState) (nr : SparseKalmanState) :=
    or.(x) @= nr.(Sx) /\ or.(P) @= nr.(SP).

  Definition SharpenedKalman :
    FullySharpened KalmanSpec.
  Proof.
    Optimize_ADT KalmanState SparseKalmanState use_a_sparse_P.
  Defined.

  Definition KalmanImpl : ComputationalADT.cADT KalmanSig :=
    Eval simpl in projT1 SharpenedKalman.

  Print KalmanImpl.
End KalmanFilter.


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

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

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

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

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

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

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


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

From Fairness Require Export ITreeLib WFLib FairBeh NatStructs Any Event.

Set Implicit Arguments.

Module TIdSet := NatSet.

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

Definition Val := nat.

Section TID.

  Definition nat_wf: WF := mk_wf Wf_nat.lt_wf.

  Definition tid_dec := PeanoNat.Nat.eq_dec.

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

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

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

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

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

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

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

  Definition kernel_tid: thread_id := 0.

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

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

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

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

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


(*** Interface part ***)

Require Import Subset
               Entropy
               reduction_semantics
               refocusing_semantics.
Require Export abstract_machine.

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

  Import R ST.

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

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

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

  Section S1.

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

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

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

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

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

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

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

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

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

  End S1.

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

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

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

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

End SLOPPY_REF_EVAL_APPLY_MACHINE.

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

  Import R ST.

  Declare Module RAW : SLOPPY_REF_EVAL_APPLY_MACHINE R.
  Export RAW.

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

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

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

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

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

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

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

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

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

  Definition next_conf (_ : entropy) := dnext_conf.

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

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

End REF_EVAL_APPLY_MACHINE.

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

  Import R.
  Import PERS.ST.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End REF_PUSH_ENTER_MACHINE.*)

(*** Implementation part ***)

Require Import Util
               reduction_languages_facts
               reduction_strategy_facts.

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

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

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

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

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

  Section S1.

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

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

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

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

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

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

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

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

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

  End S1.

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

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

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

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

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

  Proof.
    intros c1 c2; split; intro H.

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

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

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

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

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

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

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

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

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

  Proof.
    auto.
  Qed.

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

End SloppyRefEvalApplyMachine.

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

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

  Module RAW := SloppyRefEvalApplyMachine R.
  Export RAW.

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

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

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

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

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

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

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

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

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

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

  Definition next_conf (_ : entropy) := dnext_conf.

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

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

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

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

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

  Proof.
    intros c1 c2.

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

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

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

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

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

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

  Proof.
    auto.
  Qed.

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

End RefEvalApplyMachine.

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

  Import R.
  Import PERS.ST.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  Proof.
    intros c1 c2; split; intro H.

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

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

End RefPushEnterMachine.*)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
Copyright (C) 2011-2018 Guillaume Melquiond

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

This library 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
COPYING file for more details.
*)

(** * IEEE-754 encoding of binary floating-point data *)
Require Import Core Digits Binary.

Section Binary_Bits.

Arguments exist {A} {P}.
Arguments B754_zero {prec} {emax}.
Arguments B754_infinity {prec} {emax}.
Arguments B754_nan {prec} {emax}.
Arguments B754_finite {prec} {emax}.

(** Number of bits for the fraction and exponent *)
Variable mw ew : Z.

Definition join_bits (s : bool) m e :=
  (Z.shiftl ((if s then Zpower 2 ew else 0) + e) mw + m)%Z.

Lemma join_bits_range :
  forall s m e,
  (0 <= m < 2^mw)%Z ->
  (0 <= e < 2^ew)%Z ->
  (0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z.
Proof.
intros s m e Hm He.
assert (0 <= mw)%Z as Hmw.
  destruct mw as [|mw'|mw'] ; try easy.
  clear -Hm ; simpl in Hm ; omega.
assert (0 <= ew)%Z as Hew.
  destruct ew as [|ew'|ew'] ; try easy.
  clear -He ; simpl in He ; omega.
unfold join_bits.
rewrite Z.shiftl_mul_pow2 by easy.
split.
- apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm).
  rewrite <- (Zmult_0_l (2^mw)).
  apply Zmult_le_compat_r.
  case s.
  clear -He ; omega.
  now rewrite Zmult_0_l.
  clear -Hm ; omega.
- apply Z.lt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z.
  rewrite (Zmult_plus_distr_l _ 1).
  apply Zplus_lt_compat_l.
  now rewrite Zmult_1_l.
  rewrite <- (Zplus_assoc mw), (Zplus_comm mw), Zpower_plus.
  apply Zmult_le_compat_r.
  rewrite Zpower_plus by easy.
  change (2^1)%Z with 2%Z.
  case s ; clear -He ; omega.
  clear -Hm ; omega.
  clear -Hew ; omega.
  easy.
Qed.

Definition split_bits x :=
  let mm := Zpower 2 mw in
  let em := Zpower 2 ew in
  (Zle_bool (mm * em) x, Zmod x mm, Zmod (Z.div x mm) em)%Z.

Theorem split_join_bits :
  forall s m e,
  (0 <= m < Zpower 2 mw)%Z ->
  (0 <= e < Zpower 2 ew)%Z ->
  split_bits (join_bits s m e) = (s, m, e).
Proof.
intros s m e Hm He.
assert (0 <= mw)%Z as Hmw.
  destruct mw as [|mw'|mw'] ; try easy.
  clear -Hm ; simpl in Hm ; omega.
assert (0 <= ew)%Z as Hew.
  destruct ew as [|ew'|ew'] ; try easy.
  clear -He ; simpl in He ; omega.
unfold split_bits, join_bits.
rewrite Z.shiftl_mul_pow2 by easy.
apply f_equal2 ; [apply f_equal2|].
- case s.
  + apply Zle_bool_true.
    apply Zle_0_minus_le.
    ring_simplify.
    apply Zplus_le_0_compat.
    apply Zmult_le_0_compat.
    apply He.
    clear -Hm ; omega.
    apply Hm.
  + apply Zle_bool_false.
    apply Zplus_lt_reg_l with (2^mw * (-e))%Z.
    replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring.
    rewrite <- Zmult_plus_distr_r.
    apply Z.lt_le_trans with (2^mw * 1)%Z.
    now apply Zmult_lt_compat_r.
    apply Zmult_le_compat_l.
    clear -He ; omega.
    clear -Hm ; omega.
- rewrite Zplus_comm.
  rewrite Z_mod_plus_full.
  now apply Zmod_small.
- rewrite Z_div_plus_full_l by (clear -Hm ; omega).
  rewrite Zdiv_small with (1 := Hm).
  rewrite Zplus_0_r.
  case s.
  + replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring.
    rewrite Z_mod_plus_full.
    now apply Zmod_small.
  + now apply Zmod_small.
Qed.

Hypothesis Hmw : (0 < mw)%Z.
Hypothesis Hew : (0 < ew)%Z.

Let emax := Zpower 2 (ew - 1).
Let prec := (mw + 1)%Z.
Let emin := (3 - emax - prec)%Z.
Let binary_float := binary_float prec emax.

Let Hprec : (0 < prec)%Z.
Proof.
unfold prec.
apply Zle_lt_succ.
now apply Zlt_le_weak.
Qed.

Let Hm_gt_0 : (0 < 2^mw)%Z.
Proof.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
Qed.

Let He_gt_0 : (0 < 2^ew)%Z.
Proof.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
Qed.

Hypothesis Hmax : (prec < emax)%Z.

Theorem join_split_bits :
  forall x,
  (0 <= x < Zpower 2 (mw + ew + 1))%Z ->
  let '(s, m, e) := split_bits x in
  join_bits s m e = x.
Proof.
intros x Hx.
unfold split_bits, join_bits.
rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
pattern x at 4 ; rewrite Z_div_mod_eq_full with x (2^mw)%Z.
apply (f_equal (fun v => (v + _)%Z)).
rewrite Zmult_comm.
apply f_equal.
pattern (x / (2^mw))%Z at 2 ; rewrite Z_div_mod_eq_full with (x / (2^mw))%Z (2^ew)%Z.
apply (f_equal (fun v => (v + _)%Z)).
replace (x / 2 ^ mw / 2 ^ ew)%Z with (if Zle_bool (2 ^ mw * 2 ^ ew) x then 1 else 0)%Z.
case Zle_bool.
now rewrite Zmult_1_r.
now rewrite Zmult_0_r.
rewrite Zdiv_Zdiv.
apply sym_eq.
case Zle_bool_spec ; intros Hs.
apply Zle_antisym.
cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega.
apply Zdiv_lt_upper_bound.
now apply Zmult_lt_0_compat.
rewrite <- Zpower_exp ; try ( apply Z.le_ge ; apply Zlt_le_weak ; assumption ).
change 2%Z at 1 with (Zpower 2 1).
rewrite <- Zpower_exp.
now rewrite Zplus_comm.
discriminate.
apply Z.le_ge.
now apply Zplus_le_0_compat ; apply Zlt_le_weak.
apply Zdiv_le_lower_bound.
now apply Zmult_lt_0_compat.
now rewrite Zmult_1_l.
apply Zdiv_small.
now split.
now apply Zlt_le_weak.
now apply Zlt_le_weak.
now apply Zgt_not_eq.
now apply Zgt_not_eq.
Qed.

Theorem split_bits_inj :
  forall x y,
  (0 <= x < Zpower 2 (mw + ew + 1))%Z ->
  (0 <= y < Zpower 2 (mw + ew + 1))%Z ->
  split_bits x = split_bits y ->
  x = y.
Proof.
intros x y Hx Hy.
generalize (join_split_bits x Hx) (join_split_bits y Hy).
destruct (split_bits x) as ((sx, mx), ex).
destruct (split_bits y) as ((sy, my), ey).
intros Jx Jy H. revert Jx Jy.
inversion_clear H.
intros Jx Jy.
now rewrite <- Jx.
Qed.

Definition bits_of_binary_float (x : binary_float) :=
  match x with
  | B754_zero sx => join_bits sx 0 0
  | B754_infinity sx => join_bits sx 0 (Zpower 2 ew - 1)
  | B754_nan sx plx _ => join_bits sx (Zpos plx) (Zpower 2 ew - 1)
  | B754_finite sx mx ex _ =>
    let m := (Zpos mx - Zpower 2 mw)%Z in
    if Zle_bool 0 m then
      join_bits sx m (ex - emin + 1)
    else
      join_bits sx (Zpos mx) 0
  end.

Definition split_bits_of_binary_float (x : binary_float) :=
  match x with
  | B754_zero sx => (sx, 0, 0)%Z
  | B754_infinity sx => (sx, 0, Zpower 2 ew - 1)%Z
  | B754_nan sx plx _ => (sx, Zpos plx, Zpower 2 ew - 1)%Z
  | B754_finite sx mx ex _ =>
    let m := (Zpos mx - Zpower 2 mw)%Z in
    if Zle_bool 0 m then
      (sx, m, ex - emin + 1)%Z
    else
      (sx, Zpos mx, 0)%Z
  end.

Theorem split_bits_of_binary_float_correct :
  forall x,
  split_bits (bits_of_binary_float x) = split_bits_of_binary_float x.
Proof.
intros [sx|sx|sx plx Hplx|sx mx ex Hx] ;
  try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; omega ).
simpl. apply split_join_bits; split; try (zify; omega).
destruct (digits2_Pnat_correct plx).
unfold nan_pl in Hplx.
rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx.
rewrite Zpower_nat_Z in H0.
eapply Z.lt_le_trans. apply H0.
change 2%Z with (radix_val radix2). apply Zpower_le.
rewrite Z.ltb_lt in Hplx.
unfold prec in *. zify; omega.
(* *)
unfold bits_of_binary_float, split_bits_of_binary_float.
assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z).
destruct (andb_prop _ _ Hx) as (Hx', _).
unfold canonical_mantissa in Hx'.
rewrite Zpos_digits2_pos in Hx'.
generalize (Zeq_bool_eq _ _ Hx').
unfold FLT_exp.
unfold emin.
clear ; zify ; omega.
case Zle_bool_spec ; intros H ;
  [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ;
  apply split_join_bits ; try now split.
(* *)
split.
clear -He_gt_0 H ; omega.
cut (Zpos mx < 2 * 2^mw)%Z. clear ; omega.
replace (2 * 2^mw)%Z with (2^prec)%Z.
apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
apply Hf.
unfold prec.
rewrite Zplus_comm.
apply Zpower_exp ; apply Z.le_ge.
discriminate.
now apply Zlt_le_weak.
(* *)
split.
generalize (proj1 Hf).
clear ; omega.
destruct (andb_prop _ _ Hx) as (_, Hx').
unfold emin.
replace (2^ew)%Z with (2 * emax)%Z.
generalize (Zle_bool_imp_le _ _ Hx').
clear ; omega.
apply sym_eq.
rewrite (Zsucc_pred ew).
unfold Z.succ.
rewrite Zplus_comm.
apply Zpower_exp ; apply Z.le_ge.
discriminate.
now apply Zlt_0_le_0_pred.
Qed.

Theorem bits_of_binary_float_range:
  forall x, (0 <= bits_of_binary_float x < 2^(mw+ew+1))%Z.
Proof.
unfold bits_of_binary_float.
intros [sx|sx|sx pl pl_range|sx mx ex H].
- apply join_bits_range ; now split.
- apply join_bits_range.
  now split.
  clear -He_gt_0 ; omega.
- apply Z.ltb_lt in pl_range.
  apply join_bits_range.
  split.
  easy.
  apply (Zpower_gt_Zdigits radix2 _ (Zpos pl)).
  apply Z.lt_succ_r.
  now rewrite <- Zdigits2_Zdigits.
  clear -He_gt_0 ; omega.
- unfold bounded in H.
  apply Bool.andb_true_iff in H ; destruct H as [A B].
  apply Z.leb_le in B.
  unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A.
  case Zle_bool_spec ; intros H.
  + apply join_bits_range.
    * split.
      clear -H ; omega.
      rewrite Zpos_digits2_pos in A.
      cut (Zpos mx < 2 ^ prec)%Z.
      unfold prec.
      rewrite Zpower_plus by (clear -Hmw ; omega).
      change (2^1)%Z with 2%Z.
      clear ; omega.
      apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
      clear -A ; zify ; omega.
    * split.
      unfold emin ; clear -A ; zify ; omega.
      replace ew with ((ew - 1) + 1)%Z by ring.
      rewrite Zpower_plus by (clear - Hew ; omega).
      unfold emin, emax in *.
      change (2^1)%Z with 2%Z.
      clear -B ; omega.
  + apply -> Z.lt_sub_0 in H.
    apply join_bits_range ; now split.
Qed.

Definition binary_float_of_bits_aux x :=
  let '(sx, mx, ex) := split_bits x in
  if Zeq_bool ex 0 then
    match mx with
    | Z0 => F754_zero sx
    | Zpos px => F754_finite sx px emin
    | Zneg _ => F754_nan false xH (* dummy *)
    end
  else if Zeq_bool ex (Zpower 2 ew - 1) then
    match mx with
      | Z0 => F754_infinity sx
      | Zpos plx => F754_nan sx plx
      | Zneg _ => F754_nan false xH (* dummy *)
    end
  else
    match (mx + Zpower 2 mw)%Z with
    | Zpos px => F754_finite sx px (ex + emin - 1)
    | _ => F754_nan false xH (* dummy *)
    end.

Lemma binary_float_of_bits_aux_correct :
  forall x,
  valid_binary prec emax (binary_float_of_bits_aux x) = true.
Proof.
intros x.
unfold binary_float_of_bits_aux, split_bits.
assert (Hnan: nan_pl prec 1 = true).
  apply Z.ltb_lt.
  simpl. unfold prec.
  clear -Hmw ; omega.
case Zeq_bool_spec ; intros He1.
case_eq (x mod 2^mw)%Z ; try easy.
(* subnormal *)
intros px Hm.
assert (Zdigits radix2 (Zpos px) <= mw)%Z.
apply Zdigits_le_Zpower.
simpl.
rewrite <- Hm.
eapply Z_mod_lt.
now apply Z.lt_gt.
apply bounded_canonical_lt_emax ; try assumption.
unfold canonical, cexp.
fold emin.
rewrite mag_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
apply sym_eq.
apply Zmax_right.
clear -H Hprec.
unfold prec ; omega.
apply Rnot_le_lt.
intros H0.
refine (_ (mag_le radix2 _ _ _ H0)).
rewrite mag_bpow.
rewrite mag_F2R_Zdigits. 2: discriminate.
unfold emin, prec.
apply Zlt_not_le.
cut (0 < emax)%Z. clear -H Hew ; omega.
apply (Zpower_gt_0 radix2).
clear -Hew ; omega.
apply bpow_gt_0.
case Zeq_bool_spec ; intros He2.
case_eq (x mod 2 ^ mw)%Z; try easy.
(* nan *)
intros plx Eqplx. apply Z.ltb_lt.
rewrite Zpos_digits2_pos.
assert (forall a b, a <= b -> a < b+1)%Z by (intros; omega). apply H. clear H.
apply Zdigits_le_Zpower. simpl.
rewrite <- Eqplx. edestruct Z_mod_lt; eauto.
change 2%Z with (radix_val radix2).
apply Z.lt_gt, Zpower_gt_0. omega.
case_eq (x mod 2^mw + 2^mw)%Z ; try easy.
(* normal *)
intros px Hm.
assert (prec = Zdigits radix2 (Zpos px)).
(* . *)
rewrite Zdigits_mag. 2: discriminate.
apply sym_eq.
apply mag_unique.
rewrite <- abs_IZR.
unfold Z.abs.
replace (prec - 1)%Z with mw by ( unfold prec ; ring ).
rewrite <- IZR_Zpower with (1 := Zlt_le_weak _ _ Hmw).
rewrite <- IZR_Zpower. 2: now apply Zlt_le_weak.
rewrite <- Hm.
split.
apply IZR_le.
change (radix2^mw)%Z with (0 + 2^mw)%Z.
apply Zplus_le_compat_r.
eapply Z_mod_lt.
now apply Z.lt_gt.
apply IZR_lt.
unfold prec.
rewrite Zpower_exp. 2: now apply Z.le_ge ; apply Zlt_le_weak. 2: discriminate.
rewrite <- Zplus_diag_eq_mult_2.
apply Zplus_lt_compat_r.
eapply Z_mod_lt.
now apply Z.lt_gt.
(* . *)
apply bounded_canonical_lt_emax ; try assumption.
unfold canonical, cexp.
rewrite mag_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
rewrite <- H.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
replace (prec + (ex + emin - 1) - prec)%Z with (ex + emin - 1)%Z by ring.
apply sym_eq.
apply Zmax_left.
revert He1.
fold ex.
cut (0 <= ex)%Z.
unfold emin.
clear ; intros H1 H2 ; omega.
eapply Z_mod_lt.
apply Z.lt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply Rnot_le_lt.
intros H0.
refine (_ (mag_le radix2 _ _ _ H0)).
rewrite mag_bpow.
rewrite mag_F2R_Zdigits. 2: discriminate.
rewrite <- H.
apply Zlt_not_le.
unfold emin.
apply Zplus_lt_reg_r with (emax - 1)%Z.
ring_simplify.
revert He2.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
cut (ex < 2^ew)%Z.
replace (2^ew)%Z with (2 * emax)%Z.
clear ; intros H1 H2 ; omega.
replace ew with (1 + (ew - 1))%Z by ring.
rewrite Zpower_exp.
apply refl_equal.
discriminate.
clear -Hew ; omega.
eapply Z_mod_lt.
apply Z.lt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply bpow_gt_0.
Qed.

Definition binary_float_of_bits x :=
  FF2B prec emax _ (binary_float_of_bits_aux_correct x).

Theorem binary_float_of_bits_of_binary_float :
  forall x,
  binary_float_of_bits (bits_of_binary_float x) = x.
Proof.
intros x.
apply B2FF_inj.
unfold binary_float_of_bits.
rewrite B2FF_FF2B.
unfold binary_float_of_bits_aux.
rewrite split_bits_of_binary_float_correct.
destruct x as [sx|sx|sx plx Hplx|sx mx ex Bx].
apply refl_equal.
(* *)
simpl.
rewrite Zeq_bool_false.
now rewrite Zeq_bool_true.
cut (1 < 2^ew)%Z. clear ; omega.
now apply (Zpower_gt_1 radix2).
(* *)
simpl.
rewrite Zeq_bool_false.
rewrite Zeq_bool_true; auto.
cut (1 < 2^ew)%Z. clear ; omega.
now apply (Zpower_gt_1 radix2).
(* *)
unfold split_bits_of_binary_float.
case Zle_bool_spec ; intros Hm.
(* . *)
rewrite Zeq_bool_false.
rewrite Zeq_bool_false.
now ring_simplify (Zpos mx - 2 ^ mw + 2 ^ mw)%Z (ex - emin + 1 + emin - 1)%Z.
destruct (andb_prop _ _ Bx) as (_, H1).
generalize (Zle_bool_imp_le _ _ H1).
unfold emin.
replace (2^ew)%Z with (2 * emax)%Z.
clear ; omega.
replace ew with (1 + (ew - 1))%Z by ring.
rewrite Zpower_exp.
apply refl_equal.
discriminate.
clear -Hew ; omega.
destruct (andb_prop _ _ Bx) as (H1, _).
generalize (Zeq_bool_eq _ _ H1).
rewrite Zpos_digits2_pos.
unfold FLT_exp, emin.
generalize (Zdigits radix2 (Zpos mx)).
clear.
intros ; zify ; omega.
(* . *)
rewrite Zeq_bool_true. 2: apply refl_equal.
simpl.
apply f_equal.
destruct (andb_prop _ _ Bx) as (H1, _).
generalize (Zeq_bool_eq _ _ H1).
rewrite Zpos_digits2_pos.
unfold FLT_exp, emin, prec.
apply -> Z.lt_sub_0 in Hm.
generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm).
generalize (Zdigits radix2 (Zpos mx)).
clear.
intros ; zify ; omega.
Qed.

Theorem bits_of_binary_float_of_bits :
  forall x,
  (0 <= x < 2^(mw+ew+1))%Z ->
  bits_of_binary_float (binary_float_of_bits x) = x.
Proof.
intros x Hx.
unfold binary_float_of_bits, bits_of_binary_float.
set (Cx := binary_float_of_bits_aux_correct x).
clearbody Cx.
rewrite match_FF2B.
revert Cx.
generalize (join_split_bits x Hx).
unfold binary_float_of_bits_aux.
case_eq (split_bits x).
intros (sx, mx) ex Sx.
assert (Bm: (0 <= mx < 2^mw)%Z).
inversion_clear Sx.
apply Z_mod_lt.
now apply Z.lt_gt.
case Zeq_bool_spec ; intros He1.
(* subnormal *)
case_eq mx.
intros Hm Jx _.
now rewrite He1 in Jx.
intros px Hm Jx _.
rewrite Zle_bool_false.
now rewrite <- He1.
apply <- Z.lt_sub_0.
now rewrite <- Hm.
intros px Hm _ _.
apply False_ind.
apply Zle_not_lt with (1 := proj1 Bm).
now rewrite Hm.
case Zeq_bool_spec ; intros He2.
(* infinity/nan *)
case_eq mx; intros Hm.
now rewrite He2.
now rewrite He2.
intros. zify; omega.
(* normal *)
case_eq (mx + 2 ^ mw)%Z.
intros Hm.
apply False_ind.
clear -Bm Hm ; omega.
intros p Hm Jx Cx.
rewrite <- Hm.
rewrite Zle_bool_true.
now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z.
now ring_simplify.
intros p Hm.
apply False_ind.
clear -Bm Hm ; zify ; omega.
Qed.

End Binary_Bits.

(** Specialization for IEEE single precision operations *)
Section B32_Bits.

Arguments B754_nan {prec} {emax}.

Definition binary32 := binary_float 24 128.

Let Hprec : (0 < 24)%Z.
Proof.
apply refl_equal.
Qed.

Let Hprec_emax : (24 < 128)%Z.
Proof.
apply refl_equal.
Qed.

Definition default_nan_pl32 : { nan : binary32 | is_nan 24 128 nan = true } :=
  exist _ (@B754_nan 24 128 false (iter_nat xO 22 xH) (refl_equal true)) (refl_equal true).

Definition unop_nan_pl32 (f : binary32) : { nan : binary32 | is_nan 24 128 nan = true } :=
  match f as f with
  | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true)
  | _ => default_nan_pl32
  end.

Definition binop_nan_pl32 (f1 f2 : binary32) : { nan : binary32 | is_nan 24 128 nan = true } :=
  match f1, f2 with
  | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true)
  | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true)
  | _, _ => default_nan_pl32
  end.

Definition b32_erase : binary32 -> binary32 := erase 24 128.
Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32.
Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32.
Definition b32_sqrt :  mode -> binary32 -> binary32 := Bsqrt  _ _ Hprec Hprec_emax unop_nan_pl32.

Definition b32_plus :  mode -> binary32 -> binary32 -> binary32 := Bplus  _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_minus : mode -> binary32 -> binary32 -> binary32 := Bminus _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_mult :  mode -> binary32 -> binary32 -> binary32 := Bmult  _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_div :   mode -> binary32 -> binary32 -> binary32 := Bdiv   _ _ Hprec Hprec_emax binop_nan_pl32.

Definition b32_compare : binary32 -> binary32 -> option comparison := Bcompare 24 128.
Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8.

End B32_Bits.

(** Specialization for IEEE double precision operations *)
Section B64_Bits.

Arguments B754_nan {prec} {emax}.

Definition binary64 := binary_float 53 1024.

Let Hprec : (0 < 53)%Z.
Proof.
apply refl_equal.
Qed.

Let Hprec_emax : (53 < 1024)%Z.
Proof.
apply refl_equal.
Qed.

Definition default_nan_pl64 : { nan : binary64 | is_nan 53 1024 nan = true } :=
  exist _ (@B754_nan 53 1024 false (iter_nat xO 51 xH) (refl_equal true)) (refl_equal true).

Definition unop_nan_pl64 (f : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } :=
  match f as f with
  | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true)
  | _ => default_nan_pl64
  end.

Definition binop_nan_pl64 (f1 f2 : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } :=
  match f1, f2 with
  | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true)
  | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true)
  | _, _ => default_nan_pl64
  end.

Definition b64_erase : binary64 -> binary64 := erase 53 1024.
Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64.
Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64.
Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64.

Definition b64_plus  : mode -> binary64 -> binary64 -> binary64 := Bplus  _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_minus : mode -> binary64 -> binary64 -> binary64 := Bminus _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_mult  : mode -> binary64 -> binary64 -> binary64 := Bmult  _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_div   : mode -> binary64 -> binary64 -> binary64 := Bdiv   _ _ Hprec Hprec_emax binop_nan_pl64.

Definition b64_compare : binary64 -> binary64 -> option comparison := Bcompare 53 1024.
Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11.

End B64_Bits.


Require Import CoqCompile.Env.
Require Import CoqCompile.Lambda.
Require Import List.
Require Import String.
Require Import Ascii.
Require Import Bool.
Require Import ExtLib.Data.Strings.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.EitherMonad.
Require Import ExtLib.Programming.Show.
Require Import Program.
Require Import Omega.
Require Import Wf.
(* Require Import Wellfounded.Lexicographic_Product. *)
Require Import Relation_Operators.

Set Implicit Arguments.
Set Strict Implicit.

(** A simple, recursive descent parser intended to take the Scheme output
    of the extractor and build a corresponding Lambda.exp.

    A few things are still missing:
    - Scheme comments (e.g., ";;" terminated by end of line.)
    - we probably don't have all of the characters right that can appear
      in identifiers.
    - we probably ought to treat "_" as a variable specially?
    - need comments to explain more in the file.
    - should try to rewrite in a monadic style, but this would require
      a dependent monad.
    - should add error handling support so we can identify what the parse
      error is (or at least at which token it's occurring.)
    - probably should use refine instead of Program and handle more of
      the match stuff myself so that we don't generate > 400 proof
      obligations (ugh).  This would improve the compile time for this
      considerably, at the expense of making the code harder to read/write.

   This is interesting because of the way that I was forced to show
   termination of the parser.  It demonstrates the use of a function
   defined in terms of a well-founded, lexicographic ordering.
*)
Module Parse.
  Import Lambda.

Section monadic.
  Import MonadNotation.
  Local Open Scope monad_scope.

  Variable m : Type -> Type.
  Context {Monad_m : Monad m}.
  Context {MonadExc_m : MonadExc unit m}.

  (** Lexing *)
  Inductive token :=
    LPAREN | RPAREN | AT | QUOTE | COMMA | LAMBDA | LAMBDAS | LETREC | LET
  | DEFINE | MATCH | ID : string -> token.

  Section Printing.
    Import ShowNotation.
    Local Open Scope string_scope.
    Local Open Scope show_scope.

    Global Instance Show_token : Show token :=
      fun t =>
        match t with
          | LPAREN => "("
          | RPAREN => ")"
          | AT => "@"
          | QUOTE => "`"
          | COMMA => ","
          | LAMBDA => "lambda"
          | LAMBDAS => "lambdas"
          | LETREC => "letrec"
          | LET => "let"
          | DEFINE => "define"
          | MATCH => "match"
          | ID s => s ++ " "
        end.

    Global Instance Show_tokens : Show (list token) :=
      fun ts => iter_show (map show ts).

  End Printing.

  Fixpoint list2string (cs:list ascii) : string :=
    match cs with
      | nil => EmptyString
      | c::cs => String c (list2string cs)
    end.

  Fixpoint string2list (s:string) : list ascii :=
    match s with
      | EmptyString => nil
      | String c s' => c::(string2list s')
    end.

  Definition alpha : list ascii :=
    string2list "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ".
  Definition numeric : list ascii :=
    string2list "0123456789".
  Definition misc : list ascii := string2list "_~".
  Definition alpha_numeric := numeric ++ alpha.
  Definition id_start := misc ++ alpha.
  Definition id_char := alpha_numeric ++ misc.
  (** linefeed, carriage return, tab, and space *)
  Definition white : list ascii :=
    (ascii_of_nat 9)::(ascii_of_nat 10)::(ascii_of_nat 13)::(ascii_of_nat 32)::nil.

  (** Keyword string to token mapping *)
  Local Open Scope string_scope.
  Definition keywords : list (string * token) :=
    ("lambda",LAMBDA)::
    ("lambdas",LAMBDAS)::
    ("letrec",LETREC)::
    ("let",LET)::
    ("define",DEFINE)::
    ("match",MATCH)::
    nil.

  Fixpoint lookup {A} (x:string) (xs:list (string * A)) : option A :=
    match xs with
      | nil => None
      | (y,c)::t => if eq_dec y x then Some c else lookup x t
    end.

  Definition id_to_token (s:string) : token :=
    match lookup s keywords with
      | None => ID s
      | Some x => x
    end.

  Fixpoint member(c:ascii)(cs:list ascii) : bool :=
    match cs with
      | nil => false
      | c'::cs => if eq_dec c c' then true else member c cs
    end.

  (** Pull off characters from the string to form an identifier.  [cs] is
      the list of characters accumulated (in reverse order). *)
  Fixpoint token_id (s:string) (cs:list ascii) : token * string :=
    match s with
      | EmptyString => (id_to_token (list2string (rev cs)), EmptyString)
      | String c s' =>
        if member c id_char then token_id s' (c::cs) else
          (id_to_token (list2string (rev cs)), String c s')
    end.

  (** Needed to show termination for [tokenize] below. *)
  Lemma token_id_lt : forall s cs, length (snd (token_id s cs)) <= length s.
  Proof.
    induction s. simpl. intro ; auto with arith. intros.
    unfold token_id. fold token_id. destruct (member a id_char).
    specialize (IHs (a::cs)). assert (length (String a s) = S (length s)). auto.
    rewrite H. omega. simpl. auto with arith.
  Qed.

  Section TOKENIZE.
    Import Ascii.
    Local Open Scope char_scope.

    (** Converts a string into a list of tokens.  The [measure] annotation
        says that we are defining this not by structural induction, but rather
        using the well-founded order [lt] (less-than) on [nat] relative to
        the length of the input string.  That is, we must argue that the string
        is getting smaller each time around the loop. *)
    Program Fixpoint tokenize (s:string) (ts : list token) {measure (length s)} :
      ascii + (list token) :=
      match s with
        | EmptyString => inr (rev ts)
        | String c s' =>
          if member c white then tokenize s' ts
          else if eq_dec c "(" then tokenize s' (LPAREN::ts)
          else if eq_dec c ")" then tokenize s' (RPAREN::ts)
          else if eq_dec c "@" then tokenize s' (AT::ts)
          else if eq_dec c "`" then tokenize s' (QUOTE::ts)
          else if eq_dec c "," then tokenize s' (COMMA::ts)
          else if member c id_start then
            match token_id s' (c::nil) with
              | (t,s'') => tokenize s'' (t::ts)
            end
          else inl c
      end.
    Next Obligation.
      clear tokenize. generalize (token_id_lt s' [c]). rewrite <- Heq_anonymous. simpl.
      intros. omega.
    Defined.
  End TOKENIZE.

  Section parse_list.
    Context {A : Type}.
    Variable p : list token -> m (A * list token).

    (** parse_list<p> -> p parse_list<p> | epsilon **)
    Fixpoint parse_list (ts:list token) (fuel:nat) : m ((list A) * (list token)) :=
      match fuel with
        | O => raise tt (* "Ran out of fuel during parse_exp'list" *)
        | S fuel =>
          catch (res <- p ts ;;
                 let '(e,ts2) := res in
                 res <- parse_list ts2 fuel ;;
                 let '(es,ts3) := res in
                 ret (e::es,ts3))
                (fun _ => ret (nil, ts))
      end.

  End parse_list.

  Definition parse_arglist : list token -> nat -> m ((list var) * list token) :=
    parse_list (fun ts =>
      match ts with
        | (ID x) :: ts =>
          ret (Env.wrapVar x, ts)
        | _ => raise tt (* "non-arg" *)
      end).

  Definition raiseM (* (s : string) *) {a} : m a := raise tt.

  Fixpoint parse_exp' (ts:list token) (fuel:nat) : m (exp * (list token)) :=
    match fuel return m (exp * list token) with
      | O => raiseM (* "Ran out of fuel during parse_exp'" *)
      | S fuel =>
        match ts return m _ with
        (* EXP -> <ID> *)
          | (ID x)::ts2 => ret (Var_e (Env.wrapVar x), ts2)
        (* EXP -> (lambda (<ID>) <EXP>) *)
          | LPAREN::LAMBDA::LPAREN::(ID x)::RPAREN::ts2 =>
            res <- parse_exp' ts2 fuel ;;
            match res return m _ with
              | (e,RPAREN::ts3) => ret (Lam_e (Env.wrapVar x) e,ts3)
              | _ => raiseM (* "Error parsing lambda, expecting expression" *)
            end
          (* EXP -> (lambdas (<ARGLIST>) <EXP>) *)
          | LPAREN::LAMBDAS::LPAREN::ts2 =>
            res <- parse_arglist ts2 fuel ;;
            match res return m _ with
              | (xs,RPAREN::ts3) =>
                res <- parse_exp' ts3 fuel ;;
                match res return m _ with
                  | (e,RPAREN::ts4) =>
                    ret (fold_right Lam_e e xs,ts4)
                  | _ => raiseM (* "Error parsing lambda, expecting expression" *)
                end
              | _ => raiseM (* "Error parsing lambda, expecting arguments" *)
            end
          (* EXP -> `(<ID> <CONARGLIST>) *)
          | QUOTE::LPAREN::(ID c)::ts2 =>
            res <- parse_list (fun ts =>
              match ts return m (exp * list token) with
                | COMMA :: ts1 =>
                  parse_exp' ts1 fuel
                | _ => raiseM (* "can not parse exp" *)
              end) ts2 (S fuel) ;;
            match res return m (exp * list token) with
              | (es,RPAREN::ts3) =>
                ret (Con_e c es,ts3)
              | _ => raiseM (* "Error parsing constructor" *)
            end
          (* EXP -> (@ <EXPLIST>) *)
          | LPAREN::AT::ts2 =>
            res <- parse_exp' ts2 fuel ;;
            match res return m _ with
              | (e1,ts3) =>
                res <- parse_list (fun x => parse_exp' x fuel) ts3 (S fuel) ;;
                match res return m _ with
                  | (es,RPAREN::ts4) =>
                    ret (fold_left App_e es e1,ts4)
                  | _ => raiseM (* "Error parsing unquote, expecting expression list" *)
                end
            end
          (* EXP -> (match <EXP> <ARMLIST>) *)
          | LPAREN::MATCH::ts1 =>
            res <- parse_exp' ts1 fuel ;;
            match res return m _ with
              | (e,ts2) =>
                res <- parse_list (fun ts =>
                  match ts return m _ with
                    | LPAREN :: LPAREN :: (ID c) :: ts1 =>
                      res <- parse_arglist ts1 fuel ;;
                      match res return m _ with
                        | (xs, RPAREN :: ts2) =>
                          res <- parse_exp' ts2 fuel ;;
                          match res return m _ with
                            | (e, RPAREN :: ts3) =>
                              ret ((Con_p c xs, e), ts3)
                            | _ => raiseM (* "error parsing arm" *)
                          end
                        | _ => raiseM (* "error parsing arm" *)
                      end
                    | _ => raiseM (* "error parsing arm" *)
                  end) ts2 (S fuel) ;;
                match res return m _ with
                  | (arms,RPAREN::ts3) =>
                    ret (Match_e e arms,ts3)
                  | _ => raiseM (* "Error parsing match, expecting arm list" *)
                end
            end
          (* EXP -> (letrec (<DECLLIST>) <EXP>) *)
          | LPAREN::LETREC::LPAREN::ts1 =>
            res <- parse_list (fun ts =>
              match ts return m _ with
                | LPAREN::(ID f)::ts1 =>
                  res <- parse_exp' ts1 fuel ;;
                  match res return m _ with
                    | (Lam_e x e,RPAREN::ts2) =>
                      ret ((Env.wrapVar f,(x,e)),ts2)
                    | _ => raiseM (* "Error parsing declaration list, expecting lambda term" *)
                  end
                | _ => raiseM (* "Error parsing decl" *)
              end) ts1 (S fuel) ;;
            match res return m _ with
              | (ds,RPAREN::ts2) =>
                res <- parse_exp' ts2 fuel ;;
                match res return m _ with
                  | (e,RPAREN::ts3) =>
                    ret (Letrec_e ds e,ts3)
                  | _ => raiseM (* "Error parsing letrec, expecting expression" *)
                end
              | _ => raiseM (* "Error parsing letrec, expecting declaration list" *)
            end
          (* EXP -> (let (<DECL>) <EXP>) *)
          | LPAREN::LET::LPAREN::LPAREN::(ID v)::ts1 =>
            res <- parse_exp' ts1 fuel ;;
            match res return m _ with
              | (e,RPAREN::RPAREN::ts2) =>
                res <- parse_exp' ts2 fuel ;;
                match res return m _ with
                  | (e',RPAREN::ts3) =>
                    ret (Let_e (Env.wrapVar v) e e',ts3)
                  | _ => raiseM (* "Error parsing let, expecting )" *)
                end
              | _ => raiseM (* "Error parsing let, expecting expression" *)
            end
          (* EXP -> (<EXP> <EXP>) *)
          | LPAREN::ts2 =>
            res <- parse_exp' ts2 fuel ;;
            match res return m _ with
              | (e1,ts3) =>
                res <- parse_exp' ts3 fuel ;;
                match res return m _ with
                  | (e2,RPAREN::ts4) =>
                    ret (App_e e1 e2,ts4)
                  | _ => raiseM (* "Error parsing application, expecting expression" *)
                end
            end
          | t::ts => raiseM (* ("Error parsing expression, unexpected token " ++ (to_string t) ++ " while trying to parse " ++ to_string (t::ts))%string *)
          | nil => raiseM (* "Error parsing expression, unexpected EOF" *)
        end
    end.

  (** Parsing *)
  Fixpoint parse (ts:list token) (fuel:nat) : m (list (var * exp)) :=
    match fuel return m _ with
      | O => raiseM (* "Ran out of fuel during parse" *)
      | S fuel =>
        match ts return m _ with
          | nil => ret nil
          | LPAREN::DEFINE::(ID x)::ts1 =>
            res <- parse_exp' ts1 fuel ;;
            match res return m _ with
              | (e,RPAREN::ts2) =>
                es <- parse ts2 fuel ;;
                ret ((Env.wrapVar x,e)::es)
              | _ => raiseM (* "Parse error while parsing define" *)
            end
          | _ => raiseM (* "Parse error while parsing definitions" *)
        end
    end.

End monadic.

Definition failed_to_parse : string := "failed to parse"%string.

  (** A parser for expresions *)
  Definition parse_exp (s:string) : string + (exp * list token) :=
    match tokenize s nil with
      | inl c => inl ("Parse error: tokenizer failed. unknown character '" ++ String c "'")%string
      | inr ts => match parse_exp' ts (List.length ts) with
                    | inl _ => inl failed_to_parse
                    | inr e => inr e
                  end
    end.

  (** Some test cases -- should turn these into real unit tests. *)
(*
  Eval compute in parse_exp "x".
  Eval compute in parse_exp "(@ f x y)".
  Eval compute in parse_exp "(f x)".
  Eval compute in parse_exp "`(Cons ,a ,b)".
  Eval compute in parse_exp "`(Z)".
  Eval compute in parse_exp "(lambda (x) x)".
  Eval vm_compute in parse_exp "(lambdas (x1 x2 x3) (@x3 x2 x1))".
  Eval vm_compute in parse_exp "(match x ((Cons hd tl) hd) ((Nil) x))".
  Eval vm_compute in parse_exp "(letrec ((f (lambda (x) (f x)))) f)".
*)

  (** Collapse a list of top-level declarations into a big sequence of "lets".
      However, we simply assume that any function defined at the top-level is
      recursive and so use a "letrec" for lambdas.  We could try to do something
      smarter, like see if the function really is recursive, but that's something
      we can leave to the optimizer. *)
  Fixpoint collapse_decls (ds:list (var*exp)) (fs:env_t (var * exp)) (e:exp) : exp :=
    match ds with
      | nil => match rev fs with
                 | nil => e
                 | fs' => Letrec_e fs' e
               end
      | (f,(Lam_e x e'))::rest => collapse_decls rest ((f,(x,e'))::fs) e
      | (x,e')::rest =>
        match rev fs with
          | nil => Let_e x e' (collapse_decls rest nil e)
          | fs' => Letrec_e fs' (Let_e x e' (collapse_decls rest nil e))
        end
    end.

  Fixpoint lastDecl (ds : list (var * exp)) : option var :=
    match ds with
      | nil => None
      | (v,_) :: nil => Some v
      | _ :: ds => lastDecl ds
    end.

  (** Parse a set of top-level declarations and return a bit "let", binding
      those declarations, terminated by a call to "main tt".  Of course, this
      is only meaningful if one of the declarations binds a function that takes
      unit as an argument... *)
  Definition parse_topdecls (s:string) : string + exp :=
    match tokenize s nil with
      | inl c => inl ("Parse error: tokenizer failed. unknown '" ++ (String c "'"))%string
      | inr ts => match parse ts (List.length ts) with
                    | inl e => inl failed_to_parse
                    | inr ds =>
                      let body :=
                        match lastDecl ds with
                          | None => Con_e "Tt"%string nil
                          | Some v => Var_e v
                        end
                      in
                      inr (collapse_decls ds nil body)
                  end
    end.

  (** A relatively big test case that I got by extracting some real code using
      [Extraction Language Scheme].  We probably want to add some support for
      skipping the comments at the top of a file, as well as the
      "(load ...)" so that we can just pipe the output of the extractor directly
      into the parser.  But at least for now, this will be useful for building
      modestly sized Lambda expressions. *)
(*
  Eval vm_compute in parse_topdecls
"(define negb (lambda (b)
  (match b
     ((True) `(False))
     ((False) `(True)))))

(define fst (lambda (p0)
  (match p0
     ((Pair x y) x))))

(define snd (lambda (p0)
  (match p0
     ((Pair x y) y))))

(define app (lambdas (l m)
  (match l
     ((Nil) m)
     ((Cons a l1) `(Cons ,a ,(@ app l1 m))))))

(define compareSpec2Type (lambda (c)
  (match c
     ((Eq) `(CompEqT))
     ((Lt) `(CompLtT))
     ((Gt) `(CompGtT)))))

(define compSpec2Type (lambdas (x y c) (compareSpec2Type c)))

(define plus (lambdas (n m)
  (match n
     ((O) m)
     ((S p0) `(S ,(@ plus p0 m))))))

(define mult (lambdas (n m)
  (match n
     ((O) `(O))
     ((S p0) (@ plus m (@ mult p0 m))))))

(define minus (lambdas (n m)
  (match n
     ((O) n)
     ((S k)
       (match m
          ((O) n)
          ((S l) (@ minus k l)))))))

(define nat_iter (lambdas (n f x)
  (match n
     ((O) x)
     ((S n~) (f (@ nat_iter n~ f x))))))
".
*)
End Parse.