Require Import FJ_tactics.
Require Import List.
Require Import Functors.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffState.
Require Import EffExcept.
Require Export ESoundS.

Section ESoundES.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.

  Variable E : Set -> Set.
  Context {Fun_E : Functor E}.

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_M : Functor ME}.
  Context {Mon_M : Monad ME}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {StateM_ME : StateM ME (list (Names.Value V))}.
  Context {Fail_ME : FailMonad ME}.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.

  Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}.
  Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D))}.
  Context {eq_DType_neq_D : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D))}.

  Context {Typeof_E : forall T, FAlgebra TypeofName T (typeofR D MT) E}.

  Context {evalM_E : FAlgebra EvalName (Exp E) (evalMR V ME) E}.
  Context {evalM_E' : forall T, FAlgebra EvalName T (evalMR V ME) E}.

  Variable TypContext : Set.
  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Context {funWFV : iFunctor WFV}.

  Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext -> Prop.
  Context {funWFVM : iFunctor WFVM}.

  Context {TypContextCE : ConsExtensionC TypContext}.
  Context {TypContext_WFE : WF_EnvC V TypContext}.

  Context {Sub_WFVM_Base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME TypContext WFV) WFVM}.
  Context {Sub_WFVM_State_WFVM : Sub_iFunctor (WFValueM_State D V MT ME TypContext) WFVM}.
  Context {Sub_WFVM_Except_WFVM : Sub_iFunctor (WFValueM_Except D V MT ME _) WFVM}.

  Context {TypContext_S : SigTypContextC D TypContext}.
  Context {TypContext_SCE : SigConsExtensionC D TypContext _ _}.

  Section Except_State_Sound_Sec.

    Variable WFV' : (WFValue_i D V (list (DType D)) -> Prop) -> WFValue_i D V (list (DType D)) -> Prop.
    Context {funWFV' : iFunctor WFV'}.

    Variable WFVM' : (WFValueM_i D V MT ME (list (DType D)) -> Prop) ->
      WFValueM_i D V MT ME (list (DType D)) -> Prop.
    Context {funWFVM' : iFunctor WFVM'}.

    Definition Except_State_Sound_P (i : WFValueM_i D V MT ME (list (DType D))) :=
      forall T (env : list (Value V)),
        WF_Env (WF_EnvC := DType_Env_WFE D V WFV') _ env (wfvm_S _ _ _ _ _ i) ->
        fmap (@proj1_sig _ _) (wfvm_T _ _ _ _ _ i) = return_ (proj1_sig T) ->
        (exists v : Value V, exists env', exists Sigma' : list (DType D),
          (put env) >> wfvm_v _ _ _ _ _ i = put env' >> return_ (M := ME) v /\
          WFValueC D V _ WFV' Sigma' v T) \/
        (exists t, exists env', exists Sigma' : list (DType D),
          put env >> wfvm_v _ _ _ _ _ i = put env' >> throw t
        /\ WF_Env (WF_EnvC := DType_Env_WFE D V WFV') _ env' Sigma'
        /\ (forall n T, lookup (wfvm_S _ _ _ _ _ i) n = Some T -> lookup Sigma' n = Some T)).

    Inductive Except_State_Sound_Name := except_state_sound_name.

    Global Instance Except_State_Sound_WFVM_State :
      iPAlgebra Except_State_Sound_Name Except_State_Sound_P
      (WFValueM_State (TypContext_WFE := DType_Env_WFE _ _ WFV') D V MT ME (list (DType D))).
    Proof.
      econstructor.
      unfold iAlgebra; intros; apply ind_alg_WFVM_State with (State_M := StateM_ME)
        (TypContextCE := DType_Env_CE _) (TypContext_WFE := DType_Env_WFE _ _ WFV');
        try assumption; unfold Except_State_Sound_P; simpl; intros.
      (* WFVM_Get *)
      destruct (H0 env H1 T0 env H1 H2) as [[v [env' [Sigma' [eval_eq WF_v_T]]]]
        | [[] [env' [Sigma' [k_eq [WF_env_Sigma' Sigma'_Cons]]]]]].
      left; exists v; exists env'; exists Sigma'.
      unfold wbind; rewrite associativity.
      generalize put_get as put_get'; intros; unfold wbind in put_get'; rewrite put_get'.
      rewrite <- associativity.
      rewrite <- left_unit.
      split; unfold wbind; auto.
      right; exists tt; exists env'; exists Sigma';
        unfold wbind; rewrite associativity; repeat split; auto.
      generalize put_get; unfold wbind; intros pg; rewrite pg;
        rewrite <- associativity; rewrite <- left_unit; auto.
      (* WFVM_Put *)
      unfold wbind; rewrite associativity.
      generalize put_put as put_put'; intros; unfold wbind in put_put'; rewrite put_put';
        clear put_put'.
      destruct (H2 T0 env H0 H4) as [[v [env' [Sigma'' [eval_eq WF_v_T]]]]
        | [[] [env' [Sigma'' [k_eq [WF_env_Sigma'' Sigma''_Cons]]]]]].
      left; exists v; exists env'; exists Sigma''; split; auto.
      right; exists tt; exists env'; exists Sigma''; split; auto.
    Qed.

    Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV') WFV'}.

    Global Instance Except_State_Sound_WFVM_Base :
      iPAlgebra Except_State_Sound_Name Except_State_Sound_P (WFValueM_base D V MT ME _ WFV').
    Proof.
      econstructor.
      unfold iAlgebra; intros; apply ind_alg_WFVM_base with (WFV := WFV')
        (Fail_MT := Fail_MT) (Monad_ME := Mon_M);
        try assumption; unfold Except_State_Sound_P; simpl; intros.
      (* WFVM_Return' *)
      left; exists v; exists env; exists Sigma; split; auto.
      destruct H1 as [mt' mt'_eq]; subst.
      rewrite fmap_fusion in H3.
      destruct (fmap_exists _ _ _ _ _ H3) as [[T' T_eq] T'_eq].
      simpl in *; subst; auto.
      destruct T0 as [T0 T0_UP'].
      apply (WFV_proj1_b _ _ _ _ _ _ H0); simpl; auto.
      simpl in T'_eq; congruence.
      (* WFVM_Untyped' *)
      simpl in H1; apply sym_eq in H1.
      unfold wbind in H1;
        rewrite fmap_m, <- associativity, bind_fail in H1.
      apply FailMonad_Disc in H1; destruct H1; auto.
    Defined.

    Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env : list (Names.Value (Fun_V := Fun_V) V)),
      (exists a : A, exists env' : list (Names.Value (Fun_V := Fun_V) V),
        wbind (H := Mon_M) (put (StateM := StateM_ME) env)
        mte = wbind (H := Mon_M) (put (StateM := StateM_ME) env') (return_ (Monad := Mon_M) a)) \/
      (exists env', put env >> mte = put env' >> throw tt)}.
    Context {MT_eq_dec : forall (A : Set) (mta : MT A),
      {exists a, mta = return_ a} + {mta = fail}}.

    Section Except_State_Sound_WFVM_Except_Sec.
      (* Section with one possible put_catch law. *)
      Context {put_catch : forall (A : Set) (env : list (Value V)) e h,
        put env >>= (fun _ => catch (A := A) e h) = catch (put env >>= fun _ => e) h}.
      Context {put_throw : forall (A B : Set) (env env' : list (Value V)) t,
        put env >>= (fun _ => throw t (A := A)) = put env' >>= (fun _ => throw t) ->
        put env >>= (fun _ => throw t (A := B)) = put env' >>= (fun _ => throw t)}.
      Context {Put_Exception_Disc :
        forall (A : Set) (a : A) env env' n,
          (put env >>= fun _ => return_ a) <> put env' >>= fun _ => throw n}.

      Global Instance Except_State_Sound_WFVM_Except :
        iPAlgebra Except_State_Sound_Name Except_State_Sound_P (WFValueM_Except D V MT ME _).
      Proof.
        econstructor.
        unfold iAlgebra; intros; apply ind_alg_WFVM_Except with (Exception_ME := Exception_ME)
          (Fail_MT := Fail_MT) (eq_DType_DT := eq_DType_DT) (TypContextCE := DType_Env_CE _);
          try assumption; unfold Except_State_Sound_P; simpl; intros.
      (* throw case *)
        simpl; right; exists tt; exists env; exists Sigma; split; auto.
      (* catch case *)
        destruct (MT_eq_dec _ mte) as [[T' mte_eq] | mte_eq]; subst.
        destruct (MT_eq_dec _ mth) as [[T'' mth_eq] | mth_eq]; subst.
        repeat rewrite <- left_unit in H3.
        caseEq (eq_DType _ (proj1_sig T') T''); rewrite H4 in H3.
        destruct (H0 _ _ H2 H3) as [[v' [env' [Sigma' [ek'_eq WF_v'_T']]]] |
          [[] [env' [Sigma' [ek'_eq [WF_env'_Sigma' Sigma'_Cons]]]]]].
        destruct (ME_eq_dec' _ e' env) as [[v'' [env'' e'_eq]] | [env'' e'_eq]];
          subst.
        left; exists v'; exists env'; exists Sigma'; split; auto.
        unfold wbind; rewrite associativity, put_catch.
        unfold Value in *|-*; unfold wbind in e'_eq, ek'_eq; rewrite e'_eq, <- put_catch,
          catch_return, <- ek'_eq, associativity, e'_eq; auto.
        unfold Value in *|-*; unfold wbind in *|-*; rewrite associativity in ek'_eq;
          rewrite e'_eq in ek'_eq; rewrite <- associativity, bind_throw in ek'_eq.
        elimtype False; eapply Put_Exception_Disc with (a := v') (env' := env'') (env := env');
          eauto with typeclass_instances; unfold wbind; rewrite <- left_unit; eauto.
        destruct (ME_eq_dec' _ e' env) as [[v'' [env'' e'_eq]] | [env'' e'_eq]];
          subst.
        right; exists tt; exists env'; exists Sigma'; unfold wbind in *|-*; split; auto.
        unfold Value in *|-*; rewrite associativity, e'_eq in ek'_eq.
        rewrite associativity, put_catch, e'_eq, <- put_catch, catch_return; auto.
        unfold Value in *|-*; unfold wbind in *|-*; rewrite associativity, e'_eq, <- associativity in ek'_eq.
        rewrite rewrite_do with (m' := fun _ => throw tt) in ek'_eq.
        destruct (H1 tt Sigma' Sigma'_Cons T env' WF_env'_Sigma') as
          [[v'' [env''' [Sigma''' [ek''_eq WF_v''_T'']]]] |
            [[] [env''' [Sigma''' [ek''_eq [WF_env'''_Sigma''' Sigma'''_Cons]]]]]].
        rewrite <- H3.
        rewrite (rewrite_do) with (m' := fun U => kT U T'').
        rewrite (rewrite_do) with (m := fun U => return_ T' >>= _) (m' := fun U => kT U T').
        apply kt_eq; rewrite (eq_DType_eq _ _ _ H4); auto.
        apply functional_extensionality; intros; rewrite <- left_unit; auto.
        apply functional_extensionality; intros; rewrite <- left_unit; auto.
        left; exists v''; exists env'''; exists Sigma'''; split; auto.
        unfold wbind in *|-*; rewrite associativity, put_catch, e'_eq.
        rewrite (put_throw _ _ _ _ _ ek'_eq), <-put_catch, catch_throw',
          <- associativity; auto.
        right; exists tt; exists env'''; exists Sigma'''; repeat split; auto.
        unfold wbind in *|-*.
        unfold wbind in *|-*; rewrite associativity, put_catch, e'_eq.
        rewrite (put_throw _ _ _ _ _ ek'_eq), <-put_catch, catch_throw',
          <- associativity; auto.
        rewrite bind_throw; reflexivity.
        elimtype False; eapply FailMonad_Disc with (M := MT) (a := (proj1_sig T)) (mb := kT');
          eauto with typeclass_instances; unfold wbind;
            rewrite fmap_m in H3; rewrite <- associativity in H3;
              rewrite rewrite_do with (m' := fun _ : C => fail) in H3; auto;
                apply functional_extensionality; intros; repeat rewrite bind_fail; auto.
        rewrite <- left_unit in H3.
        elimtype False; eapply FailMonad_Disc with (M := MT) (a := (proj1_sig T)) (mb := kT');
          eauto with typeclass_instances; unfold wbind;
            rewrite fmap_m in H3; rewrite <- associativity in H3;
              rewrite rewrite_do with (m' := fun _ : C => fail) in H3; auto;
                apply functional_extensionality; intros; repeat rewrite bind_fail; auto.
        elimtype False; eapply FailMonad_Disc with (M := MT) (a := (proj1_sig T)) (mb := kT');
          eauto with typeclass_instances; unfold wbind;
            rewrite fmap_m in H3; rewrite <- associativity in H3;
              rewrite rewrite_do with (m' := fun _ : C => fail) in H3; auto;
                apply functional_extensionality; intros; repeat rewrite bind_fail; auto.
      Qed.

    End Except_State_Sound_WFVM_Except_Sec.

    Section Except_State_Sound_WFVM_Except_Sec2.
      (* Section with the other possible put_catch law. *)
      Context {put_catch' : forall (A : Set) (env : list (Value V)) e h,
        put env >>= (fun _ => catch (A := A) e h) =
        catch (put env >>= fun _ => e) (fun t => put env >>= fun _ => (h t))}.
      Context {Put_Exception_Disc :
        forall (A B : Set) (a : A) env env' n,
          (put env >>= fun _ => return_ a) <> put env' >>= fun _ => throw n}.

      Lemma put_catch'' : forall (A : Set) (env env' : list (Value V)) (e : ME A) h,
        catch (put env >>= fun _ => e) (fun t => put env' >>= fun _ => (h t)) =
        put env >> catch e (fun t => put env' >>= (fun _ => h t)).
      Proof.
        intros; generalize (put_put env env'); unfold wbind; intros put_put'.
        rewrite put_catch'.
        assert ((fun t : Datatypes.unit => put env' >>= (fun _ : Datatypes.unit => h t))
          = (fun t : Datatypes.unit =>
            put env >>=
            (fun _ : Datatypes.unit => put env' >>= (fun _ : Datatypes.unit => h t)))) as H
        by (apply functional_extensionality; destruct x; rewrite associativity, put_put'; auto).
        rewrite H; auto.
      Qed.

      Global Instance Except_State_Sound_WFVM_Except2 :
        iPAlgebra Except_State_Sound_Name Except_State_Sound_P (WFValueM_Except D V MT ME _).
      Proof.
        econstructor.
        unfold iAlgebra; intros; apply ind_alg_WFVM_Except with (Exception_ME := Exception_ME)
          (Fail_MT := Fail_MT) (eq_DType_DT := eq_DType_DT) (TypContextCE := DType_Env_CE _);
          try assumption; unfold Except_State_Sound_P; simpl; intros.
      (* throw case *)
        simpl; right; exists tt; exists env; exists Sigma; split; auto.
      (* catch case *)
        destruct (MT_eq_dec _ mte) as [[T' mte_eq] | mte_eq]; subst.
        destruct (MT_eq_dec _ mth) as [[T'' mth_eq] | mth_eq]; subst.
        repeat rewrite <- left_unit in H3.
        caseEq (eq_DType _ (proj1_sig T') T''); rewrite H4 in H3.
        destruct (H0 _ _ H2 H3) as [[v' [env' [Sigma' [ek'_eq WF_v'_T']]]] |
          [[] [env' [Sigma' [ek'_eq [WF_env'_Sigma' Sigma'_Cons]]]]]].
        destruct (ME_eq_dec' _ e' env) as [[v'' [env'' e'_eq]] | [env'' e'_eq]];
          subst.
        left; exists v'; exists env'; exists Sigma'; split; auto.
        unfold wbind; rewrite associativity, put_catch'.
        unfold Value in *|-*; unfold wbind in e'_eq, ek'_eq; rewrite e'_eq.
        rewrite put_catch'', catch_return, <- ek'_eq, associativity, e'_eq; auto.
        unfold Value in *|-*; unfold wbind in *|-*; rewrite associativity in ek'_eq;
          rewrite e'_eq in ek'_eq; rewrite <- associativity, bind_throw in ek'_eq.
        elimtype False; eapply Put_Exception_Disc with (a := v') (env' := env'') (env := env');
          eauto with typeclass_instances; unfold wbind; rewrite <- left_unit; eauto.
        destruct (ME_eq_dec' _ e' env) as [[v'' [env'' e'_eq]] | [env'' e'_eq]];
          subst.
        right; exists tt; exists env'; exists Sigma'; unfold wbind in *|-*; split; auto.
        unfold Value in *|-*; rewrite associativity, e'_eq in ek'_eq.
        rewrite associativity, put_catch', e'_eq, put_catch'', catch_return; auto.
        unfold Value in *|-*; unfold wbind in *|-*; rewrite associativity, e'_eq, <- associativity in ek'_eq.
        rewrite rewrite_do with (m' := fun _ => throw tt) in ek'_eq.
        destruct (H1 tt Sigma (fun _ _ => id) T env H2) as
          [[v'' [env''' [Sigma''' [ek''_eq WF_v''_T'']]]] |
            [[] [env''' [Sigma''' [ek''_eq [WF_env'''_Sigma''' Sigma'''_Cons]]]]]].
        rewrite <- H3.
        rewrite (rewrite_do) with (m' := fun U => kT U T'').
        rewrite (rewrite_do) with (m := fun U => return_ T' >>= _) (m' := fun U => kT U T').
        apply kt_eq; rewrite (eq_DType_eq _ _ _ H4); auto.
        apply functional_extensionality; intros; rewrite <- left_unit; auto.
        apply functional_extensionality; intros; rewrite <- left_unit; auto.
        left; exists v''; exists env'''; exists Sigma'''; split; auto.
        generalize put_put; unfold wbind; intros put_put'.
        unfold wbind in *|-*; rewrite associativity, put_catch', e'_eq,
          put_catch'', catch_throw'; unfold wbind; rewrite associativity,
            put_put', <- associativity; auto.
        right; exists tt; exists env'''; exists Sigma'''; repeat split; auto.
        generalize put_put; unfold wbind in *|-*; intros put_put'.
        unfold wbind in *|-*; rewrite associativity, put_catch', e'_eq,
          put_catch'', catch_throw'; unfold wbind; rewrite associativity,
            put_put', <- associativity; auto.
        rewrite bind_throw; auto.
        elimtype False; eapply FailMonad_Disc with (M := MT) (a := (proj1_sig T)) (mb := kT');
          eauto with typeclass_instances; unfold wbind;
            rewrite fmap_m in H3; rewrite <- associativity in H3;
              rewrite rewrite_do with (m' := fun _ : C => fail) in H3; auto;
                apply functional_extensionality; intros; repeat rewrite bind_fail; auto.
        rewrite <- left_unit in H3.
        elimtype False; eapply FailMonad_Disc with (M := MT) (a := (proj1_sig T)) (mb := kT');
          eauto with typeclass_instances; unfold wbind;
            rewrite fmap_m in H3; rewrite <- associativity in H3;
              rewrite rewrite_do with (m' := fun _ : C => fail) in H3; auto;
                apply functional_extensionality; intros; repeat rewrite bind_fail; auto.
        elimtype False; eapply FailMonad_Disc with (M := MT) (a := (proj1_sig T)) (mb := kT');
          eauto with typeclass_instances; unfold wbind;
            rewrite fmap_m in H3; rewrite <- associativity in H3;
              rewrite rewrite_do with (m' := fun _ : C => fail) in H3; auto;
                apply functional_extensionality; intros; repeat rewrite bind_fail; auto.
      Qed.

    End Except_State_Sound_WFVM_Except_Sec2.

    Context {Except_State_Sound_WFVM : iPAlgebra Except_State_Sound_Name Except_State_Sound_P WFVM'}.
    Context {eval_soundness'_Exp_E : forall (typeof_rec : UP'_F E -> typeofR D MT)
      (eval_rec : Names.Exp E -> evalMR V ME),
      P2Algebra ES'_ExpName E E E
      (UP'_P2
        (eval_soundness'_P D V E MT ME _ WFVM'
          Datatypes.unit E Fun_E
          (fun _ _ _ _ => True)
          tt typeof_rec eval_rec f_algebra
          (f_algebra (FAlgebra := evalM_E' (@Names.Exp E Fun_E)))))}.
    Context {WF_MAlg_typeof : WF_MAlgebra Typeof_E}.
    Context {WF_MAlg_eval : WF_MAlgebra evalM_E'}.

    Theorem eval_Except_State_Sound :
      forall (e : Exp E) Sigma (T : DType D)
        (env : list (Value V)),
        WF_Environment D V _ WFV' Sigma env Sigma ->
        fmap (@proj1_sig _ _) (typeof D E MT (proj1_sig e)) = return_ (proj1_sig T) ->
        (exists v : Value V, exists env', exists Sigma',
          (put env) >> evalM (evalM_E := evalM_E') V E ME (proj1_sig e) = put env' >> return_ (M := ME) v /\
          WFValueC D V _ WFV' Sigma' v T) \/
        (exists t, exists env', exists Sigma',
          put env >> evalM (evalM_E := evalM_E') V E ME (proj1_sig e) = put env' >> throw t
        /\ WF_Environment D V _ WFV' Sigma' env' Sigma'
        /\ (forall n T, lookup Sigma n = Some T -> lookup Sigma' n = Some T)).
    Proof.
      intros e Sigma.
      apply (ifold_ WFVM' _ (ip_algebra (iPAlgebra := Except_State_Sound_WFVM)) _
        (eval_State_soundness (eval_soundness'_Exp_E := eval_soundness'_Exp_E) _ _ _ MT ME WFVM' e Sigma)).
    Qed.

  End Except_State_Sound_Sec.

End ESoundES.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import Coq.Strings.String.
Require Import Coq.PArith.BinPos.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.String.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.HList.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.provers.DefaultProver.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.Subst.FMapSubst.
Require Import MirrorCore.Lambda.ExprLift.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.Lambda.ExprUnify_simul.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.ExprVariables.
Require Import Charge.ModularFunc.ILogicFunc.
Require Import Charge.Tactics.OrderedCanceller.
Require Import Charge.Tactics.BILNormalize.
Require Import Charge.Tactics.SynSepLog.
Require Import Charge.Tactics.SepLogFold.

Require Import Java.Tactics.Semantics.
Require Import Java.Func.JavaType.
Require Import Java.Func.JavaFunc.

Require Import Charge.ModularFunc.BILogicFunc.

Require Import Charge.Tactics.Rtac.ReifyLemma.

Require Import Charge.Tactics.Rtac.PullConjunct.

Require Import MirrorCore.Reify.Reify.

Require Import Java.Func.Reify.

Require Import Charge.Tactics.Rtac.Subst.

Require Import Java.Language.Lang.
Require Import Java.Language.Program.

Require Import Charge.Tactics.Rtac.Apply.
Require Import Charge.Tactics.Rtac.Cancellation.
Require Import Charge.Tactics.Rtac.Intro.
Require Import Charge.Tactics.Rtac.EApply.
Require Import Charge.Tactics.Rtac.Instantiate.

Require Import Coq.Arith.Peano_dec.

Fixpoint mkStars n P Q : expr typ func :=
	match n with
		| 0 => mkStar tySasn P Q
		| S n => mkStar tySasn (mkStars n P Q) (mkStars n P Q)
	end.

Definition cancelTest n :=
      mkForall tySasn tyProp
      (mkForall tySasn tyProp
          (mkEntails tySasn (mkStars n (Var 0) (Var 1)) (mkStars n (Var 1) (Var 0)))).

Section blurb.

Context {fs : Environment}.

Time Eval vm_compute in typeof_expr nil nil (cancelTest 10).
Check THEN.
Check runOnGoals.
Time Eval vm_compute in
	(THEN (REPEAT 10 (INTRO typ func))
	(runOnGoals (CANCELLATION typ func tySasn is_pure)))
		nil nil 0 0 (CTop nil nil) (ctx_empty (expr := expr typ func)) (cancelTest 10).

Fixpoint search_NoDup
    {A} (A_dec: forall a b: A, {a=b}+{a=b->False}) (l: list A) : option (NoDup l) :=
  match l with
  | nil => Some (NoDup_nil A)
  | a::l' =>
      match search_NoDup A_dec l' with
      | Some nodup =>
          match In_dec A_dec a l' with
          | left isin => None
          | right notin =>
 			match search_NoDup A_dec l' with
 				| Some pf => Some (NoDup_cons _ notin pf)
 				| None => None
            end
          end
      | None => None
      end
  end.
(*

Definition list_notin_set lst s :=
  	fold_right (fun a acc => andb (SS.for_all (fun b => negb (string_dec a b)) s) acc) true lst.

Definition method_specI : stac typ (expr typ func) subst :=
  fun tus tvs s lst e =>
    match e with
    	| mkEntails [l, mkProgEq [mkProg [P]], mkMethodSpec [C, m, mkVarList [args], mkString [r], p, q]] =>
    	      match C, m with
    	        | Inj (inl (inr (pString Cname))), Inj (inl (inr (pString Mname))) =>
    	          match SM.find Cname (p_classes P) with
    	          	| Some Class =>
    	          	  match SM.find Mname (c_methods Class) with
    	          	    | Some Method =>
						  match search_NoDup Coq.Strings.String.string_dec args with
						  	| Some pf =>
						  	  match eq_nat_dec (length args) (length (m_params Method)) with
						  	    | left pf' =>
						  	      if list_notin_set args (modifies (m_body Method)) then
						  	        More tus tvs s lst
						  	        mkEntails [l, mkProgEq [mkProg [P]],
						  	                      mkTriple [mkApplyTruncSubst [tyAsn, p, mkSubstList [mkVarList [args], mkExprList [map E_var (m_params Method)]] ], mkCmd [m_body Method],
						  	                               mkApplyTruncSubst [tyAsn, q, mkSubstList [mkVarList [r::args], mkConsExprList [App fEval (mkExpr [m_ret Method]), mkExprList[map E_var (m_params Method)]]] ]]]
						  	      else
						  	        @Fail _ _ _
						  	    | right _ => @Fail _ _ _
						  	  end
						  	| None => @Fail _ _ _
						  end
    	          	    | None => @Fail _ _ _
    	          	  end
    	          	| None => @Fail _ _ _
    	          end
    	        | _, _ => @Fail _ _ _
    	      end
      	| _ => @Fail _ _ _
    end.
*)

(** Skip **)
Definition skip_lemma : lemma typ (expr typ func) (expr typ func).
reify_lemma reify_imp rule_skip.
Defined.
Print skip_lemma.

Lemma skip_lemma_sound :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil skip_lemma.
Proof.
  unfold lemmaD; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
  apply rule_skip. apply H.
Qed.

Example test_skip_lemma : test_lemma skip_lemma. Admitted.

Definition skip_lemma2 : lemma typ (expr typ func) (expr typ func).
reify_lemma reify_imp rule_skip2.
Defined.
Print skip_lemma2.

Example test_skip_lemma2 : test_lemma skip_lemma2. Admitted.

Definition seq_lemma (c1 c2 : cmd) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_seq c1 c2).
Defined.
Print seq_lemma.

Lemma seq_lemma_sound c1 c2 :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (seq_lemma c1 c2).
Proof.
  unfold lemmaD; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
  eapply rule_seq; [apply H | apply H0].
Qed.

Example test_seq_lemma (c1 c2 : cmd) : test_lemma (seq_lemma c1 c2). Admitted.

Definition if_lemma (e : dexpr) (c1 c2 : cmd) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_if e c1 c2).
Defined.

Require Import ExtLib.Tactics.
(*
Lemma if_lemma_sound e c1 c2 :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (if_lemma e c1 c2).
Proof.
  remember (exprD nil nil (evalDExpr e) tyExpr).
  Check rule_if.
  unfold lemmaD; simpl.
  unfold lemmaD', exprD'_typ0.
  unfold le
  unfold if_lemma.
  destruct o.
  unfold exprD in Heqo. simpl in Heqo.
  remember (ExprDsimul.ExprDenote.exprD' nil nil tyVal (evalDExpr e)).
  destruct o; inv_all; subst; try congruence.
  unfold lemmaD, lemmaD', exprD'_typ0, ExprDsimul.ExprDenote.exprD'; simpl in *; intros.
 unfold ExprDsimul.ExprDenote.exprD' in *; simpl in *; intros.
 unfold exprT_App, exprT_Inj, Rcast_val, Rcast in *; simpl in *.
 unfold OpenFunc.typ2_cast_bin, OpenFunc.typ3_cast_bin in *; simpl in *.
 unfold exprT, OpenT in *; simpl in *.
 rewrite <- Heqo0.
 unfold ExprDsimul.ExprDenote.exprD' in Heqo0. simpl in Heqo0.
 rewrite <- Heqo0.
 repeat red.
 setoid_rewrite <- Heqo.
 rewrite <- Heqo.
    unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
    eapply rule_if; [eapply H | eapply H0].
  + unfold lemmaD; simpl; intros.
    unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
    eapply rule_if; [eapply H | eapply H0].
  + unfold lemmaD; simpl; intros.
    unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
    eapply rule_if; [eapply H | eapply H0].

  Print if_lemma.
  vm_compute.
  unfold lemmaD'. simpl.
  unfold exprD'_typ0. simpl.
  unfold ExprDsimul.ExprDenote.exprD'.
  simpl.
  unfold if_lemma. simpl.
  apply rule_skip. apply H.
Qed.
*)
Example test_if_lemma e (c1 c2 : cmd) : test_lemma (if_lemma e c1 c2). Admitted.

Definition read_lemma (x y : var) (f : field) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_read_fwd x y f).
Defined.

Lemma read_lemma_sound x y f :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (read_lemma x y f).
Proof.
  (*
  unfold lemmaD; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast, OpenFunc.typ3_cast_bin, OpenFunc.typ2_cast_bin, eq_rect_r in * ; simpl in *.
  eapply rule_read_fwd; [eapply H | eapply H0].
  *)
  admit.
Qed.

Example test_read_lemma x y f : test_lemma (read_lemma x y f). Admitted.

Set Printing Width 140.

Definition write_lemma (x : var) (f : field) (e : dexpr) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_write_fwd x f e).
Defined.
(*
Lemma write_lemma_sound x f e :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (write_lemma x f e).
Proof.
  induction e.
  Check evalDExpr.
  unfold lemmaD, lemmaD'; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast, OpenFunc.typ3_cast_bin, OpenFunc.typ2_cast_bin, eq_rect_r,
  fPointsto, typ2_cast_bin, BaseFunc.mkString; simpl.
  unfold exprD'_typ0; simpl.
  unfold ExprDsimul.ExprDenote.exprD'; simpl.
  vm_compute.
  eapply rule_write_fwd; [eapply H | eapply H0].
Qed.
*)

Example test_write_lemma x f e : test_lemma (write_lemma x f e). Admitted.

Definition assign_lemma (x : var) (e : dexpr) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_assign_fwd x e).
Defined.
Print assign_lemma.
Example test_assign_lemma x e : test_lemma (assign_lemma x e). Admitted.

Definition alloc_lemma (x : var) (C : class) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_alloc_fwd x C).
Defined.
Example test_alloc_lemma x C : test_lemma (alloc_lemma x C). Admitted.

Definition pull_exists_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@pull_exists val).
Defined.
Example test_pull_exists_lemma : test_lemma pull_exists_lemma. Admitted.
Eval vm_compute in pull_exists_lemma.

Definition ent_exists_right_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@ent_left_exists val).
Defined.
Example test_pull_exists_lemma2 : test_lemma ent_exists_right_lemma. Admitted.

Definition eq_to_subst_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp eq_to_subst.
Defined.
Eval vm_compute in eq_to_subst_lemma.
Example test_eq_lemma : test_lemma (eq_to_subst_lemma). Admitted.
Check rule_static_complete.
Definition scall_lemma (x : Lang.var) (C : class) (m : string) (es : list dexpr)
  : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp rule_static_complete.
Qed.

Print scall_lemma.

Print pull_exists_lemma.

Example test_pull_exists : test_lemma (pull_exists_lemma). Admitted.

Require Import Charge.ModularFunc.BaseFunc.

Require Import ExtLib.Tactics.

Require Import Charge.ModularFunc.ListFunc.

Require Import MirrorCore.Lambda.ExprTac.
(*

  Lemma foldTacOk : partial_reducer_ok foldTac.
  Proof.
    unfold partial_reducer_ok; intros.
    unfold foldTac.
    remember (listS e); destruct o; [| exists val; tauto].
    destruct l; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct e2; try (exists val; tauto).
    destruct f; try (exists val; tauto).

    destruct j; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct e; simpl in Heqo; try congruence.
    destruct f; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    inv_all; subst.
    autorewrite with exprD_rw in H; simpl in H; forward; inv_all; subst.
    autorewrite with exprD_rw in H; simpl in H; forward; inv_all; subst; [|apply _].
    autorewrite with exprD_rw in H; simpl in H; forward; inv_all; subst; [|apply _].
    autorewrite with exprD_rw in H0; simpl in H0; forward; inv_all; subst; [|apply _].
    autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst; [|apply _].
    unfold funcAs in H2.
    Opaque type_cast.
    simpl in H2. forward; inv_all; subst. red in r. inv_all.
    inversion r; subst.
    rewrite (UIP_refl r) in H4. unfold Rcast in H4; simpl in H4.
    inversion H4; unfold eq_rect_r in H6; simpl in H6.
    subst. clear H4.
    clear H2 r.
    Opaque beta.
    simpl.
    unfold exprT_App, eq_rect_r. simpl.
    cut (exists val' : exprT tus tvs (typD t),
  ExprDsimul.ExprDenote.exprD' tus tvs t
    (fold_right
       (fun (x : string) (acc : expr typ func) =>
        beta (beta (App (App e0 (mkString x)) acc))) e1 l) = Some val' /\
  (forall (us : hlist typD tus) (vs : hlist typD tvs),
   fold_right (e4 us vs) (e3 us vs) (exprT_Inj tus tvs l us vs) = val' us vs)).
   intros [? [? ?]].
   eexists; split; [eassumption | intros; apply H4].
    induction l; simpl; intros.

    + exists e3; tauto.
    + destruct IHl as [? [? ?]].
      eexists; split; [|intros; reflexivity].

  Lemma exprD'_remove_beta tus tvs t e de (H : exprD' tus tvs e t = Some de) :
    exprD' tus tvs (beta e) t = Some de.
  Proof.
    pose proof (beta_sound tus tvs e t).
    unfold exprD' in *. simpl in *. forward; inv_all; subst.
	Require Import FunctionalExtensionality.
	f_equal. symmetry.
    apply functional_extensionality; intros.
    apply functional_extensionality; intros.
    apply H2.
  Qed.

      do 2 (apply exprD'_remove_beta).
      unfold exprD'. simpl.

      red_exprD; [|apply _].
      pose proof (exprD_typeof_Some).
      specialize (H5  _ _ _ _ _ _ _ _ _ _ _ _ _ H2). rewrite H5; clear H5.
      red_exprD; [|apply _].
      forward; inv_all; subst.
      unfold mkString. forward.
      red_exprD; [|apply _].
      Transparent type_cast.
      unfold funcAs. simpl.
	  f_equal. unfold exprT_App; simpl.
	  unfold eq_rect_r. simpl.
	  apply functional_extensionality; intros.
	  apply functional_extensionality; intros.
	  rewrite H4. reflexivity.
Qed.
SearchAbout partial_reducer_ok.

Print partial_reducer_ok.
Print apps_reducer.
Print full_reducer_ok.
Print full_reducer.
Check @idred.
SearchAbout idred.
Print idred.
Print idred'.
Check @beta_all.

Definition FOLD := SIMPLIFY (typ := typ) (fun _ _ _ _ => (beta_all (fun _ => foldTac))).

Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Lambda.RedAll.
Print partial_reducer.

(*
  Lemma foldTacOk2 : partial_reducer_ok foldTac.
  Proof.
    unfold full_reducer_ok; intros.
    Print var_termsP.
    Print partial_reducer_ok.
    unfold exprT, OpenT in P.
    unfold foldTac.
    remember (listS e). destruct o.
    Focus 2.
    simpl.
  Qed.
*)
Lemma FOLD_sound : rtac_sound FOLD.
Proof.
  admit.
  (*
  unfold FOLD.
  apply SIMPLIFY_sound.
  intros; simpl.
  forward.
  rewrite <- H.
  simpl.
  unfold Ctx.propD, exprD'_typ0 in H3; forward; inv_all; subst.
  destruct (beta_all_sound foldTacOk _ _ e0 H3) as [v [H4 H5]].
  apply beta_all_sound.
  Check beta_all_sound.
  (* beta_all_sound is missing *)

  *)
Qed.

*)

Check apps.
Definition BETA := SIMPLIFY (typ := typ) (fun _ _ _ _ => beta_all (fun _ => @apps typ func)).

Lemma BETA_sound : rtac_sound BETA.
Proof.
  unfold BETA.
  apply SIMPLIFY_sound.
  intros; simpl; forward.
  (*
  SearchAbout full_reducer.
  assert (full_reducer_ok (fun _ => apps (sym := func))). {
    clear.
    intros e vars tus tvs tus' tvs' P Hvars es t targs Hexpr.
  }
  unfold full_reducer_ok.

  Print full_reducer.
  pose proof (beta_all_sound).
  SearchAbout beta_all.
  rewrite <- H.*)
  admit.
Qed.

Definition THEN' := @MirrorCore.RTac.Then.THEN typ (expr typ func).
Require Import Charge.Tactics.Rtac.Minify.

Let EAPPLY lem := THEN' (EAPPLY typ func lem) (MINIFY typ func).

Definition THEN (r1 r2 : rtac typ (expr typ func)) :=
  THEN (THEN (THEN (INSTANTIATE typ func) (runOnGoals r1)) (runOnGoals (INSTANTIATE typ func))) (runOnGoals r2).

Check SUBST.

Definition EQSUBST := THEN (EAPPLY eq_to_subst_lemma) (SUBST (ilp := ilp) (bilp := bilp) typ func).

(*
Notation "'ap_eq' '[' x ',' y ']'" :=
	 (ap (T := Fun stack) (ap (T := Fun stack) (pure (T := Fun stack) (@eq val)) x) y).
*)

Require Import Charge.ModularFunc.OpenFunc.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.EmbedFunc.

Definition match_ap_eq (e : expr typ func) : bool :=
	match e with
	  | App emb (App (App f (App (App g (App h e)) x)) y) =>
	  	match embedS emb, open_funcS f, open_funcS g, open_funcS h, baseS e with
	  		| Some (eilf_embed _ _), Some (of_ap _ _), Some (of_ap _ _), Some (of_const _), Some (pEq _) => true
	  		| _, _, _, _, _ => false
	  	end
	  | _ => false
	end.
Check @PULLCONJUNCTL.
Instance notehu : RelDec (@eq (expr typ func)).
apply RelDec_eq_expr.
apply _.
apply _.
split.
a

Definition PULLEQL := @PULLCONJUNCTL typ func RType_typ _ _ _ match_ap_eq _ _ _.

                        (*
	THEN (INSTANTIATE typ func subst) (runOnGoals (THEN (THEN (TRY FIELD_LOOKUP)
		(runOnGoals (CANCELLATION typ func subst tySpec (fun _ => false)))) (runOnGoals FOLD))) ::
		solve_entailment :: nil).
	           *)
Require Import Charge.SetoidRewrite.AutoSetoidRewrite.
Require Import Charge.SetoidRewrite.Base.
Require Import Charge.SetoidRewrite.ILSetoidRewrite.
Require Import Charge.SetoidRewrite.BILSetoidRewrite.

  Definition spec_respects (e : expr typ func) (_ : list (RG (expr typ func)))
	   (rg : RG (expr typ func)) : m (expr typ func) :=
	   match e with
	     | Inj (inr pTriple) =>
	       rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
	         (RGrespects (RGflip (RGinj (fEntails tySasn)))
	           (RGrespects (RGinj (fEq tyCmd))
	             (RGrespects (RGinj (fEntails tySasn))
	               (RGinj (fEntails tySpec))))))
	         (fun _ => rg_ret fTriple)
	     | _ => rg_fail
	   end.

Definition step_unfold vars rw :=
  setoid_rewrite vars _ (fEntails : typ -> expr typ func) rw
    (sr_combine il_respects
               (sr_combine (@il_respects_reflexive typ func _ _ _ ilops _ _)
                                        (sr_combine bil_respects
                                                    (sr_combine eq_respects
                                                    (sr_combine spec_respects refl)))))
    (fun _ => rw_fail).

  Definition STEP_REWRITE rw : rtac typ (expr typ func) :=
    fun tus tvs lus lvs c s e =>
      match step_unfold (getVars c) rw tyProp e with
        | Some (e', _) => More s (GGoal e')
        | _ => More s (GGoal e)
      end.

Definition PULL_TRIPLE_EXISTS : rtac typ (expr typ func) :=
  THEN (THEN (EAPPLY pull_exists_lemma) (INTRO typ func)) BETA.

Definition solve_entailment (rw : rewriter (typ := typ) (func := func)) : rtac typ (expr typ func) :=
	THEN (INSTANTIATE typ func)
		(FIRST (SOLVE (CANCELLATION typ func tySasn is_pure) ::
	           (THEN (THEN (THEN (THEN PULLEQL (REPEAT 1000 EQSUBST))
	           (STEP_REWRITE rw)) (REPEAT 1000 (INTRO typ func)))
	              (CANCELLATION typ func tySasn is_pure)::
	           nil))).

Definition solve_alloc rw : rtac typ (expr typ func) :=
    THEN (INSTANTIATE typ func)
    (FIRST (SOLVE (CANCELLATION typ func tySpec (fun _ => false)) ::
                        FIELD_LOOKUP ::
                        THEN FOLD (solve_entailment rw) :: nil)).

Definition simStep (rw : rewriter (typ := typ) (func := func)) (r : rtac typ (expr typ func)) :=
    THEN (THEN (THEN (THEN (SUBST typ func)
    	(TRY PULL_TRIPLE_EXISTS)) (STEP_REWRITE rw)) (REPEAT 10 PULL_TRIPLE_EXISTS)) r.

Fixpoint tripleE (c : cmd) rw : rtac typ (expr typ func) :=
	match c with
	    | cskip => simStep rw (THEN (EAPPLY skip_lemma) (solve_entailment rw))
	    | calloc x C => simStep rw (THEN (EAPPLY (alloc_lemma x C))
	        (FIRST (solve_alloc rw::solve_entailment rw::nil)))
		| cseq c1 c2 => simStep rw (THEN' (EAPPLY (seq_lemma c1 c2))
		    (THENK (runOnGoals (TRY (tripleE c1 rw))) (THENK (MINIFY typ func) (runOnGoals (tripleE c2 rw)))))
		| cassign x e => simStep rw (THEN (EAPPLY (assign_lemma x e)) (solve_entailment rw))
		| cread x y f => simStep rw (THEN (EAPPLY (read_lemma x y f)) (solve_entailment rw))
		| cif e c1 c2 => simStep rw (THEN (EAPPLY (if_lemma e c1 c2)) (solve_entailment rw))
		| cwrite x f e => simStep rw (THEN (EAPPLY (write_lemma x f e)) (solve_entailment rw))
		| _ => IDTAC
	end.

Definition symE rw : rtac typ (expr typ func) :=
	(fun tus tvs n m ctx s e =>
		(match e return rtac typ (expr typ func) with
			| App (App (Inj f) G) H =>
			  match ilogicS f, H with
			  	| Some (ilf_entails tySpec), (* tySpec is a pattern, should be checked for equality with tySpec *)
			  	  App (App (App (Inj (inr pTriple)) P) Q) (Inj (inr (pCmd c))) =>
			  	  	tripleE c rw
			  	| _, _ => FAIL
			  end
			| _ => FAIL
		end) tus tvs n m ctx s e).

Definition runTac rw :=
   (THEN (THEN (REPEAT 1000 (INTRO typ func)) (symE rw))
	(INSTANTIATE typ func)).

Lemma runTac_sound rw : rtac_sound (runTac rw).
Proof.
  admit.
Qed.

Definition mkPointsto (x : expr typ func) (f : field) (e : expr typ func) : expr typ func :=
   mkAp tyVal tyAsn
        (mkAp tyString (tyArr tyVal tyAsn)
              (mkAp tyVal (tyArr tyString (tyArr tyVal tyAsn))
                    (mkConst (tyArr tyVal (tyArr tyString (tyArr tyVal tyAsn)))
                             fPointsto)
                    x)
              (mkConst tyString (mkString f)))
        e.

Require Import Java.Semantics.OperationalSemantics.
Require Import Java.Logic.SpecLogic.
Require Import Java.Logic.AssertionLogic.
Require Import Java.Examples.ListClass.
Require Import Charge.Logics.ILogic.

Fixpoint seq_skip n :=
	match n with
	  | 0 => cskip
	  | S n => cseq cskip (seq_skip n)
	end.

Require Import ExtLib.Structures.Applicative.
Local Instance Applicative_Fun A : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

Definition testSkip n : Prop :=
  forall (G : spec) (P : sasn), G |-- triple P P (seq_skip n).

Lemma INTRO_sound : rtac_sound (INTRO typ func).
Proof.
  admit.
Qed.

Require Import Java.Tactics.Tactics.
Check IDTAC_sound.

Ltac rtac_result reify term_table tac :=
	  let name := fresh "e" in
	  match goal with
	    | |- ?P =>
	      reify_aux reify term_table P name;
	      let t := eval vm_compute in (typeof_expr nil nil name) in
	      let goal := eval unfold name in name in
	      match t with
	        | Some ?t =>
	          let goal_result := constr:(run_tac tac (GGoal name)) in
	          let result := eval vm_compute in goal_result in
	          idtac result
	        | None => idtac "expression " goal "is ill typed" t
	      end
	  end.

Lemma test_skip_lemma3 : testSkip 10.
Proof.
  idtac "start".
  unfold testSkip; simpl.

  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Time Qed.

Definition test_alloc : expr typ func :=
	mkEntails tySpec (mkProgEq (mkProg ListProg))
		(mkTriple (mkTrue tySasn) (mkCmd (cseq (calloc "x" "NodeC") cskip)) (mkFalse tySasn)).

Require Import Charge.Logics.BILogic.

  Lemma test_alloc_correct :
  prog_eq ListProg |-- triple empSP lfalse ((calloc "x" "NodeC");;Skip).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
  unfold open_func_symD. simpl.
  admit.
Qed.

Lemma test_read : ltrue |--
    triple
      (ap_pointsto [("o": var), ("f" : field), pure (T := Fun (Lang.stack)) (vint 3)] **
       ap_pointsto [("o": var), ("g" : field), pure (T := Fun (Lang.stack)) (vint 4)])
      (ap_pointsto [("o": var), ("f": field), pure (T := Fun (Lang.stack)) (vint 3)] **
      (ap_pointsto [("o": var), ("g": field), pure (T := Fun (Lang.stack)) (vint 4)]))
      (cseq (cread "x" "o" "f") (cseq (cread "y" "o" "g") cskip)).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Qed.

Lemma test_write :
	ltrue |--
	triple
      (ap_pointsto [("o": var), ("f" : field), pure (T := Fun (Lang.stack)) (vint 3)])
      (ap_pointsto [("o": var), ("f": field), pure (T := Fun (Lang.stack)) (vint 4)])
      (cseq (cwrite "o" "f" (E_val (vint 4))) cskip).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Qed.

Require Import BinInt.

Fixpoint mkSwapPre n : sasn :=
	match n with
	  | 0   => empSP
	  | S n => ap_pointsto [("o": Lang.var), (append "f" (nat2string10 n) : field),
	  	                     (eval (E_val (vint (Z.of_nat n))))] **
	           mkSwapPre n
	end.

Fixpoint mkSwapPostAux n m :=
  match n with
    | 0 => empSP
	| S n => ap_pointsto [("o": Lang.var), (append "f" (nat2string10 n) : field),
	  	                     (eval (E_val (vint (Z.of_nat (m - (S n))))))] **
	         mkSwapPostAux n m
  end.

Definition mkSwapPost n := mkSwapPostAux n n.

Fixpoint mkRead n c :=
	match n with
	  | 0 => c
	  | S n => cseq (cread ((append "x" (nat2string10 n):Lang.var)) ("o":Lang.var) ((append "f" (nat2string10 n)):field))
	                (mkRead n c)
    end.

Fixpoint mkWriteAux n m c :=
	match n with
	  | 0 => c
	  | S n => cseq (cwrite ("o":Lang.var) (append "f" (nat2string10 n)) (E_var (append "x" (nat2string10 (m - (S n))))))
	                (mkWriteAux n m c)
    end.

Definition mkWrite n c := mkWriteAux n n c.

Definition mkSwapProg (n : nat) (c : cmd) := mkRead n (mkWrite n c).

Definition mkSwap n :=
	ltrue |-- triple (mkSwapPre n) (mkSwapPost n) (mkSwapProg n cskip).

Set Printing Depth 100.

  Opaque ap.

Lemma test_swap :
|--
( {[ap_pointsto  ["o", ("f")%string, eval (E_val (vint 5))] **
    ap_pointsto  ["o", ("g")%string, eval (E_val (vint 6))] ** empSP]}
 ("x")%string R= "o" [("f")%string];;
 ("y")%string R= "o" [("g")%string];;
 "o" [("f")%string] W= E_var ("y")%string;;
 "o" [("g")%string] W=E_var ("x")%string;; Skip
 {[ap_pointsto  ["o", ("f")%string, eval (E_val (vint 6))] **
   ap_pointsto  ["o", ("g")%string, eval (E_val (vint 5))] ** empSP]} ).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Qed.

Lemma test_skip_lemma4 : testSkip 10.
Proof.
  unfold testSkip; simpl.

  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Time Qed.

Print rtac_sound.
Print rtac_spec.

Lemma test_swap2 : mkSwap 20.
Proof.
  unfold mkSwap, mkSwapPre, mkSwapPost, mkSwapProg, mkSwapPostAux, mkRead, mkWrite, mkWriteAux.

  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Time Qed.

End blurb.

Instance EmptyEnv : Environment := {
  java_env := SymEnv.from_list nil
}.

Definition ASSUMPTION : rtac typ (expr typ func) :=
  EASSUMPTION (fun _ _ _ _ x y s => if x ?[ eq ] y then Some s else None).

Lemma ASSUMPTION_sound : rtac_sound ASSUMPTION.
Proof.
  admit.
Qed.

Ltac rtac_derive_soundness :=
  repeat first [ eapply IDTAC_sound
               | eapply ASSUMPTION_sound
               | eapply FAIL_sound
               | eapply INSTANTIATE_sound
               | eapply INTRO_sound
               | eapply FIRST_sound ; Forall_rtac_derive_soundness
               | eapply SOLVE_sound ; rtac_derive_soundness
               | eapply THEN_sound ;
                 [ rtac_derive_soundness
                 | rtacK_derive_soundness ]
               | eapply TRY_sound ; rtac_derive_soundness
               | eapply REPEAT_sound ; rtac_derive_soundness
               | eapply AT_GOAL_sound ; [ intros ; rtac_derive_soundness ]
               | eapply APPLY_sound ; [ simpl ] (* TODO(gmalecha): Needs to change *)
               | eapply EAPPLY_sound ; [ simpl ]  (* TODO(gmalecha): Needs to change *)
               ]
with rtacK_derive_soundness :=
  first [ solve [eauto]
        | eapply runOnGoals_sound ; rtac_derive_soundness
        ]
with Forall_rtac_derive_soundness :=
  repeat first [
                 eapply Forall_nil
               | eapply Forall_cons ;
                 [ try rtac_derive_soundness
                 | try Forall_rtac_derive_soundness ] ].

Lemma LTrue : True.
Proof.
  apply I.
Qed.

Definition true_lemma : lemma typ (expr typ func) (expr typ func).
reify_lemma reify_imp LTrue.
Defined.
Print true_lemma.
(*
true_lemma =
{| vars := nil; premises := nil;
  concl := Inj (inl (inl (inl (inl (inl (inl (inl (inr (ilf_true tyProp))))))))) |}
     : lemma typ (expr typ func) (expr typ func)
*)
Lemma true_lemma_sound :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil true_lemma.
Proof.
  compute.
  apply LTrue.
Qed.

Definition AUTO := APPLY typ func true_lemma.

Lemma AUTO_sound : rtac_sound AUTO.
Proof.
  admit.
Qed.

Lemma test_true : True.
Proof.
  run_rtac reify_imp term_table AUTO_sound.
Qed.

Print test_true.

(*

test_true =
let tbl := FMapPositive.PositiveMap.Leaf (SymEnv.function RType_typ) in
let e := mkTrue tyProp in
run_rtac_Solved AUTO (TopSubst (expr typ func) nil nil) e AUTO_sound
  (eq_refl<:run_tac AUTO (GGoal (mkTrue tyProp)) = Solved (TopSubst (expr typ func) nil nil))
     : True

*)

Lemma andI (P Q : Prop) (HP : P) (HQ : Q) : P /\ Q.
Proof.
  tauto.
Qed.

Definition andI_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp andI.
Defined.
Print andI_lemma.
Lemma andI_lemma_sound :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil andI_lemma.
Proof.
  compute. intros. apply andI. assumption. assumption.
Qed.

Definition AUTO' :=
  THEN (REPEAT 10 (INTRO typ func))
    (FIRST (THEN (APPLY typ func andI_lemma) ASSUMPTION ::
      (APPLY typ func true_lemma) :: ASSUMPTION :: nil)).

Lemma AUTO'_sound : rtac_sound AUTO'.
Proof.
  unfold AUTO'.
  rtac_derive_soundness.
  admit.
  admit.
Qed.

Lemma test_and : forall (P Q R : Prop), Q -> P -> R -> P /\ Q.
Proof.
  run_rtac reify_imp term_table AUTO'_sound.
Qed.

Print test_and.

Lemma orI1 (P Q : Prop) (HP : P) : P \/ Q.
Proof.
  tauto.
Qed.

Lemma orI2 (P Q : Prop) (HQ : Q) : P \/ Q.
Proof.
  tauto.
Qed.

Definition orI1_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp orI1.
Defined.

Definition orI2_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp orI2.
Defined.

Lemma orI1_lemma_sound :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil orI1_lemma.
Proof.
  compute. intros. apply orI1. assumption.
Qed.

Lemma orI2_lemma_sound :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil orI1_lemma.
Proof.
  compute. intros. apply orI1. assumption.
Qed.

Definition AUTO'' :=
  REC 20
    (fun rec => THEN (REPEAT 10 (INTRO typ func))
      (FIRST
        (THEN (APPLY typ func andI_lemma) rec ::
        (THEN (APPLY typ func orI1_lemma) rec) ::
        (THEN (APPLY typ func orI2_lemma) rec) ::
        (APPLY typ func true_lemma) :: ASSUMPTION :: nil)))
    FAIL.

Lemma AUTO''_sound : rtac_sound AUTO''.
Proof.
  unfold AUTO''.
  (* rtac_derive_soundness. *)
  admit.
Qed.

Lemma test_and2 : forall (P Q R T : Prop),
	 Q -> P -> R -> (P /\ Q /\ R) \/
	    (Q /\ T /\ (R /\ R) /\ (P /\ Q) /\ Q).
Proof.
  run_rtac reify_imp term_table AUTO''_sound.
Qed.
(*
Ltac run_rtac reify term_table tac_sound :=
  match type of tac_sound with
    | rtac_sound ?tac =>
	  let name := fresh "e" in
	  match goal with
	    | |- ?P =>
	      reify_aux reify term_table P name;
	      let t := eval vm_compute in (typeof_expr nil nil name) in
	      let goal := eval unfold name in name in
	      match t with
	        | Some ?t =>
	          let goal_result := constr:(run_tac tac (GGoal name)) in
	          let result := eval vm_compute in goal_result in
	          match result with
	            | More_ ?s ?g =>
	              cut (goalD_Prop nil nil g); [
	                let goal_resultV := g in
	               (* change (goalD_Prop nil nil goal_resultV -> exprD_Prop nil nil name);*)
	                exact_no_check (@run_rtac_More _ tac _ _ _ tac_sound
	                	(@eq_refl (Result (CTop nil nil)) (More_ s goal_resultV) <:
	                	   run_tac tac (GGoal goal) = (More_ s goal_resultV)))
	                | cbv_denote
	              ]
	            | Solved ?s =>
	              exact_no_check (@run_rtac_Solved _ tac s name tac_sound
	                (@eq_refl (Result (CTop nil nil)) (Solved s) <: run_tac tac (GGoal goal) = Solved s))
	            | Fail => idtac "Tactic" tac "failed."
	            | _ => idtac "Error: run_rtac could not resolve the result from the tactic :" tac
	          end
	        | None => idtac "expression " goal "is ill typed" t
	      end
	  end
	| _ => idtac tac_sound "is not a soudness theorem."
  end.
  *)
Require Import Charge.Tactics.Rtac.PullQuant.

Lemma PULL_EXISTSL_sound : rtac_sound (THEN (REPEAT 10 (INTRO typ func)) (PULL_EXISTSL typ func ilops)).
Proof.
  admit.
Qed.

Lemma test_pull_quant_left  (P : sasn) (Q : nat -> sasn) :
  P //\\ (Exists x : nat, Q x) |-- P.
Proof.
  run_rtac reify_imp term_table PULL_EXISTSL_sound.

  Print func.


Require Import Relations.Relation_Operators.
Require Import RelationClasses.

Require Import Automation.
Require Import Prog.

(** Here we prove some basic sanity checks on prog and its semantics. *)

Local Hint Constructors exec.

Theorem can_crash_at_begin : forall `(p: prog T) w,
    can_crash ->
    exec p w (Crashed w).
Proof.
  eauto.
Qed.

Theorem can_crash_at_end : forall `(p: prog T) w v w',
    can_crash ->
    exec p w (Finished v w') ->
    exec p w (Crashed w').
Proof.
  (* This is a slightly harder proof strategy (induction over the programs is
  more straightforward), but this proof doesn't require finite programs! *)
  intros.
  remember (Finished v w').
  induction H0;
    try match goal with
        | [ H: _ = Finished _ _ |- _ ] =>
          inversion H; subst; clear H
        end; eauto.
Qed.

Local Hint Resolve can_crash_at_begin can_crash_at_end.

(** These are the monad laws

TODO: explain what the monad is and what these monad laws mean (specifically,
we're proving that exec treats programs up to the monad laws as equivalences
between programs).
 *)

Definition exec_equiv T (p: prog T) p' :=
  forall w r, exec p w r <-> exec p' w r.

Instance exec_equiv_equiv T : Equivalence (exec_equiv (T:=T)).
Proof.
  constructor; hnf; unfold exec_equiv; intros;
    repeat match goal with
           | [ H: forall (w:world) (r: Result T), _,
                 w: world,
                 r: Result T |- _ ] =>
             specialize (H w r)
           end; intuition.
Qed.

Ltac cleanup_exec :=
  match goal with
  | [ H: exec (Ret _) _ ?r |- _ ] =>
    first [ is_var r |
            apply exec_ret in H; safe_intuition; subst ]
  end.

Theorem monad_left_id : forall T T' (p: T' -> prog T) v,
    exec_equiv (Bind (Ret v) p) (p v).
Proof.
  unfold exec_equiv; split; intros.
  - inv_exec; try cleanup_exec; eauto.
  - eapply ExecBindFinished; eauto.
Qed.

Theorem monad_right_id : forall `(p: prog T),
    exec_equiv (Bind p (fun v => Ret v)) p.
Proof.
  unfold exec_equiv; split; intros.
  - destruct r; inv_exec; try cleanup_exec; eauto.
  - destruct r; eauto.
Qed.

Theorem monad_assoc : forall `(p1: prog T)
                        `(p2: T -> prog T')
                        `(p3: T' -> prog T''),
    exec_equiv (Bind (Bind p1 p2) p3) (Bind p1 (fun v => Bind (p2 v) p3)).
Proof.
  unfold exec_equiv; split; intros.
  - destruct r; repeat (inv_exec; eauto).
  - destruct r; repeat (inv_exec; eauto).
Qed.

(** invert a bind execution *)
Lemma exec_bind : forall T T' `(p: prog T) (p': T -> prog T')
                    w r,
    exec (Bind p p') w r ->
    (exists v w', exec p w (Finished v w') /\
             exec (p' v) w' r) \/
    (exists w', exec p w (Crashed w') /\
           r = Crashed w').
Proof.
  intros.
  inv_exec; eauto.
Qed.

Local Hint Constructors rexec.

Theorem rexec_equiv : forall T (p p': prog T) `(rec: prog R) w r,
    exec_equiv p p' ->
    rexec p' rec w r ->
    rexec p rec w r.
Proof.
  intros.
  inv_rexec.
  apply H in H1; eauto.
  apply H in H1; eauto.
Qed.

(* When a program finishes, its recovery procedure is irrelevant. *)
Lemma rexec_finish_any_rec : forall `(p: prog T)
                               `(rec: prog R)
                               `(rec': prog R')
                               w v w',
    rexec p rec w (RFinished v w') ->
    rexec p rec' w (RFinished v w').
Proof.
  intros.
  inversion H; subst; eauto.
Qed.

Lemma rexec_recover_bind_inv : forall `(p: prog T)
                                 `(p': T -> prog T')
                                 `(rec: prog R)
                                 w rv w'',
    rexec (Bind p p') rec w (Recovered rv w'') ->
    rexec p rec w (Recovered rv w'') \/
    exists v w', rexec p rec w (RFinished v w') /\
            rexec (p' v) rec w' (Recovered rv w'').
Proof.
  intros.
  inversion H; subst.
  inv_exec.
  - left; eauto.
  - right.
    descend; intuition eauto.
  - left; eauto.
Qed.

Local Hint Constructors exec_recover.

Arguments clos_refl_trans_1n {A} R _ _.

(** Invert looped recovery execution for a bind in the recovery procedure. The
wment essentially breaks down the execution of recovering with [_ <- p; p']
into three stages:

- First, p runs until it finishes without crashing.
- Next, p' is repeatedly run using p as the recovery procedure, crashing and
  recovering in a loop. The return value in [p' rv] comes from p and is passed
  from iteration to the next, initialized with the run of p in the first step.
- Finally, the computer stops crashing and [p' rv] can run to completion.
 *)
Lemma exec_recover_bind_inv : forall `(p: prog R)
                                `(p': R -> prog R')
                                w rv' w'',
    exec_recover (Bind p p') w rv' w'' ->
    exists rv1 w1, exec_recover p w rv1 w1 /\
                  exists rv2 w2,
                    clos_refl_trans_1n
                      (fun '(rv, w) '(rv', w') =>
                         rexec (p' rv) p w (Recovered rv' w'))
                      (rv1, w1) (rv2, w2) /\
                    exec (p' rv2) w2 (Finished rv' w'').
Proof.
  induction 1.
  - inv_exec; eauto 10 using rt1n_refl.
  - repeat deex.
    inv_exec; eauto 10.
    descend; intuition eauto.
    descend; intuition eauto.
    eapply rt1n_trans; eauto.
    simpl; eauto.
Qed.


Load "ExtraProof_1".

(*******************if EQ(x1 , x2) then x1 else y = if EQ(x1 ,x2) then x2 else y***************************************)

Theorem Example11_M:   (if_then_else_M (EQ_M  (Mvar 1) (Mvar 2)) (Mvar 1) (Mvar 3)) # (if_then_else_M (EQ_M  (Mvar 1) (Mvar 2)) (Mvar 2) (Mvar 3)) .
Proof.
intros.
rewrite EQmsg .
(assert(H1:  (EQ_M (if_then_else_M (Bvar 0) (Mvar 1) (Mvar 3) ) (if_then_else_M (Bvar 0) (Mvar 2) (Mvar 3) )) ## (if_then_else_B (Bvar 0) (EQ_M  (Mvar 1) (if_then_else_M (Bvar 0) (Mvar 2) (Mvar 3) ))  (EQ_M  (Mvar 3) (if_then_else_M (Bvar 0) (Mvar 2) (Mvar 3) ))))).
apply IFMORPH_M3 with (n:=0) (n1:=1)(n2:=2)(n3:=3)  .
apply Forall_ELM_EVAL_B  with (n:=0) (b:= (EQ_M (Mvar 1) (Mvar 2))) in H1.
simpl in H1.
assert (H2: (if_then_else_B (Bvar 0)
    [[4 := if_then_else_M (Bvar 0) (Mvar 2) (Mvar 3)]](EQ_M (Mvar 1) (Mvar 4))
    [[4 := if_then_else_M (Bvar 0) (Mvar 2) (Mvar 3)]](EQ_M (Mvar 3) (Mvar 4))) ##
  ( if_then_else_B (Bvar 0) [[4 := Mvar 2]](EQ_M (Mvar 1) (Mvar 4))
    [[4 := Mvar 3]](EQ_M (Mvar 3) (Mvar 4))) ).
apply Ex9msg_bol1 with (b:= (Bvar 0))(n1:=2)(n2:=3)(n3:=2)(n4:=3)(n5:=4)(n6:= 4) (b1:= (EQ_M (Mvar 1) (Mvar 4))) (b2:= (EQ_M (Mvar 3) (Mvar 4))) .
simpl in H2.
apply Forall_ELM_EVAL_B  with (n:=0) (b:= (EQ_M (Mvar 1) (Mvar 2))) in H2.
simpl in H2.
rewrite H2 in H1 .
rewrite H1.
assert (H3:   (EQ_M (Mvar 3) (Mvar 3)) ##   TRue).
apply EQmsg with (x:=(Mvar 3))( y:= (Mvar 3)).
reflexivity.
rewrite H3.
(***
setoid_replace  (if_then_else_B (EQ_M (Mvar 1) (Mvar 2)) (EQ_M (Mvar 1) (Mvar 2))
   (EQ_M (Mvar 3) (Mvar 3))) with  (if_then_else_B (EQ_M (Mvar 1) (Mvar 2)) (EQ_M (Mvar 1) (Mvar 2))
   (TRue)) using relation EQb.
**)
assert (H4: (if_then_else_B (Bvar 0) TRue FAlse) ## (Bvar 0)).
apply IFTF with (n:=0).
apply Forall_ELM_EVAL_B2 with (n :=0)(b:= (EQ_M (Mvar 1) (Mvar 2))) in H4.
simpl  in H4.
assert(H6:  (if_then_else_B (Bvar 0) (Bvar 0) TRue) ## (if_then_else_B (Bvar 0) TRue TRue)).
apply IFEVAL_B with (n:=0) (b1:=(Bvar 0)) (b2:= TRue) .
apply Forall_ELM_EVAL_B with (n :=0)(b:= (EQ_M (Mvar 1) (Mvar 2))) in H6.
simpl  in H6.
rewrite H6.
apply IFSAME_B.
Qed.

Theorem Example11_B:    (if_then_else_B (EQ_B  (Bvar 1) (Bvar 2)) (Bvar 1) (Bvar 3)) ## ( if_then_else_B (EQ_B  (Bvar 1) (Bvar 2)) (Bvar 2) (Bvar 3) ).
Proof.
intros.
rewrite EQ_Bool .
(assert(H1:  (EQ_B (if_then_else_B (Bvar 0) (Bvar 1) (Bvar 3) ) (if_then_else_B (Bvar 0) (Bvar 2) (Bvar 3) )) ## (if_then_else_B (Bvar 0) (EQ_B  (Bvar 1) (if_then_else_B (Bvar 0) (Bvar 2) (Bvar 3) ))  (EQ_B  (Bvar 3) (if_then_else_B (Bvar 0) (Bvar 2) (Bvar 3) ))))).
assert (H2 : (EQ_B (if_then_else_B (Bvar 0) (Bvar 1) (Bvar  3)) (Bvar 4)) ## ( if_then_else_B (Bvar 0) (EQ_B (Bvar 1) (Bvar 4) ) (EQ_B (Bvar 3) (Bvar 4)))).
apply IFMORPH_B3 with  (n:=0) (n1:=1).
apply Forall_ELM_EVAL_B  with (n:=4) (b:= if_then_else_B (Bvar 0) (Bvar 2) (Bvar 3) )in H2.
simpl in H2.
apply H2.
apply Forall_ELM_EVAL_B  with (n:=0) (b:= (EQ_B (Bvar 1) (Bvar 2))) in H1.
simpl in H1.
assert (H2:  (if_then_else_B (Bvar 0) (EQ_B (Bvar 1) (if_then_else_B (Bvar 0) (Bvar 2) (Bvar 3) ) )   (EQ_B (Bvar 3) (if_then_else_B (Bvar 0) (Bvar 2) (Bvar 3) ) )) ## (if_then_else_B (Bvar 0) (EQ_B (Bvar 1) (Bvar 2) ) ( EQ_B (Bvar 3) (Bvar 3))  )).
apply Ex9bol_bol1 with (n1:=2)(n2:=3)(n3:=2)(n4:=3)(n5:=4)(n6:= 4) (b1:= (EQ_B (Bvar 1) (Bvar 4))) (b2:= (EQ_B (Bvar 3) (Bvar 4))) .
apply Forall_ELM_EVAL_B  with (n:=0) (b:= (EQ_B (Bvar 1) (Bvar 2))) in H2.
simpl in H2.
rewrite H1 .
rewrite H2.
assert (H3:   (EQ_B (Bvar 3) (Bvar 3)) ## TRue).
apply EQ_Bool with (x:=(Bvar 3))( y:= (Bvar 3)).
reflexivity.
rewrite H3.
(***setoid_replace  (if_then_else_B (EQ_B (Bvar 1) (Bvar 2)) (EQ_B (Bvar 1) (Bvar 2))
   (EQ_B (Bvar 3) (Bvar 3))) with  (if_then_else_B (EQ_B (Bvar 1) (Bvar 2)) (EQ_B (Bvar 1) (Bvar 2))
   (TRue)) using relation EQb. **)
assert (H4: (if_then_else_B (Bvar 0) TRue FAlse) ## (Bvar 0)).
apply IFTF with (n:=0).
apply Forall_ELM_EVAL_B2 with (n :=0)(b:= (EQ_B (Bvar 1) (Bvar 2))) in H4.
simpl  in H4.
assert(H6: (if_then_else_B (Bvar 0) (Bvar 0) TRue) ## ( if_then_else_B (Bvar 0) TRue TRue)).
apply IFEVAL_B with (n:=0) (b1:=(Bvar 0)) (b2:= TRue) .
apply Forall_ELM_EVAL_B with (n :=0)(b:= (EQ_B (Bvar 1) (Bvar 2))) in H6.
simpl  in H6.
rewrite H6.
apply IFSAME_B.
Qed.

Axiom Example11_B1: forall (n1 n2 n3 :nat), (if_then_else_B (EQ_B  (Bvar n1) (Bvar n2)) (Bvar n1) (Bvar n3))  ## ( if_then_else_B (EQ_B  (Bvar n1) (Bvar n2)) (Bvar n2) (Bvar n3)).
Axiom Example11_B2: forall (n1 n2 n3 :nat),  (if_then_else_B (EQ_M  (Mvar n1) (Mvar n2)) (Bvar n1) (Bvar n3))  ## (if_then_else_B (EQ_M  (Mvar n1) (Mvar n2)) (Bvar n2) (Bvar n3)).
Axiom Example11_M1:forall(n1 n2 n3:nat),   (if_then_else_M (EQ_M  (Mvar n1) (Mvar n2)) (Mvar n1) (Mvar n3) ) # (if_then_else_M (EQ_M  (Mvar n1) (Mvar n2)) (Mvar n2) (Mvar n3)).
Axiom Example11_M2:forall(n1 n2 n3:nat),   (if_then_else_M (EQ_B  (Bvar n1) (Bvar n2)) (Mvar n1) (Mvar n3) ) # (if_then_else_M (EQ_B  (Bvar n1) (Bvar n2)) (Mvar n2) (Mvar n3)).


Set Implicit Arguments.

Require Import Platform.Facade.DFacade.
Require Import Platform.Facade.Notations.
Import Notations.OpenScopes.

Section ADTValue.

  Variable ADTValue : Type.
  Variables ArraySeq_newSpec ArraySeq_writeSpec ArraySeq_readSpec ArraySeq_deleteSpec ListSet_newSpec ListSet_addSpec ListSet_sizeSpec ListSet_deleteSpec : AxiomaticSpec ADTValue.

  Definition count_unique :=
    module
    import {
      "ADT"!"ArraySeq_new" ==> ArraySeq_newSpec;
      "ADT"!"ArraySeq_write" ==> ArraySeq_writeSpec;
      "ADT"!"ArraySeq_read" ==> ArraySeq_readSpec;
      "ADT"!"ArraySeq_delete" ==> ArraySeq_deleteSpec;
      "ADT"!"ListSet_new" ==> ListSet_newSpec;
      "ADT"!"ListSet_add" ==> ListSet_addSpec;
      "ADT"!"ListSet_size" ==> ListSet_sizeSpec;
      "ADT"!"ListSet_delete" ==> ListSet_deleteSpec
    }
    define {
      def "count" = func("arr", "len") {
        "set" <-- call_ "ADT"!"ListSet_new"();
        "i" <- 0;
        while_ ("i" < "len") {
          "e" <-- call_ "ADT"!"ArraySeq_read" ("arr", "i");
          call_ "ADT"!"ListSet_add"("set", "e");
          "i" <- "i" + 1
        };
        "ret" <-- call_ "ADT"!"ListSet_size"("set");
        call_ "ADT"!"ListSet_delete"("set")
      };
      def "main" = func() {
(*
        "arr" <-- call_ "ADT"!"ArraySeq_new"(3);;
        call_ "ADT"!"ArraySeq_write"("arr", 0, 10);;
        call_ "ADT"!"ArraySeq_write"("arr", 1, 20);;
        call_ "ADT"!"ArraySeq_write"("arr", 2, 10);;
        "ret" <-- call_ "count"!"count" ("arr", 3);;
        call_ "ADT"!"ArraySeq_delete"("arr")
*)
        "ret" <- 0
      }
    }.

  Require Import Platform.Facade.CompileDFModule.

  Definition gmodule := compile_to_gmodule count_unique "count_unique" eq_refl.

  (* test executability *)
  Require Import Platform.Cito.GoodModuleDec.
  Require Import Platform.Cito.IsGoodModule.

  Goal is_good_module gmodule = true. Proof. exact eq_refl. Qed.

End ADTValue.


Require Import Category.

Set Universe Polymorphism.

Instance Coq : Category := {|
  object := Type;
  morphism A B := A -> B;
  id A a := a;
  composition A B C f g a := g (f a)
|}.
Proof.
  all: intros; reflexivity.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime C2 B0 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ E Eprimeprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime O /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ Eprimeprime B O /\ col_ O E B0)))))))))))))))))))))))))))))) -> col_ O E Eprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.algebra Require Import frac agree.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import adequacy.

From fae_gtlc_mu Require Import refinements.gradual_static.logical_relation.
From fae_gtlc_mu Require Import cast_calculus.lang stlc_mu.lang.

Section adequacy.
  Context `{!inG Σ specR, !invPreG Σ}.

  Lemma adequacy
    (e : cast_calculus.lang.expr) (e' : stlc_mu.lang.expr) (τ : cast_calculus.types.type) :
    (∀ `{!implG Σ, !specG Σ}, [] ⊨ e ≤log≤ e' : τ) →
    (cast_calculus.lang.Halts e) →
    (stlc_mu.lang.Halts e').
  Proof.
    intros Hlog Hsteps.
    (** Using Iris' adequacy result for weakest preconditions to prove that e' Halts (assuming that the right WP holds) *)
    cut (adequate MaybeStuck e tt (λ _ _, ∃ v', rtc erased_step ([e'], tt) (of_val v' :: [], tt))).
    { rewrite /cast_calculus.lang.Halts in Hsteps. destruct 1. naive_solver. }
    eapply (wp_adequacy Σ); first by apply _.
    (** Actually prove that the right WP holds *)
    iIntros (Hinv ?).
    (* Allocate two halfs at e' to specify static part *)
    iMod (own_alloc ((((1/2)%Qp , to_agree e') ⋅ ((1/2)%Qp , to_agree e')) : specR)) as (spec_name) "[Hs1 Hs2]".
    { rewrite -pair_op frac_op' Qp_half_half agree_idemp.
      apply pair_valid; split; try done; try by apply frac_valid'. }
    set (SpecΣ := SpecG Σ inG0 spec_name).
    set (ImplΣ := ImplG Σ Hinv).
    (* Allocate invariant with e' using one of the halfs *)
    iMod (inv_alloc specN _ (initially_body e') with "[Hs1]") as "#Hinitially".
    { iNext. iExists e'. iSplit; eauto. }
    iExists (λ _ _, True%I), (λ _, True%I); iSplitR; first done.
    (* Proving goal by obtaining the WP in the conclusion of Hlog *)
    iApply wp_fupd. iApply (wp_wand with "[-]").
    - (* Using conclusion in Hlog *) iPoseProof (Hlog ImplΣ SpecΣ [] e' with "[]") as "Hrel".
      { iSplit; auto. iApply interp_env_nil. }
      replace e with (e.[cast_calculus.typing_lemmas.env_subst [] ]) at 2 by by asimpl.
      iApply ("Hrel" $! []). asimpl; iFrame.
    - (* Given postcondition in WP of Hlog and invariant, we continue proving the goal *)
      iModIntro. simpl. iIntros (v'). iDestruct 1 as (v2) "[Hj #Hinterp]".
      iExists v2.
      (* open invariant to get contents *)
      iInv specN as ">Hinv" "Hclose".
      (* prove that e'' must correspond to v2 *)
      iDestruct "Hinv" as (e'') "[He'' %]".
      iDestruct (own_valid_2 with "He'' Hj") as %Hvalid.
      rewrite -pair_op frac_op' Qp_half_half in Hvalid.
      move: Hvalid=> /pair_valid [_ /agree_op_inv' b]. apply leibniz_equiv in b. subst.
      (* close invariant *) iMod ("Hclose" with "[-]") as "_". iExists v2. auto.
      iIntros "!> !%". eauto.
  Qed.

End adequacy.

Definition actualΣ : gFunctors := #[ invΣ ; GFunctor specR ].

Instance subG_inG_specR {Σ} : subG (GFunctor specR) Σ → inG Σ specR.
Proof. solve_inG. Qed.


(*! Understanding conflicts and forwarding, with modules !*)
Require Import Koika.Frontend.

Module Import Queue32.
  Inductive reg_t := empty | data.
  Definition R reg :=
    match reg with
    | empty => bits_t 1
    | data => bits_t 32
    end.

  Definition dequeue0: UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun dequeue0 () : bits_t 32 =>
         guard(!read0(empty)); write0(empty, Ob~1); read0(data) }}.

  Definition enqueue0: UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun enqueue0 (val: bits_t 32) : unit_t =>
         guard(read0(empty)); write0(empty, Ob~0); write0(data, val) }}.

  Definition dequeue1: UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun dequeue1 () : bits_t 32 =>
         guard(!read1(empty)); write1(empty, Ob~1); read1(data) }}.
End Queue32.

Inductive reg_t :=
| in0: Queue32.reg_t -> reg_t
| in1: Queue32.reg_t -> reg_t
| fifo: Queue32.reg_t -> reg_t
| out: Queue32.reg_t -> reg_t.

Inductive rule_name_t := deq0 | deq1 | process.

Definition R (reg: reg_t) : type :=
  match reg with
  | in0 st => Queue32.R st
  | in1 st => Queue32.R st
  | fifo st => Queue32.R st
  | out st => Queue32.R st
  end.

Definition urules (rl: rule_name_t) : uaction reg_t empty_ext_fn_t :=
  match rl with
  | deq0 =>
    {{ fifo.(enqueue0)(in0.(dequeue0)()) }}
  | deq1 =>
    {{ fifo.(enqueue0)(in1.(dequeue0)()) }}
  | process =>
    {{ out.(enqueue0)(|32`d412| + fifo.(dequeue1)()) }}
  end.

Definition rules : rule_name_t -> rule R empty_Sigma :=
  tc_rules R empty_Sigma urules.

Definition pipeline : scheduler :=
  deq0 |> deq1 |> process |> done.

Definition external (r: rule_name_t) := false.

Definition r (reg: reg_t) : R reg :=
  match reg with
  | in0 empty => Ob~0
  | in0 data => Bits.of_nat _ 42
  | in1 empty => Ob~0
  | in1 data => Bits.of_nat _ 73
  | fifo empty => Ob~1
  | fifo data => Bits.zero
  | out empty => Ob~1
  | out data => Bits.zero
  end.

Definition cr := ContextEnv.(create) r.

Definition interp_result :=
  tc_compute (commit_update cr (interp_scheduler cr empty_sigma rules pipeline)).

Definition circuits :=
  compile_scheduler rules external pipeline.

Definition package :=
  {| ip_koika := {| koika_reg_types := R;
                   koika_reg_init reg := r reg;
                   koika_ext_fn_types := empty_Sigma;
                   koika_rules := rules;
                   koika_rule_external := external;
                   koika_scheduler := pipeline;
                   koika_module_name := "conflicts_modular" |};

     ip_sim := {| sp_ext_fn_specs := empty_ext_fn_props;
                 sp_prelude := None |};

     ip_verilog := {| vp_ext_fn_specs := empty_ext_fn_props |} |}.

Definition prog := Interop.Backends.register package.
Extraction "conflicts_modular.ml" prog.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.
Require Import Coq.Lists.List.

Set Implicit Arguments.

Section TopSection.

  Local Open Scope nat.

  Opaque mult.

  Lemma ptsto32m'_out : forall p ls n,
    ptsto32m' nil p n ls ===> ptsto32m nil p n ls.
    induction ls; simpl; intros.
    apply Himp_refl.
    eapply Himp_trans; [ apply Himp_star_frame; [ apply Himp_refl
      | apply IHls ] | ].
    destruct ls; simpl in *.
    destruct n.
    replace (p ^+ $0) with p by words.
    eapply Himp_trans; [ apply Himp_star_comm | ].
    apply Himp_star_Emp.
    eapply Himp_trans; [ apply Himp_star_comm | ].
    apply Himp_star_Emp.
    destruct n; simpl.
    replace (p ^+ $0) with p by words.
    apply Himp_refl.
    apply Himp_refl.
  Qed.

  Lemma ptsto32m'_in : forall p ls n,
    ptsto32m nil p n ls ===> ptsto32m' nil p n ls.
    induction ls; simpl; intros.
    apply Himp_refl.
    eapply Himp_trans; [ | apply Himp_star_frame; [ apply Himp_refl
      | apply IHls ] ].
    destruct ls; simpl in *.
    destruct n.
    replace (p ^+ $0) with p by words.
    eapply Himp_trans; [ | apply Himp_star_comm ].
    apply Himp_star_Emp'.
    eapply Himp_trans; [ | apply Himp_star_comm ].
    apply Himp_star_Emp'.
    destruct n; simpl.
    replace (p ^+ $0) with p by words.
    apply Himp_refl.
    apply Himp_refl.
  Qed.

  Lemma ptsto32m'_split' : forall p ls2 ls1 base,
    ptsto32m' nil p base (ls1 ++ ls2) ===>
    star (ptsto32m' nil p base ls1)
    (ptsto32m' nil (p ^+ $ (4 * length ls1)) base ls2).
    induction ls1; simpl; intros.

    change (4 * 0) with 0.
    replace (p ^+ $0) with p by words.
    apply Himp_star_Emp'.

    eapply Himp_trans; [ apply Himp_star_frame; [
      apply Himp_refl | apply IHls1 ] | ].
    sepLemma.
    eapply Himp_trans; [ apply ptsto32m'_shift_base' | ].
    instantiate (1 := 4).
    auto.
    apply Himp_refl'; f_equal; try omega.
    unfold natToW.
    rewrite <- wplus_assoc.
    rewrite <- natToWord_plus.
    do 2 f_equal.
    auto.
  Qed.

  Lemma ptsto32m'_split : forall p ls pos base,
    pos <= length ls
    -> ptsto32m' nil p base ls ===>
    star (ptsto32m' nil p base (firstn pos ls))
    (ptsto32m' nil (p ^+ $ (4 * pos)) base (skipn pos ls)).
    intros.
    pattern ls at 1.
    replace ls with (firstn pos ls ++ skipn pos ls).
    replace (4 * pos) with (4 * length (firstn pos ls)).
    apply ptsto32m'_split'.
    rewrite firstn_length.
    rewrite Min.min_l; auto.
    apply firstn_skipn.
  Qed.

  Lemma ptsto32m'_elim : forall p ls base,
    ptsto32m' nil p base ls ===> (p ^+ $ base) =?> length ls.
    induction ls; simpl; intros.

    apply Himp_refl.

    apply Himp_star_frame.
    sepLemma.
    eapply Himp_trans; [ | apply allocated_shift_base ].
    eapply Himp_trans; [ | apply IHls ].
    apply Himp_refl.
    do 2 rewrite <- wplus_assoc.
    do 2 rewrite <- natToWord_plus.
    do 2 f_equal.
    omega.
    auto.
  Qed.

End TopSection.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import VST.floyd.functional_base.

Require Import sha.ByteBitRelations. (* TODO this is only here because of bitsToBytes *)

Module Type ABSTRACT_ENTROPY.

Parameter stream: Type.

Inductive error_code: Type :=
| catastrophic_error
| generic_error
.

Inductive result X: Type: Type :=
| success: X -> stream -> @result X
| error : error_code -> stream -> @result X
.

Arguments success {X} _ _.
Arguments error {X} _ _.

Parameter get_bytes: nat -> stream -> result (list byte).
Parameter get_bits: nat -> stream -> result (list bool).

End ABSTRACT_ENTROPY.

Module OPTIONAL_ENTROPY <: ABSTRACT_ENTROPY.

Definition stream: Type := nat -> option bool.

Inductive error_code: Type :=
| catastrophic_error
| generic_error
.

Inductive result X: Type: Type :=
| success: X -> stream -> @result X
| error : error_code -> stream -> @result X
.

Arguments success {X} _ _.
Arguments error {X} _ _.

Fixpoint get_bits (k: nat) (s: stream): result (list bool) :=
  match k with
    | O => success [] s
    | S k' => match get_bits k' s with
                | error e s' => error  e s'
                | success b s' =>
                  match s' O with
                    | None => error catastrophic_error (fun i => match Nat.compare i k' with
                                                                   | Lt => s i
                                                                   | Eq | Gt => s (1 + i)%nat
                                                                 end
                                                       )
                    | Some e => success (b ++ [e]) (fun i => s (k + i)%nat)
                  end
              end
  end.

Example get_bits_test1:
  forall bits s output s',
    bits = [Some false; Some true; Some false; Some false] ->
    s = (fun i => nth i bits None) ->
    success output s' = get_bits (length bits) s ->
    s' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  split.
  extensionality i. destruct i; reflexivity.
  reflexivity.
Qed.

Example get_bits_test2:
  forall bits s output s' s'',
    bits = [Some false; None; Some true; Some false; Some false] ->
    s = (fun i => nth i bits None) ->
    error catastrophic_error s' = get_bits 4%nat s ->
    success output s'' = get_bits 4%nat s' ->
    s'' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  inv H2.
  split.
  extensionality i. reflexivity.
  reflexivity.
Qed.

Example get_bits_test3:
  forall bits s output s' s'',
    bits = [None; Some false; Some true; Some false; Some false] ->
    s = (fun i => nth i bits None) ->
    error catastrophic_error s' = get_bits 4%nat s ->
    success output s'' = get_bits 4%nat s' ->
    s'' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  inv H2.
  split.
  extensionality i. reflexivity.
  reflexivity.
Qed.

Example get_bits_test4:
  forall bits s output s' s'',
    bits = [Some false; Some true; Some false; None; Some false] ->
    s = (fun i => nth i bits None) ->
    error catastrophic_error s' = get_bits 4%nat s ->
    success output s'' = get_bits 4%nat s' ->
    s'' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  inv H2.
  split.
  extensionality i. reflexivity.
  reflexivity.
Qed.
(*
Fixpoint get_bits_concrete (k: nat) (s: stream) (max: nat): @result (list bool) :=
  match k with
    | O => success [] s
    | S k' =>
      match s (max - k)%nat with
        | None => error catastrophic_error (fun i => s (1 + i)%nat)
        | Some bit =>
          match get_bits_concrete k' s max with
            | error e s' => error e (fun i => match Nat.compare i (max - k)%nat with
                                                  | Gt => s' i
                                                  | Eq | Lt => s i
                                     end)
            | success b s' => success (bit::b) (fun i => s (k + i)%nat)
          end
      end
  end
.
Lemma get_bits_concrete_correct:
  forall k s, get_bits k s = get_bits_concrete k s k.
Proof.
  intros k.
  induction k as [|k']; [reflexivity|].
  intros s.
  simpl.
  rewrite IHk'. clear IHk'.
  replace (k' - k')%nat with O by lia.
  remember (s O) as sO.
  destruct sO.
  {
    (* s 0 <> None *)
    (*
    remember (get_bits_concrete k' s k') as result.
    destruct result as [string s' | e s'].
    {
      remember (get_bits_concrete k' s (S k')) as result2.
      destruct result2 as [string2 s'2 | e2 s'2].
      {
        (* case where both result return success *)
        generalize dependent s.
        induction k' as [|k'']; intros.
        simpl in *. inv Heqresult. inv Heqresult2. rewrite <- HeqsO. auto.
        simpl in *. replace (k'' - k'')%nat with O in * by lia. rewrite <- HeqsO in *.
        rewrite IHk''.
      }
      unfold get_bits_concrete.
    }
*)
    induction k' as [|k''].
    {
      simpl. rewrite <- HeqsO.
      reflexivity.
    }
    simpl.
    replace (k'' - k'')%nat with O by lia.
    rewrite <- HeqsO in *.
    replace (match k'' with
             | 0%nat => S k''
             | S l => (k'' - l)%nat
             end) with 1%nat by (destruct k''; lia).

  }
  {
    destruct k' as [|k''].
    {
      simpl. rewrite <- HeqsO.
      replace (fun i : nat =>
      match Nat.compare i 0 with
      | Eq => s (S i)
      | Lt => s i
      | Gt => s (S i)
      end) with (fun i => s (S i)); [reflexivity|].
      extensionality i.
      destruct i as [|i']; reflexivity.
    }
    simpl.
    replace (k'' - k'')%nat with O by lia; rewrite <- HeqsO.
    reflexivity.
  }
  simpl.
  *)

Definition get_bytes (k: nat) (s: stream): result (list byte) :=
  match get_bits (8 * k)%nat s with
    | success bits s' => success (bitsToBytes bits) s'
    | error e s' => error e s'
  end
.

End OPTIONAL_ENTROPY.

Module ENTROPY := OPTIONAL_ENTROPY.

Definition get_entropy (security_strength min_length max_length: Z) (prediction_resistance: bool) s :=
           ENTROPY.get_bytes (Z.to_nat min_length) s.