Require Import CoqlibC Errors.
Require Import Integers Floats AST Linking.
Require Import ValuesC Memory Events Globalenvs Smallstep.
Require Import Op Locations MachC Conventions ConventionsC AsmC.
Require Import Asmgen Asmgenproof0.
Require Import sflib.
(* newly added *)
Require Export Asmgenproof.
Require Import SimModSem SimMemExt SimSymbId MemoryC ValuesC MemdataC LocationsC StoreArguments Conventions1C.

Require Import Skeleton Mod ModSem SimMod SimSymb SimMem AsmregsC MatchSimModSem.
Require Import JunkBlock StoreArgumentsProps.
Require SoundTop.

Local Opaque Z.mul.
Local Existing Instance main_args_some.

Set Implicit Arguments.

Section PRESERVATION.

Variable skenv_link: SkEnv.t.
Variable prog: Mach.program.
Variable tprog: Asm.program.
Let md_src: Mod.t := (MachC.module prog return_address_offset).
Let md_tgt: Mod.t := (AsmC.module tprog).
Hypothesis (INCLSRC: SkEnv.includes skenv_link (Mod.sk md_src)).
Hypothesis (INCLTGT: SkEnv.includes skenv_link (Mod.sk md_tgt)).
Hypothesis (WF: SkEnv.wf skenv_link).

Hypothesis TRANSF: match_prog prog tprog.

Let ge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_src)) prog).
Let tge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_tgt)) tprog).

Variable sm_link: SimMem.t.

Definition msp: ModSemPair.t :=
  ModSemPair.mk (SM := SimMemExt)
                (Mod.modsem (md_src) skenv_link)
                (Mod.modsem (md_tgt) skenv_link)
                (SimSymbId.mk md_src md_tgt) sm_link.

Definition get_rs (ms: Mach.state) : Mach.regset :=
  match ms with
  | Mach.State _ _ _ _ rs _ => rs
  | Callstate _ _ rs _ => rs
  | Returnstate _ rs _ => rs
  end.

Record agree_eq (ms: Mach.regset) (sp: val) (rs: Asm.regset) (sg: signature): Prop :=
  mkagree
    { agree_sp: rs#SP = sp;
      agree_sp_def: sp <> Vundef;
      agree_mregs_less:
        forall (r: mreg) (IN: In (R r) (regs_of_rpairs (loc_arguments sg))),
          Val.lessdef (ms r) (rs#(preg_of r));
      agree_mregs_eq:
        forall (r: mreg) (NOTIN: ~ In (R r) (regs_of_rpairs (loc_arguments sg))),
          (ms r) = (rs#(preg_of r));
    }.

Definition set_regset (rs0 rs1: Mach.regset) (sg: signature) (mr: mreg) : val :=
  if Loc.notin_dec (R mr) (regs_of_rpairs (loc_arguments sg)) then rs1 mr else rs0 mr.

Definition set_regset_undef (rs: Mach.regset) (sg: signature) (mr: mreg) : val :=
  if Loc.notin_dec (R mr) (regs_of_rpairs (loc_arguments sg)) then Vundef else rs mr.

Inductive match_init_data init_sp init_ra
          init_rs_src init_sg_src init_rs_tgt : Prop :=
| match_init_data_intro
    (INITRA: init_ra = init_rs_tgt RA)
    (INITRAPTR: <<TPTR: Val.has_type (init_ra) Tptr>> /\ <<RADEF: init_ra <> Vundef>>)
    (INITRS: agree_eq init_rs_src init_sp init_rs_tgt init_sg_src )
    (SIG: exists fd, (Genv.find_funct tge) (init_rs_tgt PC) = Some (Internal fd) /\ fd.(fn_sig) = init_sg_src /\ init_sg_src.(sig_cstyle)).

Inductive stack_base (initial_parent_sp initial_parent_ra: val): list Mach.stackframe -> Prop :=
| stack_base_dummy:
    stack_base initial_parent_sp initial_parent_ra
      ((dummy_stack initial_parent_sp initial_parent_ra)::[])
| stack_base_cons
    fr ls
    (TL: stack_base initial_parent_sp initial_parent_ra ls):
    stack_base initial_parent_sp initial_parent_ra (fr::ls).

Inductive match_states
          (idx: nat) (st_src0: MachC.state) (st_tgt0: AsmC.state)
          (sm0: SimMem.t): Prop :=
| match_states_intro
    init_sp init_ra
    (* (initial_parent_sp_ptr : ValuesC.is_real_ptr (init_sp)) *)
    (initial_parent_ra_ptr: Val.has_type init_ra Tptr)
    (initial_parent_ra_def: init_ra <> Vundef)
    (initial_parent_ra_junk: forall blk ofs (RAVAL: init_ra = Vptr blk ofs),
        ~ Plt blk (Genv.genv_next skenv_link))
    (* (initial_parent_ra_junk1: tge.(Genv.find_funct) init_ra = None) *)
    (STACKWF: stack_base init_sp init_ra (get_stack st_src0.(MachC.st)))
    (INITDATA: match_init_data
                 init_sp init_ra st_src0.(MachC.init_rs) st_src0.(init_sg) st_tgt0.(init_rs))
    (MATCHST: Asmgenproof.match_states ge st_src0.(MachC.st) st_tgt0)
    (* (SPPTR: ValuesC.is_real_ptr (st_tgt0.(init_rs) RSP)) *)
    (MCOMPATSRC: (MachC.get_mem st_src0.(MachC.st)) = sm0.(SimMem.src))
    (MCOMPATTGT: (get_mem st_tgt0) = sm0.(SimMem.tgt))
    (IDX: measure st_src0.(MachC.st) = idx).

Lemma asm_step_dstep init_rs st0 st1 tr
      (STEP: Asm.step skenv_link tge st0 tr st1):
    Simulation.DStep (modsem skenv_link tprog) (mkstate init_rs st0) tr (mkstate init_rs st1).
Proof.
  econs.
  - eapply modsem_determinate; et.
  - econs; auto.
Qed.

Lemma asm_star_dstar init_rs st0 st1 tr
      (STEP: star Asm.step skenv_link tge st0 tr st1):
    Simulation.DStar (modsem skenv_link tprog) (mkstate init_rs st0) tr (mkstate init_rs st1).
Proof.
  induction STEP; econs; eauto. eapply asm_step_dstep; auto.
Qed.

Lemma asm_plus_dplus init_rs st0 st1 tr
      (STEP: plus Asm.step skenv_link tge st0 tr st1):
    Simulation.DPlus (modsem skenv_link tprog) (mkstate init_rs st0) tr (mkstate init_rs st1).
Proof.
  inv STEP. econs; eauto.
  - eapply asm_step_dstep; eauto.
  - eapply asm_star_dstar; eauto.
Qed.

Theorem make_match_genvs :
  SimSymbId.sim_skenv (SkEnv.project skenv_link (Mod.sk md_src))
                      (SkEnv.project skenv_link (Mod.sk md_tgt)) ->
  Genv.match_genvs (match_globdef (fun _ f tf => transf_fundef f = OK tf) eq prog) ge tge.
Proof. subst_locals. eapply SimSymbId.sim_skenv_revive; eauto. Qed.

Lemma transf_function_sig
      fd_src fd_tgt
      (TRANS: transf_function fd_src = OK fd_tgt):
  fd_src.(Mach.fn_sig) = fd_tgt.(fn_sig).
Proof. repeat unfold transf_function, bind, transl_function in *. des_ifs. Qed.

Theorem sim_modsem: ModSemPair.sim msp.
Proof.
  eapply match_states_sim with (match_states := match_states)
                               (match_states_at := top4); eauto; ii; ss.

  - apply lt_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - inv INITTGT; cycle 1.
    { ss. des_safe. inv SAFESRC. inv SIMARGS; ss. }
    des. inv SAFESRC. destruct sm_arg, args_src; ss. inv SIMARGS; ss. clarify.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE. des.

    assert (SRCSTORE: exists rs_src m_src,
               StoreArguments.store_arguments src rs_src (typify_list vs_src (sig_args (fn_sig fd))) (fn_sig fd) m_src /\
           agree_eq rs_src (Vptr (Mem.nextblock src)
                          Ptrofs.zero) rs (fn_sig fd) /\ Mem.extends m_src m0).
    { inv TYP.
      exploit store_arguments_parallel_extends.
      - eapply typify_has_type_list. eauto.
      - exploit SkEnv.revive_incl_skenv; try eapply INCLTGT; eauto. i. des. inv WF.
        eapply WFPARAM in H; eauto.
      - instantiate (1:= typify_list vs_src (sig_args (fn_sig fd))).
        eapply lessdef_list_typify_list; eauto. erewrite lessdef_list_length; eauto.
      - eapply MWF.
      - inv STORE. eauto.
      - i. des. exists (set_regset rs_src (to_mregset rs) (fn_sig fd)).
        esplits; eauto.
        + clear - ARGTGT. inv ARGTGT. econs; eauto.
          eapply extcall_arguments_same; eauto.
          i. unfold set_regset. des_ifs.
          eapply Loc.notin_not_in in n. contradiction.
        + inv STORE. econs; eauto.
          * inv MWF. rewrite mext_next. eauto.
          * intros X. inv X.
          * i. unfold set_regset. des_ifs.
            eapply val_inject_id. eapply AGREE.
          * i. unfold set_regset. des_ifs.
            eapply LocationsC.Loc_not_in_notin_R in NOTIN. contradiction.
    }

    destruct SRCSTORE as [rs_src [m_src [SRCSTORE [AGREE EXTENDS]]]]. inv AGREE.
    exists (MachC.mkstate
              rs_src (fn_sig fd)
              (Callstate
                 [dummy_stack (Vptr (Mem.nextblock src) Ptrofs.zero) (rs RA)]
                 fptr_src rs_src (assign_junk_blocks m_src n))).
    inv FPTR; ss.
    esplits; auto; ss.
    + inv TYP0. clear_tac.
      assert(SIG2: fn_sig fd = (Mach.fn_sig fd0)).
      { hexploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. i; des.
        folder. ss; try unfold bind in *; des_ifs.
        symmetry. eapply transf_function_sig; eauto.
      }
      econs; eauto; ss.
      * econs; eauto; ss; eauto with congruence.
      * ii. erewrite (agree_mregs_eq0 mr) in *; auto. unfold NW. apply NNPP. intro T.
        exploit PTRFREE; eauto.
        { instantiate (1:= preg_of mr). intro U. contradict T.
          unfold is_junk_value in U. unfold is_junk_value. des_ifs. des. split; ss.
          - erewrite Mem.valid_block_extends; eauto.
          - erewrite Mem.valid_block_extends; eauto. eapply assign_junk_block_extends; et.
        }
        i. des; try (by destruct mr; clarify). rewrite Asm.to_preg_to_mreg in *. clarify.
    + instantiate (1:= SimMemExt.mk (assign_junk_blocks m_src n) (assign_junk_blocks m0 n)).
      econs; try eapply RADEF; ss; eauto.
      * econs; eauto.
      * econs; ss; eauto.
      * econs; eauto; ss; try by (econs; eauto).
        { eapply assign_junk_block_extends; et. }
        econs; eauto. i.
        destruct (classic (In (R r) (regs_of_rpairs (loc_arguments (fn_sig fd))))); eauto.
        erewrite agree_mregs_eq0; auto.

  - ss. des. inv SAFESRC. inv SIMARGS; ss. destruct sm_arg; ss. clarify.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE.
    hexploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. i; des. ss; unfold bind in *; des_ifs. rename f into fd_tgt.
    inv TYP.
    assert(SIG: fn_sig fd_tgt = (Mach.fn_sig fd)).
    { hexploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. i; des.
      folder. ss; try unfold bind in *; des_ifs.
      symmetry. eapply transf_function_sig; eauto.
    }
    assert (exists rs_tgt m_tgt,
               (<<STORE: AsmC.store_arguments tgt rs_tgt
                                              (typify_list vs_tgt (sig_args (Mach.fn_sig fd)))
                                              (* (Args.vs args_tgt) *)
                                              (Mach.fn_sig fd) m_tgt>>) /\
               (<<RSPC: rs_tgt PC = fptr_tgt>>) /\
               (<<RSRA: rs_tgt RA = Vnullptr>>) /\
               (<<PTRFREE: forall pr (PTR: ~ is_junk_value m0 (assign_junk_blocks m0 n) (rs_tgt pr)),
                   (<<INARG: exists mr,
                       (<<MR: to_mreg pr = Some mr>>) /\
                       (<<ARG: In (R mr) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd)))>>)>>) \/
                   (<<INPC: pr = PC>>) \/
                   (<<INRSP: pr = RSP>>)>>)).
    { exploit StoreArgumentsProps.store_arguments_progress.
      - instantiate (2:=typify_list vs_tgt (sig_args (Mach.fn_sig fd))).
        eapply typify_has_type_list. erewrite <- lessdef_list_length; eauto.
      - exploit SkEnv.revive_incl_skenv; try eapply INCLTGT; eauto. i. des. inv WF.
        eapply WFPARAM in H0. eauto. ss. rewrite <- SIG. ss.
      - instantiate (1:= n). i. des.
        exists ((to_pregset (set_regset_undef rs0 (Mach.fn_sig fd)))
                  #PC <- fptr_tgt
                  #RA <- Vnullptr
                  #RSP <- (Vptr (Mem.nextblock tgt) Ptrofs.zero)).
        esplits; eauto.
        + split; ss. inv STR. econs; eauto. eapply extcall_arguments_same; eauto. i.
          { assert (NNIN: ~ Loc.notin (R r) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd)))).
            { intros X. eapply Loc.notin_not_in; eauto. }
            unfold set_regset_undef, to_pregset, to_mregset, Pregmap.set, to_preg, preg_of, to_mreg in *.
            destruct r; eauto; des_ifs; try contradiction.
          }
        + i.
          assert (NNIN: forall mr, ~ Loc.notin (R mr) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd))) -> In (R mr) (regs_of_rpairs (loc_arguments (Mach.fn_sig fd)))).
          { intros mr NIN. clear - NIN.
            eapply NNPP. intros X.
            eapply LocationsC.Loc_not_in_notin_R in X. des. contradiction. }
          clear - NNIN PTR. unfold set_regset_undef, to_pregset, to_mregset, Pregmap.set, to_preg, preg_of, to_mreg in *.
          destruct pr; des_ifs; ss; eauto. exfalso. apply PTR. ss.
    }
    des. eexists. econs; eauto; swap 1 2.
    + folder. inv FPTR; ss. eauto.
    + congruence.
    + rewrite RSRA. econs; ss.
    + rewrite RSRA. ss.
    + rewrite SIG. econs; eauto. rewrite <- LEN. symmetry. eapply lessdef_list_length. eauto.
    + erewrite <- transf_function_sig; eauto.
    + erewrite <- transf_function_sig; eauto. ii. hexploit PTRFREE0; et.
      ii. apply PTR. unfold is_junk_value in *. des_ifs.
      unfold Mem.valid_block. unfold Mem.valid_block in H0.
      rewrite assign_junk_blocks_nextblock in *.
      inv STORE. inv STORE0. inv H1. rewrite <- NB0. rewrite <- NB in *.
      erewrite Mem.nextblock_alloc; eauto.
      erewrite (Mem.nextblock_alloc src) in H0; eauto.
      inv MWF. rewrite <- mext_next. des; esplits; eauto; try xomega.
  - inv MATCH; ss. destruct st_src0, st_tgt0, sm0. ss. inv MATCHST; ss.

  - ss. inv CALLSRC. inv MATCH. inv INITDATA. inv MATCHST. ss. destruct st_tgt0. ss. clarify. des.
    inv FPTR; ss. destruct (rs0 PC) eqn:PCEQ; ss. des_ifs.

    exploit Asmgenproof0.extcall_arguments_match; eauto. intros TGRARGS. des.
    exploit Mem.free_parallel_extends; eauto. intros TGTFREE. des. esplits; ss.
    + econs; eauto.
      * r in TRANSF. r in TRANSF.
        exploit (SimSymbId.sim_skenv_revive TRANSF); eauto.
        { apply SIMSKENV. }
        intro GE. apply (fsim_external_funct_id GE); ss.
      * inv STACKS; ss.
        -- inv STACKWF; [|inv TL]. inv ATLR; auto; exfalso; auto.
        -- destruct ra; ss; try inv H0. inv ATLR. ss.
      * inv AG. rewrite agree_sp0. clarify.
    + instantiate (1:= SimMemExt.mk m1 m2'). econs; ss; eauto.
    + ss.

  - inv AFTERSRC. ss. des. clarify. destruct st_tgt0, st. inv MATCH. inv MATCHST.
    inv INITDATA. inv SIMRET; ss. destruct sm_ret. ss. clarify.
    exploit Mem_unfree_parallel_extends; try eapply UNFREE; eauto.
    intros TGTUNFREE. des. esplits; auto.
    + econs; ss; eauto.
      * exists skd. esplits; eauto. replace (r PC) with fptr; auto. inv FPTR; ss.
      * inv AG. rewrite agree_sp0. eauto.
    + instantiate (1:= SimMemExt.mk m1 m2'). inv INITRS. inv AG.
      econs; ss; eauto; econs; eauto.
      * econs; eauto.
      * unfold loc_external_result, regset_after_external, Mach.regset_after_external.
        apply agree_set_other; auto. apply agree_set_pair; auto.
        econstructor; ss; eauto. intros. rewrite to_preg_to_mreg.
        destruct (Conventions1.is_callee_save r0) eqn:T; eauto.

  - ss. inv FINALSRC. des. clarify. destruct st_tgt0, st. inv MATCH. inv MATCHST.
    inv INITDATA. destruct sm0. ss. clarify.
    inv STACKWF; [|inv TL]. inv STACKS; [|inv H7; ss]. inv INITRS.
    exploit Mem.free_parallel_extends; eauto. intros TGTFREE. des.
    esplits; auto.
    + econs; ss; eauto.
      * replace (r PC) with (init_rs0 RA).
        { clear - initial_parent_ra_junk. unfold external_state. des_ifs.
          exploit initial_parent_ra_junk; ss; eauto.
          unfold Genv.find_funct_ptr, Genv.find_def in *. des_ifs.
          eapply Genv.genv_defs_range in Heq1. ss.
        }
        inv ATPC; auto. exfalso. auto.
      * inv ATPC; auto. exfalso. auto.
      * unfold Genv.find_funct, Genv.find_funct_ptr. des_ifs.
        exfalso. exploit Genv.genv_defs_range; eauto. eapply initial_parent_ra_junk; ss.
      * inv AG. i.
        { eapply Val.lessdef_trans.
          - erewrite <- agree_mregs_eq0; auto. ii.
            eapply loc_args_callee_save_disjoint; eauto.
          - eauto.
        }
      * inv AG. rewrite agree_sp0. ss.
    + econs; simpl; ss.
      * ss. inv AG. auto.
      * instantiate (1:= SimMemExt.mk _ _). ss.
      * ss.
    + ss.

  - left; i. ss. esplits.
    + eapply MachC.modsem_receptive; et.

    + i. inv STEPSRC. inv MATCH. set (INITDATA0 := INITDATA). inv INITDATA0.
      inv INITRAPTR. inv INITRS0. clarify.
      exploit step_simulation; ss; try apply agree_sp_def0; eauto.
      { eapply make_match_genvs; eauto. apply SIMSKENV. }
      i. des; ss; esplits; auto; clarify.
      * left. instantiate (1 := mkstate st_tgt0.(init_rs) S2'). ss.
        destruct st_tgt0. eapply asm_plus_dplus; eauto.
      * instantiate (1 := SimMemExt.mk (MachC.get_mem (MachC.st st_src1)) (get_mem S2')).
        econs; ss; eauto.
        { instantiate (1:=init_rs st_tgt0 RSP).
          destruct st_src0, st_src1. clear - STEP STACKWF NOTDUMMY.
          inv STEP; ss; clarify.
          - econs. ss.
          - inv STACKWF; ss.
        }
        rewrite <- INITRS. rewrite <- INITFPTR. auto.
      * right. split; eauto. apply star_refl.
      * instantiate (1 := SimMemExt.mk (MachC.get_mem (MachC.st st_src1)) (get_mem st_tgt0.(st))).
        econs; ss; eauto.
        { instantiate (1:=init_rs st_tgt0 RSP).
          destruct st_src0, st_src1. clear - STEP STACKWF NOTDUMMY. inv STEP; ss; clarify.
          - econs. ss.
          - inv STACKWF; ss.
        }
        rewrite <- INITRS. rewrite <- INITFPTR. auto.

  Unshelve.
    all: ss.
Qed.

End PRESERVATION.

Section SIMMOD.

Variable prog: Mach.program.
Variable tprog: program.
Hypothesis TRANSL: match_prog prog tprog.
Definition mp: ModPair.t := mk_mp (MachC.module prog return_address_offset) (AsmC.module tprog).

Theorem sim_mod: ModPair.sim mp.
Proof.
  econs; ss.
  - r. eapply Sk.match_program_eq; eauto. ii. destruct f1; ss.
    + clarify. right. unfold bind in MATCH. des_ifs. esplits; eauto.
      unfold transf_function, transl_function, bind in *. des_ifs.
    + clarify. left. esplits; eauto.
  - ii. inv SIMSKENVLINK. eapply sim_modsem; eauto.
Qed.

End SIMMOD.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.fieldlist.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.nested_pred_lemmas.
Import compcert.lib.Maps.
Open Scope Z.

Module Type ACR_DEC.

  Parameter align_compatible_rec_dec:
    forall {cs: compspecs},
      forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.

End ACR_DEC.

Module align_compatible_rec_dec: ACR_DEC.

Section align_compatible_rec_dec.

Context {cs: compspecs}.

Definition dec_type := sigT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}).

Definition dec_by_value (ch: memory_chunk): dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z})
   (fun z => (Memdata.align_chunk ch | z))
   (fun z => Zdivide_dec (Memdata.align_chunk ch) z (*Memdata.align_chunk_pos _*)).

Definition dec_False: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => False) (fun z => right (fun H => H)).

Definition dec_True: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => True) (fun z => left I).

Fixpoint cons_in_list {A} (a: A) (al' al: list A) (H: forall x, In x al' -> In x al) (bl: list {x:A| In x al'}) : list {x: A | In x al} :=
  match bl with
  | nil => nil
  | exist x i :: bl0 =>exist _ x (H x i)  :: cons_in_list a al' al H bl0
  end.

Fixpoint make_in_list {A} (al: list A) : list {x: A | In x al} :=
  match al as ax return (al = ax -> list {x : A | In x ax}) with
           | nil => fun _ => nil
           | a::al' => fun H: al = a::al' =>
                      exist _ a (or_introl eq_refl) ::
                         eq_rect al (fun l : list A => list {x : A | In x l})
                          (cons_in_list a al' al (fun (x : A) (H0 : In x al') =>
                                 eq_ind_r (fun al0 : list A => In x al0) (in_cons _ _ _ H0) H)
                               (make_in_list al'))
                        (a :: al') H
           end (eq_refl _).

Lemma in_make_in_list: forall {A} (a: A) (al: list A) H,
   In (exist (fun x => In x al) a H) (make_in_list al).
Proof.
induction al; intros.
inv H.
destruct H.
subst a0.
simpl.
left; auto.
unfold make_in_list; fold @make_in_list.
right.
specialize (IHal i).
unfold eq_rect.
forget (make_in_list al) as bl.
unfold eq_ind_r.
unfold eq_ind.
simpl.
induction bl.
inv IHal.
destruct IHal.
subst a1.
left.
apply exist_ext; auto.
specialize (IHbl H).
unfold cons_in_list; fold @cons_in_list.
destruct a1.
right. auto.
Qed.

Lemma field_type_in_members_strong:
 forall i t m
  (PLAIN: plain_members m = true),
   Ctypes.field_type i m = Errors.OK t ->
          In (Member_plain i t) m.
Proof.
induction m as [|[|]]; intros.
inv H.
simpl in H.
if_tac in H. subst. inv H. left; auto.
right. apply IHm; auto.
inv PLAIN.
Qed.

Lemma align_compatible_dec_aux:
   forall n t, (rank_type cenv_cs t < n)%nat ->
    forall z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Proof.
induction n; intros; [ lia | ].
rename H into Hrank.
destruct t  as [ | [ | | | ] [ | ]| [ | ] | [ | ] | | | | | ] eqn:Ht; intros;
try solve [
clear IHn Hrank;
match goal with |- context [align_compatible_rec _ ?t _] =>
evar (ch: memory_chunk);
assert (access_mode t = By_value ch) by (subst ch; reflexivity);
(destruct (Zdivide_dec (Memdata.align_chunk ch) z);
   [left; econstructor; try reflexivity; eassumption
   |right;  contradict n; inv n; inv H0; auto])
end];
try solve [right; intro H; inv H; inv H0].
* (* Tarray *)
specialize (IHn t0).
simpl in Hrank. spec IHn; [lia | ]. clear Hrank.
pose proof (Zrange_pred_dec (fun ofs => align_compatible_rec cenv_cs t0 (z + sizeof t0 * ofs))).
spec H.
intro; apply IHn.
specialize (H 0 z0).
destruct H as [H|H]; [left|right].
+
eapply align_compatible_rec_Tarray; intros.
apply H; auto.
+
contradict H.
intros.
eapply align_compatible_rec_Tarray_inv in H.
apply H.
split; try lia.
* (* Tstruct *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
destruct (plain_members (co_members c)) eqn:?PLAIN;
   [ | right; intro Hx; inv Hx; [ discriminate | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (FO id := match Ctypes.field_offset cenv_cs id (co_members c) with
                      | Errors.OK (z0, Full) => z0 | _ => 0 end).
pose (D := fun x: {it: member | In it (co_members c)} =>
                align_compatible_rec cenv_cs (type_member (proj1_sig x)) (z + FO (name_member (proj1_sig x)))).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. lia.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tstruct.
 eassumption. auto.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (Member_plain i0 t0) (field_type_in_members_strong _ _ _ PLAIN H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 subst D.
 simpl in H1.
 replace z0 with (FO i0).
 apply H1.
 unfold FO. rewrite H2. auto.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 eapply align_compatible_rec_Tstruct_inv in H2; try eassumption.
 instantiate (1:=id). simpl.
 pose proof (get_co_members_no_replicate i).
 unfold get_co in H1. rewrite H in H1. unfold members_no_replicate in H1.
 clear - i0 H1 PLAIN.
 induction (co_members c) as [|[|]]; [ | | discriminate]. inv i0. simpl.
 if_tac. subst.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 exfalso. apply Heqb. apply (in_map name_member) in H. apply H.
 apply IHm. auto.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 auto.
 unfold FO; simpl.
 clear - i0 PLAIN.
 assert (in_members id (co_members c)). unfold in_members. apply (in_map name_member) in i0; auto.
 pose proof (plain_members_field_offset _ PLAIN _ _ H). rewrite H0. auto.
* (* Tunion *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
destruct (plain_members (co_members c)) eqn:?PLAIN;
   [ | right; intro Hx; inv Hx; [ discriminate | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (D := fun x: {it: member | In it (co_members c)} =>
                align_compatible_rec cenv_cs (type_member (proj1_sig x)) z).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. lia.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tunion.
 eassumption. auto.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (Member_plain i0 t0) (field_type_in_members_strong _ _ _ PLAIN H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 apply H1.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0|] ?].
2:{ exfalso. clear - i0 PLAIN.
   induction (co_members c) as [|[|]]; simpl in *; try discriminate; auto. destruct i0; auto. discriminate.
 }
 eapply align_compatible_rec_Tunion_inv in H2; try eassumption.
 instantiate (1:=id). simpl.
 pose proof (get_co_members_no_replicate i).
 unfold get_co in H1. rewrite H in H1. unfold members_no_replicate in H1.
 clear - i0 H1 PLAIN.
 induction (co_members c) as [|[|]]; [ | | discriminate]. inv i0. simpl.
 if_tac. subst.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 exfalso. apply Heqb. apply (in_map name_member) in H. apply H.
 apply IHm; auto.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list id0 (map name_member m)) eqn:?; try discriminate.
 auto.
Qed.

Lemma align_compatible_rec_dec: forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Proof.
intros.
apply align_compatible_dec_aux with (S (rank_type cenv_cs t)).
lia.
Qed.

End align_compatible_rec_dec.

End align_compatible_rec_dec.

Lemma align_compatible_dec: forall {cs: compspecs} t p, {align_compatible t p} + {~ align_compatible t p}.
Proof.
  intros.
  destruct p; try solve [left; unfold align_compatible; simpl; tauto].
  simpl.
  apply align_compatible_rec_dec.align_compatible_rec_dec.
Qed.


Require Import Core.Core Core.Notations Core.Tactics Types
        Exec.Der_write_tags (* BCT.Exec *).
From ExtLib.Structures Require Import Monad MonadWriter.
From ExtLib.Data Require Import Monads.OptionMonad.

Require Export Types.
Require Export ExtLib.Structures.Monad.
From ExtLib.Data Require Export Monads.OptionMonad.

Open Scope monad.

(*Definition primitive_decoder td ls : option (list int * Z) :=
    match ls with
    | [] => None
    | _ => ber_check_tags td ls >>=
                        fun x => let c := tag_consumed x in
                              let l := tag_length x in
                              if (Zlength ls - c <? l)
                              then None
                              else let y := skipn (Z.to_nat c) ls in
                                    Some (y, c + 1)
    end.*)

(* writes tags, copies ls and outputs the number of encoded bytes *)
(* Definition primitive_encoder td ls : errW1 asn_enc_rval :=
  x <- der_write_tags td  ;;
  tell ls ;;
  ret (encode (Zlength ls + encoded x)). *)

Definition ZeroChar := Byte.repr 48.

Definition bool_of_byte (b : byte) :=
  if (b == default_byte)%byte then false else true.
Definition byte_of_bool (b : bool) := Byte.repr (if b then 255 else 0).
Definition int_of_bool (b : bool) := Int.repr (if b then 255 else 0).
Definition bool_of_int (i : int) :=
  if (i == 0)%int then false else true.

(* Find composite *)
Fixpoint find_cs (id : ident) cs : option composite_definition :=
  match cs with
  | Composite i s_u m a :: css => if (i =? id)%positive
                             then Some (Composite i s_u m a)
                             else find_cs id css
  | [] => None
  end.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.algebra Require Import excl agree csum.
From iris.heap_lang Require Import notation par proofmode.
From iris.proofmode Require Import proofmode.
From iris_examples.barrier Require Import proof specification.
From iris.prelude Require Import options.

Definition one_shotR (Σ : gFunctors) (F : oFunctor) :=
  csumR (exclR unitO) (agreeR $ laterO $ oFunctor_apply F (iPropO Σ)).
Definition Pending {Σ F} : one_shotR Σ F := Cinl (Excl ()).
Definition Shot {Σ} {F : oFunctor} (x : oFunctor_apply F (iPropO Σ)) : one_shotR Σ F :=
  Cinr $ to_agree $ Next $ x.

Class oneShotG (Σ : gFunctors) (F : oFunctor) :=
  one_shot_inG :> inG Σ (one_shotR Σ F).
Definition oneShotΣ (F : oFunctor) : gFunctors :=
  #[ GFunctor (csumRF (exclRF unitO) (agreeRF (▶ F))) ].
Global Instance subG_oneShotΣ {Σ F} : subG (oneShotΣ F) Σ → oneShotG Σ F.
Proof. solve_inG. Qed.

Definition client : val :=
  λ: "fM" "fW1" "fW2",
  let: "b" := newbarrier #() in
  ("fM" #() ;; signal "b") ||| ((wait "b" ;; "fW1" #()) ||| (wait "b" ;; "fW2" #())).

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapGS Σ, !barrierG Σ, !spawnG Σ, !oneShotG Σ F}.
Context (N : namespace).
Local Notation X := (oFunctor_apply F (iPropO Σ)).

Definition barrier_res γ (Φ : X → iProp Σ) : iProp Σ :=
  (∃ x, own γ (Shot x) ∗ Φ x)%I.

Lemma worker_spec e γ l (Φ Ψ : X → iProp Σ) :
  recv N l (barrier_res γ Φ) -∗ (∀ x, Φ x -∗ WP e {{ _, Ψ x }}) -∗
  WP wait #l ;; e {{ _, barrier_res γ Ψ }}.
Proof.
  iIntros "Hl He". wp_apply (wait_spec with "Hl"); simpl.
  iDestruct 1 as (x) "[#Hγ Hx]".
  wp_seq. iApply (wp_wand with "[Hx He]"); [by iApply "He"|].
  iIntros (v) "?"; iExists x; by iSplit.
Qed.

Context (P : iProp Σ) (Φ Φ1 Φ2 Ψ Ψ1 Ψ2 : X -n> iPropO Σ).
Context {Φ_split : ∀ x, Φ x -∗ (Φ1 x ∗ Φ2 x)}.
Context {Ψ_join  : ∀ x, Ψ1 x -∗ Ψ2 x -∗ Ψ x}.

Lemma P_res_split γ : barrier_res γ Φ -∗ barrier_res γ Φ1 ∗ barrier_res γ Φ2.
Proof.
  iDestruct 1 as (x) "[#Hγ Hx]".
  iDestruct (Φ_split with "Hx") as "[H1 H2]". by iSplitL "H1"; iExists x; iSplit.
Qed.

Lemma Q_res_join γ : barrier_res γ Ψ1 -∗ barrier_res γ Ψ2 -∗ ▷ barrier_res γ Ψ.
Proof.
  iDestruct 1 as (x) "[#Hγ Hx]"; iDestruct 1 as (x') "[#Hγ' Hx']".
  iAssert (▷ (x ≡ x'))%I as "Hxx".
  { iCombine "Hγ" "Hγ'" as "Hγ2". iClear "Hγ Hγ'".
    rewrite own_valid csum_validI /= agree_validI agree_equivI later_equivI /=.
    rewrite -{2}[x]oFunctor_map_id -{2}[x']oFunctor_map_id.
    assert (HF : oFunctor_map F (cid, cid) ≡ oFunctor_map F (iProp_fold (Σ:=Σ) ◎
        iProp_unfold, iProp_fold (Σ:=Σ) ◎ iProp_unfold)).
    { apply ne_proper; first by apply _.
      by split; intro; simpl; symmetry; apply iProp_fold_unfold. }
    rewrite (HF x). rewrite (HF x').
    rewrite !oFunctor_map_compose. iNext. by iRewrite "Hγ2". }
  iNext. iRewrite -"Hxx" in "Hx'".
  iExists x; iFrame "Hγ". iApply (Ψ_join with "Hx Hx'").
Qed.

Lemma client_spec_new (fM fW1 fW2 : val) :
  WP fM #() {{ _, ∃ x, Φ x }} -∗
  □ (∀ x, Φ1 x -∗ WP fW1 #() {{ _, Ψ1 x }}) -∗
  □ (∀ x, Φ2 x -∗ WP fW2 #() {{ _, Ψ2 x }}) -∗
  WP client fM fW1 fW2 {{ _, ∃ γ, barrier_res γ Ψ }}.
Proof using All.
  iIntros "/= Hf #Hf1 #Hf2"; rewrite /client.
  iMod (own_alloc (Pending : one_shotR Σ F)) as (γ) "Hγ"; first done.
  wp_lam. wp_pures. wp_apply (newbarrier_spec N (barrier_res γ Φ)); auto.
  iIntros (l) "[Hr Hs]".
  set (workers_post (v : val) := (barrier_res γ Ψ1 ∗ barrier_res γ Ψ2)%I).
  wp_smart_apply (par_spec  (λ _, True)%I workers_post with "[Hf Hs Hγ] [Hr]").
  - wp_lam. wp_bind (fM #()). iApply (wp_wand with "Hf").
    iIntros (v) "HP"; iDestruct "HP" as (x) "HP". wp_seq.
    iMod (own_update with "Hγ") as "Hx".
    { by apply (cmra_update_exclusive (Shot x)). }
    iApply (signal_spec with "[- $Hs]"); last auto.
    iExists x; auto.
  - iDestruct (recv_weaken with "[] Hr") as "Hr"; first by iApply P_res_split.
    iMod (recv_split with "Hr") as "[H1 H2]"; first done.
    wp_smart_apply (par_spec (λ _, barrier_res γ Ψ1)%I
                       (λ _, barrier_res γ Ψ2)%I with "[H1] [H2]").
    + wp_smart_apply (worker_spec with "H1"); auto.
    + wp_smart_apply (worker_spec with "H2"); auto.
    + auto.
  - iIntros (_ v) "[_ [H1 H2]]". iDestruct (Q_res_join with "H1 H2") as "?". auto.
Qed.
End proof.


From Undecidability.L Require Import Tactics.LTactics.
From Undecidability.L.Datatypes Require Import Lists LVector LSum LProd LFinType LNat.
From Complexity.Complexity Require Import NP Definitions Monotonic Subtypes.
From Undecidability.L.Functions Require Import EqBool.
From Undecidability.L.TM Require Import TapeFuns.
From Complexity.L.TM Require Import CompCode.

From Undecidability.TM Require Import TM_facts CodeTM.
From Undecidability.TM.Single Require Import EncodeTapes StepTM.

From Complexity.TM Require Import M2MBounds PrettyBounds.SizeBounds.
From Undecidability Require Import TM.Util.VectorPrelim.
From Complexity.Libs Require Import PSLCompat.

Unset Printing Coercions.

(*Import EncodeTapes DecodeTapes Single.StepTM ProgrammingTools Combinators Decode.*)

(*From Undecidability Require Import MultiUnivTimeSpaceSimulation. *)
From Complexity.NP Require Import TMGenNP_fixed_mTM M_multi2mono.

Set Default Proof Using "Type".
Section LMGenNP_to_TMGenNP_mTM.

  Context (sig:finType) (n:nat) `{R__sig : encodable sig}  (M : TM sig (S n)).
  Let M__mono := M__mono M.

  Local Arguments Canonical_Rel : simpl never.
  Local Arguments loopM : clear implicits.
  Local Arguments loopM {_ _ } _ _ _.
  Import L_facts.
  Import EqBool.

  (* From L/TM/Encoding.v *)
  Lemma sizeOfTape_by_size (t:(tape sig)) :
    sizeOfTape t <= size (enc t).
  Proof.
    unfold enc;cbn.
    destruct t;cbn [tapeToList sizeOfTape length size].
    all:rewrite ?app_length,?rev_length. all:cbn [length].
    all:ring_simplify. all:try rewrite !size_list_enc_r. all:try nia.
  Qed.
  Lemma sizeOfmTapes_by_size (t:tapes sig n) :
    sizeOfmTapes t <= size (enc t).
  Proof.
    setoid_rewrite enc_vector_eq. rewrite Lists.size_list.
    erewrite <- sumn_map_le_pointwise with (f1:=fun _ => _). 2:{ intros. setoid_rewrite <- sizeOfTape_by_size. reflexivity. }
    rewrite sizeOfmTapes_max_list_map. unfold MaxList.max_list_map. rewrite max_list_sumn.
    etransitivity. 2:now apply Nat.le_add_r. apply sumn_map_le_pointwise. intros. apply Nat.le_add_r.
  Qed.

  Lemma TMGenNP_mTM_to_TMGenNP_singleTM :
    mTMGenNP_fixed M ⪯p TMGenNP_fixed (projT1 M__mono).
  Proof.
    subst M__mono.
    evar (f__steps : nat*nat*nat -> nat). evar (f__nice : nat*nat*nat -> nat).
    enough (Hf__nice : f__steps <=c f__nice).
    unfold mTMGenNP_fixed,mTMGenNP_fixed',TMGenNP_fixed. cbn.
    set (t__start:=fun (ts : tapes sig n) => inl START::concat (map (fun t => inr (sigList_cons)::map (fun s => inr (sigList_X s)) (encode_tape t)) (Vector.to_list ts))++[inr (sigList_cons)]).
    set (t__size := fun maxSize => 3 + if eqb 0 maxSize then 0 else 1 + maxSize).
    eapply reducesPolyMO_intro_restrictBy_in with
        (f:=fun '(ts,maxSize,steps) => (t__start ts
                                     ,t__size maxSize
                                     ,  c__leUpToC (H:=Hf__nice) * f__nice (steps,sizeOfmTapes ts,maxSize)+ 3)).
    2:{ unfold execTM.
        intros [[v maxSize] steps]. unfold HaltsOrDiverges_mTM_fixed. intros H_HaltOrDiv.
        split.
        -intros (t1&Ht1&s__end&Hs__end).
         eexists (map (fun c => inr (sigList_X c)) (encode_tape t1) ++ [inr sigList_nil;inl STOP]).
         split. 1:{ cbn - [plus]. autorewrite with list. rewrite sizeOfTape_encodeTape. cbn - [Nat.eqb].
                    destruct (Nat.eqb_spec 0 (sizeOfTape t1));
                      destruct (eqb_spec 0 (maxSize)). all:try nia.
         }
         edestruct Terminates__mono as (?&?).
         2:{ eexists. cbn. unfold execTM. rewrite H. easy. }
         cbn. set (tin:=midtape _ _ _).
         eexists (select (putFirstAtEnd n) (t1:::v)), _.
         assert (Ht1v:contains_tapes tin (select (putFirstAtEnd n) (t1 ::: v))).
         { hnf. subst tin. f_equal. unfold encode_tapes.
           rewrite encode_list_concat.
           autorewrite with list. cbn. rewrite !concat_map,!map_map.
           rewrite putFirstAtEnd_to_list.
           autorewrite with list. cbn. repeat setoid_rewrite map_map.
           rewrite concat_app;cbn. autorewrite with list. easy.
         } split. easy.
         split. 2:easy. hnf.
         (do 2 eexists). split.
         +intros ? ?. cbn in H. replace v0 with ((select (putFirstAtEnd n) (t1 ::: v))) in * by now eapply contains_tapes_inj. clear v0 H.
          split. 1: {hnf. rewrite putEnd_invL. eauto. }
          assert (H':=proj2_sig M2MBounds.Loop_steps_nice). hnf in H'.
          unfold PrettyBounds.dominatedWith in H'.
          rewrite H'. rewrite putFirstAtEnd_to_list.
          rewrite BaseCode.encodeList_size_app,size_list, Vector.length_to_list.
          unfold Code.size. cbn - [mult plus].
          autorewrite with list. cbn [length]. rewrite sizeOfTape_encodeTape_le.
          erewrite sumn_map_le_pointwise with (f2:=fun x => _).
          2:{ intros. rewrite sizeOfTape_encodeTape_le. rewrite sizeOfmTapes_upperBound. 2:now eapply Vector.to_list_In. reflexivity. }
          rewrite !sumn_map_c, Vector.length_to_list.
          unshelve erewrite ( _ : (n * (2 + sizeOfmTapes v) + n + 1 + S (2 + sizeOfTape t1 + 1) + S n * steps)
                                  <= ((steps + sizeOfmTapes v + 5)* S n + sizeOfTape t1)). nia.
          reflexivity.
         +cbn - [mult plus]. autorewrite with list; cbn - [plus mult].
          rewrite length_concat,map_map;cbn - [plus mult];setoid_rewrite map_length.
          rewrite sizeOfTape_encodeTape_le,Ht1.
          rewrite sumn_le_bound.
          2:{ intros ? (?&<-&?)%in_map_iff.
              rewrite sizeOfTape_encodeTape_le, sizeOfmTapes_upperBound. 2:now apply Vector.to_list_In. reflexivity. }
          rewrite map_length. rewrite Vector.length_to_list.
          replace (1 + (2 + maxSize + 2)) with (maxSize + 5) by lia.
          setoid_rewrite <- correct__leUpToC.
          [f__steps]:refine (fun '(steps, sizeOfmTapes, maxSize) =>  _).
          set (sizeOfmTapes _). unfold f__steps. reflexivity.
        -intros (cert&Hsize&f'&Hf'). destruct @loopM as [f| ] eqn:Hf. all:cbn -[plus mult t__start] in *. 2:now inv Hf'. clear Hf' f'.
         apply Realises__mono in Hf as (v0&v1&Hv0&Hv1&H__mono). cbn in Hv0.
         hnf in H__mono;cbn in H__mono. unfold LiftTapes in H__mono;cbn in H__mono.
         destruct H__mono as (outc&k&Hout&<-&_).
         hnf in Hv0. revert Hv0. intros [= Htl].
         unfold encode_tapes in Htl;rewrite encode_list_concat in Htl.
         rewrite map_app,concat_map,map_map in Htl. cbn in Htl.
         setoid_rewrite map_map in Htl. rewrite <- !app_assoc in Htl. cbn in Htl.
         assert (H':=Htl). eapply concat_eq_inv_borderL with (isBorder := fun c => c = inr sigList_cons) in H'. rewrite map_length, Vector.length_to_list in H'.
         5:easy. 4:now cbn;intuition subst.
         2,3:intros _ (x&<-&Hinx)%in_map_iff. 2,3:eexists _,_;split;[reflexivity | ].
         2,3:now split;[easy | intros ? (y&<-&Hiny)%in_map_iff;easy].
         destruct H' as [Hinit Hlast]. rewrite skipn_map in Hlast.
         destruct (split_vector v0 n) as (v'&vlst) eqn:Hsplit.
         unshelve eassert (H':=split_vector_correct _ _). 6:rewrite Hsplit in H'. clear. abstract nia.
         cbn [fst snd] in H'. apply (f_equal (@vector_to_list _ _ )) in H'. rewrite vector_to_list_cast in H'. clear Hsplit.
         rewrite Vector.to_list_append in H'.
         revert v' vlst H'. replace (Init.Nat.min n (S n)) with n by nia. replace (S n - n) with 1 by nia.
         intros v' vlst eq. destruct_vector (* vlst as h *). cbn in eq.
         rewrite <- eq in Hlast,Hinit.
         replace v' with v in *.
         2:{ eapply VectorSpec.eq_nth_iff. intros i ? <-.
             unshelve eassert (Htmp:=Hinit (proj1_sig (Fin.to_nat i)) _). { now destruct Fin.to_nat. }
             destruct (Fin.to_nat i) eqn:Hi.
             rewrite map_app,<-!Vector.to_list_map in Htmp.
             rewrite nth_error_app1 in Htmp. 2:now rewrite Vector.length_to_list.
             cbn in Htmp. rewrite !vector_nth_error_nat in Htmp.
             destruct lt_dec. 2:easy.
             rewrite !nth_map' in Htmp. revert Htmp. intros [= Htmp].
             apply map_injective in Htmp. 2:congruence. apply DecodeTape.tape_encode_injective in Htmp.
             rewrite <- (Fin.of_nat_to_nat_inv i).  rewrite Hi;cbn.
             erewrite Fin.of_nat_ext. apply Htmp.
         }
         clear Hinit v'.
         rewrite skipn_app in Hlast. 2:now rewrite Vector.length_to_list. cbn in Hlast.
         autorewrite with list in Hlast. cbn in Hlast. revert Hlast. intros [= ->].
         edestruct H_HaltOrDiv as (?&?&?&?).
         2:now eauto.
         assert (Hts__size : sizeOfTape h <= maxSize).
         1:{ autorewrite with list in Hsize.  rewrite sizeOfTape_encodeTape in Hsize. unfold t__size in *.
             destruct (eqb_spec 0 maxSize);destruct sizeOfTape. all:cbn in Hsize;try nia. }
         clear Hsize. unfold initc in *. cbn in Hout.
         unshelve eassert (Htmp := LiftTapes_lift _ _). 11:{ now rewrite Hout. } now apply putEndAtFirst_dupfree.
         cbn in Htmp. unfold selectConf in Htmp. cbn in Htmp.

         erewrite putEndAtFirst_to_list in Htmp. 2:exact eq. eassumption.
    }
    2:{

      unfold f__steps.
      enough ((fun _ => 1) <=c f__nice).
      smpl upToC.
      1,2:smpl_upToC.
      3:{ [f__nice]: exact (fun '(x,y,z) => (fun s => s*s*S x) (S x + y + z)).
          subst f__nice.
          set (c:= 5*(S n) + 1).
          exists (c * c).
          intros [[x y] z].
          set (s:=S x+y+z).
          unshelve erewrite (_ : (x + y + 5) * S n + z <= c*s). 1:{ unfold s,c. nia. }
          nia.
      }
      all:unfold f__nice. all:smpl_upToC_solve.
    }

    assert (polyTimeComputable f__nice).
    {
      evar (time : nat -> nat). [time]:intros n0.
      eexists (fun x => time x).
      { unfold f__nice. extract. solverec.
        set (n0:=(L_facts.size (enc (a0, b0, b)))).
        assert (a0+b0+b+1 <= n0). 1:{ unfold n0. rewrite !size_prod. cbn [fst snd]. rewrite !size_nat_enc.
          unfold c__natsizeS, c__natsizeO; nia. }
        unfold add_time, mult_time.
        unshelve erewrite (_ : a0 <= n0). nia. unshelve erewrite (_ : b0 <= n0). nia. unshelve erewrite (_ : b <= n0). nia.
        unfold time. reflexivity. }
      1,2:unfold time;smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros [[a0 b0] b]. unfold f__nice.
          set (n0:=(L_facts.size (enc (a0, b0, b)))).
          assert (a0+b0+b+1 <= n0). 1:{ unfold n0. rewrite !size_prod. cbn [fst snd]. rewrite !size_nat_enc.
            unfold c__natsizeS, c__natsizeO; nia. }
          rewrite size_nat_enc.
          unshelve erewrite (_ : a0 <= n0). nia. unshelve erewrite (_ : b0 <= n0). nia. unshelve erewrite (_ : b <= n0). nia.
          change S with (plus 1).
          unfold f__size;reflexivity.
        }
        all:unfold f__size;smpl_inO.
      }
    }
    clearbody f__nice.

    assert (polyTimeComputable t__size).
    {
      evar (c0 : nat).
      eexists (fun _ => c0).
      { unfold t__size. extract. solverec. all:rewrite eqbTime_le_l.
        all:set (c:=L_facts.size (enc 0)). all:cbv in c;subst c. all:subst c0. 2:easy. nia. }
      1,2:smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros x. unfold t__size.
          set (n0:=(L_facts.size (enc x))).
          assert (Hx:x<=n0) by apply size_nat_enc_r.
          rewrite size_nat_enc. destruct _. 2:rewrite Hx;unfold f__size;reflexivity. unfold f__size. nia.
        }

        all:unfold f__size;smpl_inO.
      }
    }clearbody t__size.

    assert (polyTimeComputable t__start).
    {
      set (f:=fun s : sigTape sig => inr (sigList_X s)) in t__start.
      assert ( {f__c:UpToC (fun _ => 1) & computableTime' f (fun _ _ => (f__c tt,tt))}) as [t__f comp__f].
      {  evar (c:nat). exists_UpToC (fun _ => c). unfold f. clear_all. extract. solverec. [c]:exact 3. now unfold c. subst c. smpl_upToC_solve. }

      set (g:= (fun t : tape sig => inr sigList_cons :: map f (encode_tape t))) in t__start.
      assert ( {t__g:UpToC (fun t=> sizeOfTape t + 1) & computableTime' g (fun t _ => (t__g t,tt))}) as [t__g comp__g].
      {  evar (t__c: tape sig -> nat). [t__c]:intro. exists_UpToC t__c. unfold g.
         extract. solverec.
         rewrite map_time_const,sizeOfTape_encodeTape_le. all:unfold t__c. reflexivity. smpl_upToC_solve.
      }

      evar (time : nat -> nat). [time]:intros n0.
      eexists (fun x => time x).
      { unfold t__start. extract. solverec. rewrite (UpToC_le _).
        rewrite (correct__leUpToC (mapTime_upTo _)).
        rewrite length_concat,map_map. subst g. cbn -[plus mult]. setoid_rewrite map_length. rewrite Vector.length_to_list.
        erewrite sumn_map_le_pointwise  with (f2:=fun _ => _).
        2:{ intros;rewrite (UpToC_le t__g),sizeOfmTapes_upperBound;try reflexivity;now apply Vector.to_list_In. }
        erewrite sumn_map_le_pointwise with (f1:=fun x1 : tape sig => S (| encode_tape x1 |)) (f2:=fun _ => _).
        2:{ intros. setoid_rewrite sizeOfTape_encodeTape_le at 1. rewrite sizeOfmTapes_upperBound at 1. 2:now apply Vector.to_list_In.
            reflexivity. }
        rewrite sumn_map_c, Vector.length_to_list.
        rewrite sumn_map_c, Vector.length_to_list.
        rewrite sizeOfmTapes_by_size. set (L_facts.size _).
        unfold time. reflexivity.
      }
      1,2:now unfold time;change S with (plus 1);smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros x. unfold t__start.
          rewrite size_list_cons. subst g f.
          rewrite Lists.size_list. rewrite map_app,concat_map,map_map. cbn. setoid_rewrite map_map. rewrite sumn_app.
          assert (H' : forall l, sumn (concat l) = sumn (map sumn l)). 1:{induction l;cbn;now autorewrite with list. }
          rewrite H',map_map. cbn. set (tmp:=size (enc (inr sigList_cons)));cbv in tmp;subst tmp.
          setoid_rewrite size_sum. rewrite size_boundary. setoid_rewrite size_sigList.
          repeat setoid_rewrite <- Nat.add_assoc.  ring_simplify. ring_simplify (7 + (4 + 5)).
          repeat setoid_rewrite sumn_map_add. repeat setoid_rewrite sumn_map_c. setoid_rewrite sumn_map_mult_c_r.
          setoid_rewrite sumn_map_le_pointwise with (f2:=fun x => _) at  3 4 5.
          2,3,4: (setoid_rewrite sizeOfTape_encodeTape_le;intros;rewrite sizeOfmTapes_upperBound at 1; [ | now apply Vector.to_list_In]; reflexivity).
          rewrite sumn_map_c.
          setoid_rewrite sumn_map_le_pointwise with (f2:=fun x => _).
          2:{ intros. setoid_rewrite sumn_map_le_pointwise with (f2:=fun x => _).
              2:{ intros. apply (correct__leUpToC (size_finType_any_le_c (X:=finType_CS (sigTape sig)))). }
              rewrite sumn_map_c. rewrite sizeOfTape_encodeTape_le,  sizeOfmTapes_upperBound. 2:now apply Vector.to_list_In. reflexivity. }
          rewrite sumn_map_c. rewrite Vector.length_to_list. setoid_rewrite sizeOfmTapes_by_size.
          set (n0:= L_facts.size _). ring_simplify. unfold f__size. reflexivity.
        }
        all:unfold f__size;smpl_inO.
      }
    }
    clearbody f__steps t__start.
(*    assert (polyTimeComputable (@sizeOfmTapes sig n)) by apply ptc_sizeOfmtapes. *)

    evar (time : nat -> nat). [time]:intros n0.
      eexists (fun x => time x).
      {
        extract. solverec.
        remember (L_facts.size (enc (a0, b0, b))) as n0 eqn:Hn0.
        rewrite !size_prod in Hn0. cbn [fst snd] in Hn0.
        erewrite (mono__polyTC X0 (x':=n0)). 2:{ subst n0. repeat set (L_facts.size _). nia. }
        rewrite (mono__polyTC X1 (x':=n0)). 2:{ subst n0. repeat set (L_facts.size _). nia. }
        set (c0 := 5+c__natsizeO +c__natsizeS).
        assert (H'' : L_facts.size (enc (b, sizeOfmTapes a0, b0)) <= n0*c0).
        {  rewrite !size_prod. cbn [fst snd]. setoid_rewrite size_nat_enc at 2.
            rewrite sizeOfmTapes_by_size. subst n0. repeat set (L_facts.size _). nia. }
        setoid_rewrite (mono__polyTC X (x':=n0*c0)). 2:exact H''.
        specialize (bounds__rSP (f:=f__nice)) as H'. setoid_rewrite <- size_nat_enc_r in H'.
        unfold mult_time, add_time.
        unshelve rewrite H'. now apply resSize__polyTC.
        setoid_rewrite mono__rSP. 2,3:exact H''.
        rewrite sizeOfmTapes_by_size at 1. unshelve erewrite (_ : L_facts.size (enc a0) <= n0). now (subst n0;clear;repeat set (L_facts.size _);nia).
        unfold time. reflexivity.
      }
      1,2:now unfold time;smpl_inO;apply inOPoly_comp;smpl_inO.
      { evar (f__size : nat -> nat). [f__size]:intros n0. exists f__size.
        { intros [[a0 b0] b]. remember (L_facts.size (enc (a0, b0, b))) as n0 eqn:Hn0.
          rewrite !size_prod in Hn0|-*. cbn [fst snd] in Hn0|-*. rewrite !size_nat_enc.
          assert (H'' : L_facts.size (enc (b, sizeOfmTapes a0, b0)) <= n0*(5 + c__natsizeS + c__natsizeO)).
        {  rewrite !size_prod. cbn [fst snd]. setoid_rewrite size_nat_enc at 2.
           rewrite sizeOfmTapes_by_size. subst n0. repeat set (L_facts.size _). nia. }
        specialize (bounds__rSP (f:=f__nice)) as H'. setoid_rewrite <- size_nat_enc_r in H'.
        unshelve rewrite H'. now apply resSize__polyTC.
        setoid_rewrite mono__rSP. 2:exact H''.

        specialize (bounds__rSP (f:=t__size)) as Hsize. setoid_rewrite <- size_nat_enc_r in Hsize at 1.
        unshelve rewrite Hsize. now apply resSize__polyTC.
        setoid_rewrite (mono__rSP _ (x':=n0)) at 1 . 2:nia.

        specialize (bounds__rSP (f:=t__start)) as Hstart.
        unshelve rewrite Hstart. now apply resSize__polyTC.
        setoid_rewrite (mono__rSP _ (x':=n0)) at 1 . 2:subst;clear;repeat (set (L_facts.size _));nia.
        unfold f__size. reflexivity.
        }
        1,2:unfold f__size;smpl_inO; apply inOPoly_comp;smpl_inO.

      }

  Qed.

  (* Print Assumptions LMGenNP_to_TMGenNP_mTM. *)

End LMGenNP_to_TMGenNP_mTM.


(*
  This file is part of the verified smart contract project of SECBIT Labs.

  Copyright 2018 SECBIT Labs

  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 3 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
  Lesser 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, see <https://www.gnu.org/licenses/>.
*)

Require Export Model.
Require Export Lists.List.

(*
  A specification of a function consists of:
    1) [spec_require] requirements via the `require()` calls
    2) [spec_events ] events generated via event calls
    3) [spec_trans  ] state transition done by the function
*)
Record Spec: Type :=
  mk_spec {
      spec_require: state -> Prop;
      spec_events: state -> eventlist -> Prop;
      spec_trans: state -> state -> Prop
    }.

(*
  This specification follows the smart contract as implemented in
    https://github.com/ConsenSys/Tokens/blob/master/contracts/eip20/EIP20.sol
*)

(*
    constructor(uint256 _initialAmount, string _name, string _symbol, uint8 _decimals, uint256 _unLockTime) public {

        require (_unLockTime >= block.timestamp);
        totalSupply = _initialAmount;
        balances[msg.sender] = _initialAmount;
        name = _name;
        symbol = _symbol;
        decimals = _decimals;
        UnLockTime = _unLockTime;
        emit Transfer(0x0, msg.sender, _initialAmount);
    }
*)
Definition funcspec_constructor (_initialAmount: uint256) (_tokenName: string)
            (_tokenSymbol: string)(_decimalUnits: uint8)(_unLockTime: uint256) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (* No require in this function. *)
       (fun S : state => _unLockTime >= env_time env)

       (* Models an constructor event here. *)
       (fun S E => E = ((ev_constructor (m_sender msg) _initialAmount _tokenName _tokenSymbol _decimalUnits _unLockTime):: (ev_Transfer (m_sender msg) 0  (m_sender msg) _initialAmount) :: nil))

       (* State transition: *)
       (fun S S' : state =>
       (* totalSupply = _initialAmount;                        // Update total supply *)
          st_totalSupply S' = _initialAmount /\
       (* Name = _tokenName;                                   // Set the name for display purposes *)
          st_name S' = _tokenName /\
       (* decimals = _decimalUnits;                            // Amount of decimals for display purposes *)
          st_decimals S' = _decimalUnits /\
       (* symbol = _tokenSymbol;                               // Set the symbol for display purposes *)
          st_symbol S' =  _tokenSymbol /\
       (* balances[msg.sender] = _initialAmount;               // Give the creator all initial tokens *)
          st_balances S' = $0 $+ {m_sender msg <- _initialAmount} /\
       (* Init to all zero. *)
          st_allowed S' = $0 /\
       (* st_owner = msg.sender *)
          st_owner S' = (m_sender msg) /\
       (* UnLockTime = _unLockTime *)
          st_unLockTime S'= _unLockTime
       )
    ).

(*
function name() public view returns (string){
   return name;
}
 *)
Definition funcspec_name :=
  fun (this: address)(env: env)(msg: message) =>
    (mk_spec
        (* No require in this function. *)
       (fun S : state => True)

        (* return name; *)
       (fun S E => E = (ev_return _ (st_name S)) :: nil)

       (* Unchanged. *)
       (fun S S' : state => S = S')
    ).

(*
    function symbol() public view returns (string){
        return symbol;
    }
*)
Definition funcspec_symbol :=
    fun (this: address)(env: env)(msg: message) =>
    (mk_spec
        (* No require in this function. *)
       (fun S : state => True)

        (* return name; *)
       (fun S E => E = (ev_return _ (st_symbol S)) :: nil)

       (* Unchanged. *)
       (fun S S' : state => S = S')
    ).

(*
function decimals() public view returns (uint8){
   return decimals;
}
 *)
Definition funcspec_decimals :=
    fun (this: address)(env: env)(msg: message) =>
    (mk_spec
        (* No require in this function. *)
       (fun S : state => True)

        (* return name; *)
       (fun S E => E = (ev_return _ (st_decimals S)) :: nil)

       (* Unchanged. *)
       (fun S S' : state => S = S')
    ).

(*
function totalSupply() public view returns (uint256){
        return totalSupply;
    }
*)
Definition funcspec_totalSupply :=
  fun (this: address)(env: env)(msg:message) =>
    (mk_spec
       (* No require in this function. *)
       (fun S : state => True)

        (* return totalSupply_; *)
       (fun S E => E = (ev_return _ (st_totalSupply S)) :: nil)

       (* Unchanged. *)
       (fun S S' : state => S = S')
    ).

(*
    function balanceOf(address _owner) public view returns (uint256){
        return balances[_owner];
    }
*)
Definition funcspec_balanceOf
           (owner: address) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (* No requirement *)
       (fun S : state => True)

       (* return balances[_owner]; *)
       (fun S E => E = (ev_return _ (st_balances S owner)) :: nil)

       (* Unchanged. *)
       (fun S S' : state => S = S')
    ).

(*
function transfer(address _to, uint256 _value) isUnLocked public returns (bool success){
        require (balances[_to] + _value >= balances[_to]);
        require (balances[msg.sender] >= _value);
        balances[_to] = balances[_to] + _value;
        balances[msg.sender] = balances[_to] + _value;
        emit Transfer(msg.sender, _to, _value);
        return true;
    }
*)
Definition funcspec_transfer
           (to: address)
           (value: value) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (fun S : state =>
            (* block.timestamp > UnLockTime *)
           (env_time env >= st_unLockTime S /\
            (*  balances[msg.sender]>= _value *)
            st_balances S (m_sender msg ) >= value /\
            (* balances[_to] + _value <= MAX_UINT256 *)
           (st_balances S to <= MAX_UINT256 - value)))

       (* emit Transfer(msg.sender, _to, _value); *)
       (* return True; *)
       (fun S E => E = (ev_Transfer (m_sender msg) (m_sender msg) to value) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
       (* balances[msg.sender] -= _value; *)
          st_balances S' = (st_balances S) $+{ (m_sender msg) <- -= value }
       (* balances[_to] += _value; *)
                                           $+{ to <- += value }
       (* Unchanged. *)
          /\ st_allowed S' = st_allowed S
          /\ st_owner S' =  st_owner S
          /\ st_unLockTime S' = st_unLockTime S
       )
    ).

(*
    function transferFrom(address _from, address _to, uint256 _value) isUnLocked public returns (bool success){
        uint256 allowance = allowed[_from][msg.sender];
        require (balances[_to] + _value >= balances[_to]);
        require (balances[_from] >= _value);
        require (allowance >= _value);
        balances[_to] = balances[_to] + _value;
        balances[_from] = balances[_from] - _value;

        if (allowance < MAX_UINT256) {
            allowed[_from][msg.sender] = allowed[_from][msg.sender] - _value;
        }
        emit Transfer(_from, _to, _value);
        return true;
    }
*)
Definition funcspec_transferFrom_1
           (from: address)
           (to: address)
           (value: value) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (fun S : state =>
        (* block.timestamp > UnLockTime *)
       env_time env >= st_unLockTime S /\
       (* _value <= balances[_from] *)
         st_balances S from >= value /\
       (* balances[_to] + _value <= MAX_UINT256 *)
         st_balances S to <= MAX_UINT256 - value /\
        (* _value <= allowed[_from][msg.sender] *)
         st_allowed S (from, m_sender msg) >= value /\
       st_allowed S (from, m_sender msg) < MAX_UINT256)

       (* emit Transfer(_from, _to, _value); *)
       (* return True; *)
       (fun S E => E = (ev_Transfer (m_sender msg) from to value) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
       (* balances[_from] -= _value; *)
          st_balances S' = (st_balances S) $+{ from <- -= value }
       (* balances[_to] += _value; *)
                                           $+{ to <- += value } /\
       (* allowed[_from][msg.sender] -= _value; *)
          st_allowed S' = (st_allowed S) $+{ from, (m_sender msg) <-  -= value} /\
          st_owner S' = st_owner S /\
          st_unLockTime S' = st_unLockTime S

       )
    ).

Definition funcspec_transferFrom_2
           (from: address)
           (to: address)
           (value: value) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (fun S : state =>
        (* block.timestamp > UnLockTime *)
       env_time env >= st_unLockTime S /\
       (* _value <= balances[_from] *)
         st_balances S from >= value /\
       (* balances[_to] + _value <= MAX_UINT256 *)
         st_balances S to <= MAX_UINT256 - value /\
        (* _value <= allowed[_from][msg.sender] *)
         st_allowed S (from, m_sender msg) >= value /\
       st_allowed S (from, m_sender msg) = MAX_UINT256)

       (* emit Transfer(_from, _to, _value); *)
       (* return True; *)
       (fun S E => E = (ev_Transfer (m_sender msg) from to value) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
       (* balances[_from] -= _value; *)
          st_balances S' = (st_balances S) $+{ from <- -= value }
       (* balances[_to] += _value; *)
                                           $+{ to <- += value } /\
       (* allowed[_from][msg.sender] -= _value; *)
          st_allowed S' = st_allowed S /\
          st_owner S' = st_owner S /\
          st_unLockTime S' = st_unLockTime S

       )
    ).

(*
 function approve(address _spender, uint256 _value) isUnLocked public returns (bool){
        allowed[msg.sender][_spender] = _value;
        emit Approval(msg.sender, _spender, _value);
        return true;
    }
*)
Definition funcspec_approve
           (spender: address)
           (value: value) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (* block.timestamp > UnLockTime *)
       (fun S : state => (env_time env >= st_unLockTime S))

       (* emit Approval(msg.sender, _spender, _value); *)
       (* return True; *)
       (fun S E => E = (ev_Approval (m_sender msg) (m_sender msg) spender value) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
          st_balances S' = st_balances S /\
       (* allowed[msg.sender][_spender] = _value; *)
          st_allowed S' = (st_allowed S) $+{ m_sender msg, spender <- value} /\
          st_owner S' = st_owner S /\
          st_unLockTime S' = st_unLockTime S
       )
    ).

(*
function allowance(address _owner, address _spender) public view returns (uint256){
        return allowed[_owner][_spender];
    }
*)
Definition funcspec_allowance (owner: address) (spender: address) :=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (* No requirement *)
       (fun S : state => True)

       (* return allowed[_owner][_spender]; *)
       (fun S E => E = (ev_return _ (st_allowed S (owner, spender))) :: nil)

       (* Unchanged. *)
       (fun S S' : state => S' = S)
    ).

(*
function increaseApproval(address _spender, uint _addedValue) isUnLocked public returns (bool) {

        require (allowed[msg.sender][_spender]+ _addedValue >= allowed[msg.sender][_spender]);
        allowed[msg.sender][_spender] = allowed[msg.sender][_spender]+ _addedValue;
        emit Approval(msg.sender, _spender, allowed[msg.sender][_spender]);
        return true;
    }
 *)
Definition funcspec_increaseApproval (spender: address)(addValue: value):=
  fun (this: address) (env: env) (msg: message) =>
    (mk_spec
       (fun S : state =>
           (* block.timestamp > UnLockTime *)
          (env_time env >= st_unLockTime S /\
           st_allowed S (m_sender msg , spender) + addValue <= MAX_UINT256)
        )

       (* emit Approval(msg.sender, _spender, _value); *)
       (* return True; *)
       (fun S E => E = (ev_Approval (m_sender msg) (m_sender msg) spender (st_allowed S (m_sender msg, spender) )) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
          st_balances S' = st_balances S /\
       (* allowed[msg.sender][_spender] = _value; *)
          st_allowed S' = (st_allowed S) $+{ m_sender msg, spender <- += addValue} /\
          st_owner S' = st_owner S /\
          st_unLockTime S' = st_unLockTime S
       )
    ).

(*
function decreaseApproval(address _spender, uint _subtractedValue) isUnLocked public returns (bool success) {

        uint oldValue = allowed[msg.sender][_spender];
        if (_subtractedValue > oldValue) {
            allowed[msg.sender][_spender] = 0;
        } else {
            allowed[msg.sender][_spender] = oldValue - _subtractedValue;
        }
        emit Approval(msg.sender, _spender, allowed[msg.sender][_spender]);
        return true;
    }
 *)
Definition funcspec_decreaseApproval_1 (spender: address)(subValue: value) :=
  fun (this: address)(env: env)(msg: message) =>
    (mk_spec
       (* !stopped  *)
       (fun S : state =>
          (* block.timestamp > UnLockTime *)
          (env_time env >= st_unLockTime S /\
           (st_allowed S (m_sender msg, spender ) < subValue)))

       (* emit Approval(msg.sender, _spender, 0); *)
       (* return True; *)
       (fun S E => E = (ev_Approval (m_sender msg) (m_sender msg) spender 0) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
          st_balances S' = st_balances S /\
          (* allowed[msg.sender][_spender] = 0; *)
          st_allowed S' = (st_allowed S) $+{ m_sender msg, spender <- 0} /\
          st_owner S' = st_owner S /\
          st_unLockTime S' = st_unLockTime S
       )
  ).

Definition funcspec_decreaseApproval_2 (spender: address)(subValue: value) :=
  fun (this: address)(env: env)(msg: message) =>
    (mk_spec
       (* !stopped  *)
       (fun S : state =>  (* block.timestamp > UnLockTime *)
          (env_time env >= st_unLockTime S /\
              (st_allowed S (m_sender msg, spender ) >= subValue)))

       (* emit Approval(msg.sender, _spender, 0); *)
       (* return True; *)
       (fun S E => E = (ev_Approval (m_sender msg) (m_sender msg) spender (st_allowed S (m_sender msg, spender))) :: (ev_return _ True) :: nil)

       (* State transition: *)
       (fun S S' : state =>
       (* Unchanged. *)
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
          st_balances S' = st_balances S /\
          (* allowed[msg.sender][_spender] = 0; *)
          st_allowed S' = (st_allowed S) $+{ m_sender msg, spender <- -= subValue } /\
          st_owner S' = st_owner S /\
           st_unLockTime S' = st_unLockTime S
       )
    ).

(*
funcspec transferOwnership(address newOwner){
    requir: msg.sender = owner and newOwner != address(0)
    {
        pre: True
        event: @OwnershipTransferred(owner, newOwner)
        post: owner' = newOwner
    }
}
*)
Definition funcspec_transferOwnership (newOwner: address) :=
  fun (this: address)(env: env)(msg: message) =>
    (mk_spec
       (* msg.sender = owner and newOwner != address(0) *)
       (fun S : state => (m_sender msg = st_owner S) /\ (newOwner <> 0))
       (* emit OwnershipTransferred(owner, newOwner); *)
       (fun S E => E = (ev_OwnershipTransferred (st_owner S) newOwner):: nil)
       (* State transition: *)
       (fun S S': state =>
          st_totalSupply S' = st_totalSupply S /\
          st_name S' = st_name S /\
          st_decimals S' = st_decimals S /\
          st_symbol S' = st_symbol S /\
          st_balances S' = st_balances S /\
          st_allowed S' =  st_allowed S /\
          st_owner S' = newOwner /\
           st_unLockTime S' = st_unLockTime S
       )
    ).

(* Constructor invocation. *)
Inductive create : env -> message -> contract -> eventlist -> Prop :=
  | create_Constructor : forall env msg S C E sender _initialAmount _tokenName _tokenSymbol _decimalUnits _unLockTime spec preP evP postP,
      msg = mk_msg sender (mc_constructor _initialAmount _tokenName _tokenSymbol _decimalUnits _unLockTime) 0
      -> spec = funcspec_constructor _initialAmount _tokenName _tokenSymbol _decimalUnits _unLockTime (w_a C) env msg
      -> _initialAmount <= MAX_UINT256
      -> preP = spec_require spec
      -> evP = spec_events spec
      -> postP = spec_trans spec
      -> evP S E /\ postP S (w_st C)
      -> create env msg C E.

(* Evaluation step: any of the possible invocations. *)
Inductive step : env -> contract -> message -> contract -> eventlist -> Prop :=
  | step_totalSupply: forall env sender msg spec C C' E' preP evP postP,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_totalSupply) 0
      -> spec = funcspec_totalSupply  (w_a C) env msg
      -> preP = spec_require spec
      -> evP = spec_events spec
      -> postP = spec_trans spec
      -> preP (w_st C) /\ evP (w_st C) E' /\ postP (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_transfer: forall env msg C C' E' sender  to v spec preP evP postP,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_transfer to v) 0
      -> spec = funcspec_transfer to v (w_a C) env msg
      -> preP = spec_require spec
      -> evP = spec_events spec
      -> postP = spec_trans spec
      -> preP (w_st C) /\ evP (w_st C) E' /\ postP (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_balanceOf : forall env sender msg owner spec C C' E' ,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_balanceOf owner) 0
      -> spec = funcspec_balanceOf owner (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_transferFrom_1 : forall env sender msg from to v spec C C' E' ,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_transferFrom from to v) 0
      -> spec = funcspec_transferFrom_1 from to v (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_transferFrom_2 : forall env sender msg from to v spec C C' E' ,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_transferFrom from to v) 0
      -> spec = funcspec_transferFrom_2 from to v (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_approve : forall env sender msg spender v spec C C' E' ,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_approve spender v) 0
      -> spec = funcspec_approve spender v (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_allowance : forall env sender msg owner spender spec C C' E' ,
      w_a C = w_a C'
      -> msg = mk_msg sender (mc_allowance owner spender) 0
      -> spec = funcspec_allowance owner spender (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_increaseApproval: forall env sender msg spender addValue spec C C' E',
       w_a C = w_a C'
      -> msg = mk_msg sender (mc_approve spender addValue) 0
      -> spec = funcspec_increaseApproval spender addValue (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_decreaseApproval_1: forall env sender msg spender subValue spec C C' E',
       w_a C = w_a C'
      -> msg = mk_msg sender (mc_approve spender subValue) 0
      -> spec = funcspec_decreaseApproval_1 spender subValue (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  |  step_decreaseApproval_2: forall env sender msg spender subValue spec C C' E',
       w_a C = w_a C'
      -> msg = mk_msg sender (mc_approve spender subValue) 0
      -> spec = funcspec_decreaseApproval_2 spender subValue (w_a C) env msg
      -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
      -> step env C msg C' E'

  | step_transferOwnership: forall env sender msg newOwner spec C C' E',
      w_a C = w_a C'
     -> msg = mk_msg sender (mc_OwnershipTransferred newOwner) 0
     -> spec = funcspec_transferOwnership newOwner (w_a C) env msg
     -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
     -> step env C msg C' E'
.

(* Evaluation step for the environment. *)
Definition env_step (env1: env) (env2: env) : Prop :=
  env_time env2 >= env_time env1 /\ env_bhash env2 <> env_bhash env1.

(* Big step *)
Fixpoint steps (env: env) (C: contract) (ml: list message) (env': Model.env) (C': contract) (E: eventlist) :Prop :=
  match ml with
    | nil => C' = C /\ E = nil /\ env = env'
    | cons msg ml => exists env'', exists C'', exists E'', exists E',
                    step env C msg C'' E'' /\ steps env'' C'' ml env' C' E'
                    /\ E = E'' ++ E'
                    /\ env_step env env''
  end.

(* Running a smart contract c in environment env over a list of messages. *)
Definition run (env: env) (C: contract) (ml: list message) (C': contract) (E: eventlist) :Prop :=
  exists env',
    steps env C ml env' C' E.


Require Import VST.veric.juicy_extspec.
Require Import VST.floyd.proofauto.
Require Export VST.floyd.io_events.
Require Export ITree.ITree.
Require Export ITree.Eq.Eq.
Require Export ITree.Eq.SimUpToTaus.
(* Import ITreeNotations. *) (* one piece conflicts with subp notation *)
Notation "x <- t1 ;; t2" := (ITree.bind t1 (fun x => t2))
  (at level 100, t1 at next level, right associativity) : itree_scope.
Notation "' p <- t1 ;; t2" :=
  (ITree.bind t1 (fun x_ => match x_ with p => t2 end))
(at level 100, t1 at next level, p pattern, right associativity) : itree_scope.

Definition stdin := 0%nat.
Definition stdout := 1%nat.

Section specs.

Context {E : Type -> Type} `{IO_event(file_id := nat) -< E}.

Definition putchar_spec :=
  WITH c : byte, k : IO_itree
  PRE [ tint ]
    PROP ()
    PARAMS (Vubyte c) GLOBALS()
    SEP (ITREE (write stdout c ;; k))
  POST [ tint ]
   EX i : int,
    PROP (Int.signed i = -1 \/ Int.signed i = Byte.unsigned c)
    LOCAL (temp ret_temp (Vint i))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (write stdout c ;; k) else k)).

Definition getchar_spec :=
  WITH k : byte -> IO_itree
  PRE [ ]
    PROP ()
    PARAMS () GLOBALS()
    SEP (ITREE (r <- read stdin ;; k r))
  POST [ tint ]
   EX i : int,
    PROP (-1 <= Int.signed i <= Byte.max_unsigned)
    LOCAL (temp ret_temp (Vint i))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- read stdin ;; k r) else k (Byte.repr (Int.signed i)))).

(* Build the external specification. *)
Program Definition IO_void_Espec : OracleKind := ok_void_spec (@IO_itree E).

Definition IO_specs (ext_link : string -> ident) :=
  [(ext_link "putchar"%string, putchar_spec); (ext_link "getchar"%string, getchar_spec)].

Definition IO_Espec (ext_link : string -> ident) : OracleKind := add_funspecs IO_void_Espec ext_link (IO_specs ext_link).

End specs.