Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Pred.
Require Import Trace.

Require Import MemoryMerge.
Require Import PromiseConsistent.
Require Import PFConsistent.
Require Import ReorderCancel.
Require Import MemoryProps.
Require Import OrderedTimes.

Require Import Mapping.
Require Import CapFlex.
Require Import GoodFuture.
Require Import Cover.
Require Import PFConsistentStrong.

Set Implicit Arguments.

Fixpoint times_join (ts: list Time.t): Time.t :=
  match ts with
  | [] => Time.bot
  | thd::ttl => Time.join thd (times_join ttl)
  end.

Lemma times_join_max ts t (IN: List.In t ts):
  Time.le t (times_join ts).
Proof.
  revert t IN. induction ts; ss.
  i. des; subst.
  - eapply Time.join_l.
  - eapply IHts in IN. etransitivity; eauto. eapply Time.join_r.
Qed.

Variant sim_event: ThreadEvent.t -> ThreadEvent.t -> Prop :=
| sim_event_promise
    loc from to msg kind
  :
    sim_event
      (ThreadEvent.promise loc from to msg kind)
      (ThreadEvent.promise loc from to msg kind)
| sim_event_read
    loc to val released released' ordr
    (RELEASEDLE: View.opt_le released released')
  :
    sim_event
      (ThreadEvent.read loc to val released ordr)
      (ThreadEvent.read loc to val released' ordr)
| sim_event_write
    loc from to val released released' ordw
    (RELEASEDLE: View.opt_le released released')
  :
    sim_event
      (ThreadEvent.write loc from to val released ordw)
      (ThreadEvent.write loc from to val released' ordw)
| sim_event_update
    loc from to valr valw releasedr releasedr'
    releasedw releasedw' ordr ordw
    (RELEASEDRLE: View.opt_le releasedr releasedr')
    (RELEASEDWLE: View.opt_le releasedw releasedw')
  :
    sim_event
      (ThreadEvent.update loc from to valr valw releasedr releasedw ordr ordw)
      (ThreadEvent.update loc from to valr valw releasedr' releasedw' ordr ordw)
| sim_event_fence
    or ow
  :
    sim_event
      (ThreadEvent.fence or ow)
      (ThreadEvent.fence or ow)
| sim_event_syscall
    e
  :
    sim_event
      (ThreadEvent.syscall e)
      (ThreadEvent.syscall e)
| sim_event_silent
  :
    sim_event
      (ThreadEvent.silent)
      (ThreadEvent.silent)
| sim_event_failure
  :
    sim_event
      (ThreadEvent.failure)
      (ThreadEvent.failure)
.

Lemma ident_map_sim_event (f: Loc.t -> Time.t -> Time.t -> Prop)
      (IDENT: forall loc to fto (MAP: f loc to fto), to = fto)
      e fe
      (EVENT: tevent_map f e fe)
  :
    sim_event e fe.
Proof.
  assert (MSG: forall msg fmsg, msg_map f msg fmsg -> msg = fmsg).
  { i. inv H; auto. eapply opt_view_ident_map in MAP; auto.
    subst. auto. }
  inv EVENT.
  - eapply IDENT in FROM. eapply IDENT in TO.
    eapply MSG in MSG0. subst. inv KIND.
    + econs; eauto.
    + apply IDENT in TO. eapply MSG in MSG0. subst.
      econs; eauto.
    + eapply MSG in MSG0. subst.
      econs; eauto.
    + econs; eauto.
  - eapply IDENT in TO.
    eapply opt_view_ident_map in RELEASED; auto. subst. econs; eauto.
  - eapply IDENT in FROM. eapply IDENT in TO.
    eapply opt_view_ident_map in RELEASED; auto. subst. econs; eauto.
  - eapply IDENT in FROM. eapply IDENT in TO.
    eapply opt_view_ident_map in RELEASEDR; auto. eapply opt_view_ident_map in RELEASEDW; auto.
    subst. econs; eauto.
  - econs; eauto.
  - econs; eauto.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma promise_monotonicity lang0 lang1 st0 st1 st2 lc0 lc1 lc2 sc0 sc2 mem0 mem2 loc to tr0
      (CONSISTENT: Thread.consistent (@Thread.mk lang0 st0 lc0 sc0 mem0))
      (LOCAL0: Local.wf lc0 mem0)
      (LOCAL1: Local.wf lc1 mem0)
      (DISJOINT: Local.disjoint lc0 lc1)
      (SC: Memory.closed_timemap sc0 mem0)
      (MEM: Memory.closed mem0)
      (PROMISE: concrete_promised (Local.promises lc0) loc to)
      (STEPS0: Trace.steps tr0 (@Thread.mk lang1 st1 lc1 sc0 mem0) (@Thread.mk _ st2 lc2 sc2 mem2))
  :
    (exists tr1 st0' lc0' sc0' mem0' we tr0' val lc2' sc2' mem2',
        (<<STEPS1: Trace.steps tr1 (@Thread.mk _ st0 lc0 sc0 mem0) (@Thread.mk _ st0' lc0' sc0' mem0')>>) /\
        (<<CONSISTENT: Thread.consistent (@Thread.mk _ st0' lc0' sc0' mem0')>>) /\
        (<<FINAL: final_event_trace we tr1>>) /\
        (<<WRITE: relaxed_writing_event loc to val we>>) /\
        (<<STEPS0: Trace.steps tr0' (@Thread.mk lang1 st1 lc1 sc0' mem0') (@Thread.mk _ st2 lc2' sc2' mem2')>>) /\
        (<<TRACE: List.Forall2 (fun '(_, e0) '(_, e1) => sim_event e1 e0) tr0 tr0'>>)) \/
    (Thread.steps_failure (@Thread.mk _ st0 lc0 sc0 mem0)).
Proof.
  inv PROMISE.
  hexploit consistent_pf_consistent_super_strong; eauto; ss. i. des.
  hexploit (memory_times_wf_exists mem0). i. des.
  hexploit (@trace_times_list_exists tr0). i. des.
  set (tm := fun loc => Time.incr (Time.join (times_join (times loc)) (Memory.max_ts loc mem0))).
  set (f := (fun loc ts fts => ts = fts /\ Time.lt ts (tm loc))).
  assert (MAPLT: mapping_map_lt f).
  { unfold f. ii. des; subst; auto. }
  assert (IDENT: map_ident_in_memory f mem0).
  { ii. split; auto. eapply TimeFacts.le_lt_lt; eauto.
    eapply TimeFacts.le_lt_lt.
    { eapply Time.join_r. }
    { eapply Time.incr_spec. }
  }
  hexploit concrete_promise_max_timemap_exists.
  { eapply MEM. } i. des.
  eapply pf_consistent_super_strong_mon
    with (certimes1 := certimes \2/ times_mem \2/ fun _ ts => exists n, incr_time_seq n = ts) in CONSISTENT0; eauto.
  hexploit pf_consistent_super_strong_promises_list_exists; eauto.
  { i. right. eauto. }
  i. des. unfold pf_consistent_super_strong_promises_list in *. des. ss.
  hexploit COMPLETE; eauto. i. eapply List.in_split in H. des. subst.
  hexploit CONSISTENT1; eauto.
  { refl. }
  { ii. exploit MWF; eauto.  i. des. splits; eauto. }
  i. clear CONSISTENT1. des.
  - left. eapply max_good_future_map in GOOD; eauto; cycle 1.
    { i. eapply TimeFacts.le_lt_lt.
      - eapply Time.join_r.
      - eapply Time.incr_spec. }
    hexploit Trace.steps_future; eauto. i. des. ss.
    hexploit Trace.steps_disjoint; eauto. i. des.
    hexploit (@trace_steps_map f).
    { unfold f. ii. des; subst; auto. }
    { unfold f. ii. split; auto. eapply TimeFacts.le_lt_lt.
      - eapply Time.bot_spec.
      - eapply Time.incr_spec.
    }
    { unfold f. ii. des; subst; auto. }
    { instantiate (1:=tr0). eapply wf_time_mapped_mappable.
      { instantiate (1:=fun loc to => List.In to (times loc)).
        - eapply List.Forall_impl; eauto. ss. }
      { i. ss. exists to0. split; auto. eapply TimeFacts.le_lt_lt.
        { eapply times_join_max; eauto. }
        { eapply TimeFacts.le_lt_lt.
          { eapply Time.join_l. }
          { eapply Time.incr_spec. }
        }
      }
    }
    { eapply STEPS0. }
    { ss. }
    { ss. }
    { ss. }
    { eapply LOCAL1. }
    { eapply WF. }
    { eauto. }
    { eauto. }
    { eauto. }
    { eauto. }
    { eapply map_ident_in_memory_local; eauto. }
    { eauto. }
    { eapply mapping_map_lt_collapsable_unwritable; eauto. }
    { eapply map_ident_in_memory_closed_timemap; eauto. }
    { rewrite SC0. refl. }
    i. des. destruct e1. ss. esplits; try eassumption.
    { eapply pf_consistent_super_strong_consistent; eauto. }
    eapply list_Forall2_impl; eauto. i. ss. des; auto.
    { clear - EVENT. destruct a, b. ss. eapply ident_map_sim_event; eauto.
      i. eapply MAP. }
  - right. unfold Thread.steps_failure.
    unguard. des. destruct e1. ss. esplits.
    { eapply Trace.silent_steps_tau_steps; eauto.
      eapply List.Forall_impl; eauto. i. ss. des; auto. }
    { econs 2. econs; eauto. }
Qed.


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 A B C D M N Aprime Bprime Cprime Dprime Mprime Nprime H G : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ C D /\ (wd_ A D /\ (wd_ A C /\ (wd_ B D /\ (wd_ Aprime Bprime /\ (wd_ Bprime Cprime /\ (wd_ Cprime Dprime /\ (wd_ Aprime Dprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Dprime /\ (wd_ Nprime Aprime /\ (wd_ Nprime Dprime /\ (wd_ Mprime Bprime /\ (wd_ Mprime Cprime /\ (wd_ N A /\ (wd_ N D /\ (wd_ M B /\ (wd_ M C /\ (wd_ N H /\ (wd_ H G /\ (wd_ M N /\ (wd_ N G /\ (wd_ M G /\ (wd_ M H /\ (wd_ Mprime Nprime /\ (wd_ N C /\ (wd_ D G /\ (wd_ A H /\ (col_ A D H /\ (col_ Nprime Aprime Dprime /\ (col_ N A D /\ (col_ Mprime Bprime Cprime /\ (col_ M B C /\ col_ N D H))))))))))))))))))))))))))))))))))) -> col_ H A N)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*******************************************************************************)
(*  © Université de Lille, The Pip Development Team (2015-2021)                *)
(*                                                                             *)
(*  This software is a computer program whose purpose is to run a minimal,     *)
(*  hypervisor relying on proven properties such as memory isolation.          *)
(*                                                                             *)
(*  This software is governed by the CeCILL license under French law and       *)
(*  abiding by the rules of distribution of free software.  You can  use,      *)
(*  modify and/ or redistribute the software under the terms of the CeCILL     *)
(*  license as circulated by CEA, CNRS and INRIA at the following URL          *)
(*  "http://www.cecill.info".                                                  *)
(*                                                                             *)
(*  As a counterpart to the access to the source code and  rights to copy,     *)
(*  modify and redistribute granted by the license, users are provided only    *)
(*  with a limited warranty  and the software's author,  the holder of the     *)
(*  economic rights,  and the successive licensors  have only  limited         *)
(*  liability.                                                                 *)
(*                                                                             *)
(*  In this respect, the user's attention is drawn to the risks associated     *)
(*  with loading,  using,  modifying and/or developing or reproducing the      *)
(*  software by the user in light of its specific status of free software,     *)
(*  that may mean  that it is complicated to manipulate,  and  that  also      *)
(*  therefore means  that it is reserved for developers  and  experienced      *)
(*  professionals having in-depth computer knowledge. Users are therefore      *)
(*  encouraged to load and test the software's suitability as regards their    *)
(*  requirements in conditions enabling the security of their systems and/or   *)
(*  data to be ensured and,  more generally, to use and operate it in the      *)
(*  same conditions as regards security.                                       *)
(*                                                                             *)
(*  The fact that you are presently reading this means that you have had       *)
(*  knowledge of the CeCILL license and that you accept its terms.             *)
(*******************************************************************************)
Require Import Pip.Model.ADT.
Require Import List PeanoNat Lt Lia Coq.Logic.Classical_Prop Bool Coq.Program.Tactics.
Import List.ListNotations.

(** * Summary
    This file contains required functions to manipulate an association list *)
Fixpoint eqList {A : Type} (l1 l2 : list A) (eq : A -> A -> bool) : bool :=
 match l1, l2 with
 |nil,nil => true
 |a::l1' , b::l2' => if  eq a b then eqList l1' l2' eq else false
 |_ , _ => false
end.

Definition beqPairs {A B: Type} (a : (A*B)) (b : (A*B)) (eqA : A -> A -> bool) (eqB : B -> B -> bool) :=
if (eqA (fst a) (fst b)) && (eqB (snd a) (snd b))  then true else false.

Fixpoint lookup {A B C: Type} (k : A) (i : B)  (assoc : list ((A * B)*C))  (eqA : A -> A -> bool) (eqB : B -> B -> bool) :=
  match assoc with
    | nil => None
    | (a, b) :: assoc' => if beqPairs a (k,i) eqA eqB then Some b else lookup k i assoc' eqA eqB
  end.

Fixpoint removeDup {A B C: Type} (k : A) (i : B) (assoc : list ((A * B)*C) )(eqA : A -> A -> bool) (eqB : B -> B -> bool)   :=
  match assoc with
    | nil => nil
    | (a, b) :: assoc' => if beqPairs a (k,i) eqA eqB then removeDup k i assoc' eqA eqB else (a, b) :: (removeDup k i assoc' eqA eqB)
  end.

Definition add {A B C: Type} (k : A) (i : B) (v : C) (assoc : list ((A * B)*C) ) (eqA : A -> A -> bool) (eqB : B -> B -> bool)  :=
  (k,i,v) :: removeDup k i assoc eqA eqB.

Program Fixpoint getNextVaddrAux (indexList : list index) : bool * (list index) :=
match indexList with
| nil   =>  (true, nil)
| h::t  =>  if (fst (getNextVaddrAux t)) then
              if (Nat.eq_dec (h+1) tableSize) then
                (true, (Build_index 0 _)::(snd (getNextVaddrAux t)))
              else
                (false, (Build_index (h+1) _::(snd (getNextVaddrAux t))))
            else
                (false, (Build_index h _::(snd (getNextVaddrAux t))))
end.

Next Obligation.
destruct tableSizeBigEnough.
unfold tableSizeLowerBound.
apply neq_0_lt.
trivial.
unfold tableSizeLowerBound in g.
apply Nat.lt_0_succ.
Qed.

Next Obligation.
assert(i h < tableSize) by (apply (ADT.Hi h)).
destruct h.
simpl in *.
lia.
Qed.

Next Obligation.
apply (ADT.Hi h).
Qed.

Definition getNextVaddr (va : vaddr) : vaddr :=
CVaddr (snd (getNextVaddrAux va)).

Fixpoint getNthVAddrFromAux (start : vaddr) (range : nat) : vaddr :=
match range with
| 0   => start
| S n => getNthVAddrFromAux (getNextVaddr start) n
end.

Obligation Tactic := idtac.

Program Fixpoint firstVAddrGreaterThanSecondAux (firstIndexList secondIndexList : list index)
(HlenVAddr   : length firstIndexList = length secondIndexList)
: bool :=
match (firstIndexList, secondIndexList) with
| (nil, nil) => true
| (hf::tf, hs::ts) => let hs_le_hf := Nat.leb hs hf in
                      if (hs_le_hf) then
                        true
                      else
                      let differentHeads := negb (Nat.eqb hf hs) in
                      if (differentHeads) then
                        false
                      else
                        firstVAddrGreaterThanSecondAux tf ts _
| (_,_) => False_rect _ _
end.

Next Obligation.
cbn.
intros firstIndexList secondIndexList HlenVAddr hf tf hs ts [=Hfirst Hsecond].
subst.
injection HlenVAddr.
trivial.
Qed.

Next Obligation.
cbn.
intros firstIndexList secondIndexList HlenVAddr someIndexList someIndexList2.
case_eq someIndexList.
- case_eq someIndexList2.
  * intros.
    destruct H1.
    contradict H2.
    reflexivity.
  * intros.
    injection Heq_anonymous.
    intros.
    subst.
    contradict HlenVAddr.
    unfold length.
    trivial.
- case_eq someIndexList2.
  * intros.
    injection Heq_anonymous.
    intros.
    subst.
    contradict HlenVAddr.
    unfold length.
    apply Nat.neq_succ_0.
  * intros.
    destruct H1.
    apply (H1 i0 l0 i l).
    trivial.
Qed.

Next Obligation.
cbn.
intros.
split; intros; unfold not; intro; inversion H1.
Qed.

Next Obligation.
cbn.
intros.
split; intros; unfold not; intro; inversion H1.
Qed.

Obligation Tactic := program_simpl.


From Coq Require Import Lists.List.
From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From VST Require Import floyd.proofauto.

From CertiGraph Require Import graph.graph_gen.
From CertiGraph Require Import graph.graph_model.

From CertiGC Require Import model.constants.
From CertiGC Require Import model.heap.heap.
From CertiGC Require Import model.heapgraph.generation.generation.
From CertiGC Require Import model.heapgraph.graph.
From CertiGC Require Import model.heapgraph.mark.
From CertiGC Require Import model.heapgraph.roots.
From CertiGC Require Import model.util.
From CertiGC Require Import vst.cmodel.constants. (* uses WORD_SIZE *)

Record thread_info: Type := {
    ti_heap_p: val;
    ti_heap: Heap;
    ti_args: list val;
    arg_size: Zlength ti_args = MAX_ARGS;
}.

Definition ti_add_new_space (ti: thread_info) (sp: Space) i
           (Hs: 0 <= i < MAX_SPACES): thread_info :=
  Build_thread_info (ti_heap_p ti) (add_new_space (ti_heap ti) sp i Hs)
                    (ti_args ti) (arg_size ti).

Definition nth_space (t_info: thread_info) (n: nat): Space :=
  nth n t_info.(ti_heap).(heap_spaces) null_space.

Lemma nth_space_Znth: forall t n,
    nth_space t n = Znth (Z.of_nat n) (heap_spaces (ti_heap t)).
Proof.
  intros. unfold nth_space, Znth. rewrite if_false. 2: lia.
  rewrite Nat2Z.id. reflexivity.
Qed.

Lemma ans_nth_new: forall ti sp i (Hs: 0 <= i < MAX_SPACES),
    nth_space (ti_add_new_space ti sp i Hs) (Z.to_nat i) = sp.
Proof.
  intros. rewrite nth_space_Znth. simpl. rewrite Z2Nat.id by lia.
  rewrite upd_Znth_same; [reflexivity | rewrite heap_spaces__size; assumption].
Qed.

Lemma ans_nth_old: forall ti sp i (Hs: 0 <= i < MAX_SPACES) gen,
    gen <> Z.to_nat i -> nth_space (ti_add_new_space ti sp i Hs) gen =
                         nth_space ti gen.
Proof.
  intros. rewrite !nth_space_Znth. simpl. rewrite upd_Znth_diff_strong.
  - reflexivity.
  - rewrite heap_spaces__size. assumption.
  - intro. apply H. subst. rewrite Nat2Z.id. reflexivity.
Qed.

Definition gen_size t_info n := space_capacity (nth_space t_info n).

Definition rest_gen_size (t_info: thread_info) (gen: nat): Z :=
  space_capacity (nth_space t_info gen) - space_allocated (nth_space t_info gen) - space_remembered (nth_space t_info gen).

Definition enough_space_to_copy g t_info from to: Prop :=
  (unmarked_gen_size g from <= rest_gen_size t_info to)%Z.

Lemma lgd_enough_space_to_copy: forall g e v' t_info gen sp,
    enough_space_to_copy g t_info gen sp ->
    enough_space_to_copy (labeledgraph_gen_dst g e v') t_info gen sp.
Proof.
  intros. unfold enough_space_to_copy in *. intuition. Qed.

Definition space_address (t_info: thread_info) (gen: nat) :=
  offset_val (SPACE_STRUCT_SIZE * Z.of_nat gen) (ti_heap_p t_info).

Definition enough_space_to_have_g g t_info from to: Prop :=
  (heapgraph_generation_size g from <= rest_gen_size t_info to)%Z.

Record thread_info_relation t t' :=
{
  thread_info_relation__ti_heap: ti_heap_p t = ti_heap_p t';
  thread_info_relation__gen_size (n: nat): gen_size t n = gen_size t' n;
  thread_info_relation__space_base (n: nat): space_base (nth_space t n) = space_base (nth_space t' n);
}.

Arguments thread_info_relation__ti_heap [_] [_].
Arguments thread_info_relation__gen_size [_] [_].
Arguments thread_info_relation__space_base [_] [_].

Definition thread_info__remembered_invariant t t' := forall (n: nat), space_remembered (nth_space t n) = space_remembered (nth_space t' n).

Lemma tir_id: forall t, thread_info_relation t t.
Proof.
  dintuition idtac.
Qed.

Lemma tir_trans: forall t1 t2 t3,
    thread_info_relation t1 t2 -> thread_info_relation t2 t3 ->
    thread_info_relation t1 t3.
Proof.
  dintuition congruence.
Qed.

Definition generation_size_spec (tinfo: thread_info) (n: nat): Prop :=
  if Val.eq (nth_space tinfo n).(space_base) nullval
  then True
  else gen_size tinfo n = generation_size n.

Definition ti_size_spec (tinfo: thread_info): Prop :=
  Forall (generation_size_spec tinfo) (nat_inc_list (Z.to_nat MAX_SPACES)).

Lemma ti_size_spec_add: forall ti sp i (Hs: 0 <= i < MAX_SPACES),
    space_capacity sp = generation_size (Z.to_nat i) -> ti_size_spec ti ->
    ti_size_spec (ti_add_new_space ti sp i Hs).
Proof.
  intros. unfold ti_size_spec in *. rewrite Forall_forall in *. intros.
  specialize (H0 _ H1). unfold generation_size_spec in *.
  destruct (Nat.eq_dec x (Z.to_nat i)); unfold gen_size.
  - subst x. rewrite !ans_nth_new. if_tac; auto.
  - rewrite !ans_nth_old; assumption.
Qed.

Lemma ti_relation_size_spec: forall t_info1 t_info2 : thread_info,
    thread_info_relation t_info1 t_info2 ->
    ti_size_spec t_info1 -> ti_size_spec t_info2.
Proof.
  intros.
  unfold ti_size_spec in *.
  rewrite Forall_forall in *.
  intros.
  specialize (H0 _ H1). unfold generation_size_spec in *.
  pose proof (thread_info_relation__gen_size H) as H2.
  pose proof (thread_info_relation__space_base H) as H3.
  now rewrite <- H2, <- H3.
Qed.

Lemma ans_space_address: forall ti sp i (Hs: 0 <= i < MAX_SPACES) j,
    space_address (ti_add_new_space ti sp i Hs) (Z.to_nat j) =
    space_address ti (Z.to_nat j).
Proof. intros. unfold space_address. simpl. reflexivity. Qed.

Lemma ngs_range: forall i,
    0 <= i < MAX_SPACES -> 0 <= generation_size (Z.to_nat i) < MAX_SPACE_SIZE.
Proof.
  intros. unfold generation_size. rewrite MAX_SPACES_eq in H.
  rewrite Z2Nat.id, NURSERY_SIZE_eq, Zbits.Zshiftl_mul_two_p,
  Z.mul_1_l, <- two_p_is_exp by lia. split.
  - cut (two_p (16 + i) > 0). 1: intros; lia. apply two_p_gt_ZERO. lia.
  - try (assert (E: MAX_SPACE_SIZE = two_p 28) by easy ; rewrite E ; clear E ; apply two_p_monotone_strict ; lia) ;
    try (transitivity (two_p 28) ; try easy ; apply two_p_monotone_strict ; lia).
Qed.

Lemma ngs_int_singed_range: forall i,
    0 <= i < MAX_SPACES ->
    (if Archi.ptr64 then Int64.min_signed else Int.min_signed) <=
    generation_size (Z.to_nat i) <=
    (if Archi.ptr64 then Int64.max_signed else Int.max_signed).
Proof.
  intros. apply ngs_range in H. destruct H. split.
  - transitivity 0. 2: assumption. vm_compute. intro HS; inversion HS.
  - apply Z.lt_le_incl. transitivity MAX_SPACE_SIZE. 1: assumption.
    unfold MAX_SPACE_SIZE. vm_compute. reflexivity.
Qed.

Lemma ngs_S: forall i,
    0 <= i -> 2 * generation_size (Z.to_nat i) = generation_size (Z.to_nat (i + 1)).
Proof.
  intros. unfold generation_size. rewrite !Z2Nat.id by lia.
  rewrite Z.mul_comm, <- Z.mul_assoc, (Z.mul_comm (two_p i)), <- two_p_S by assumption.
  reflexivity.
Qed.

Record fun_info : Type := {
    fun_word_size: Z;
    live_roots_indices: list Z;
    fi_index_range: forall i, In i live_roots_indices -> (0 <= i < MAX_ARGS)%Z;
    lri_range: (Zlength (live_roots_indices) <= MAX_UINT - 2)%Z;
    word_size_range: (0 <= fun_word_size <= MAX_UINT)%Z;
}.

Definition null_fun_info: fun_info.
Proof.
  apply (Build_fun_info 0 nil).
  - intros. inversion H.
  - rewrite Zlength_nil.
    unfold MAX_UINT. rep_lia.
  - unfold MAX_UINT. rep_lia.
Qed.

Definition np_roots_rel from f_info (roots roots': roots_t) (l: list Z) : Prop :=
  let lri := live_roots_indices f_info in
  let maped_lri := (map ((fun x y => Znth y x) lri) l) in
  forall v j, Znth j roots' = inr v ->
              (In (Znth j lri) maped_lri -> addr_gen v <> from) /\
              (~ In (Znth j lri) maped_lri -> Znth j roots = inr v).

Lemma np_roots_rel_cons: forall roots1 roots2 roots3 from f_info i l,
    np_roots_rel from f_info roots1 roots2 [i] ->
    np_roots_rel from f_info roots2 roots3 l ->
    np_roots_rel from f_info roots1 roots3 (i :: l).
Proof.
  intros. unfold np_roots_rel in *. intros. simpl. specialize (H0 _ _ H1).
  destruct H0. split; intros.
  - destruct (in_dec Z.eq_dec (Znth j (live_roots_indices f_info))
                     (map ((fun x y => Znth y x) (live_roots_indices f_info)) l)).
    1: apply H0; assumption. destruct H3. 2: contradiction.
    specialize (H2 n). specialize (H _ _ H2). destruct H. apply H. simpl.
    left; assumption.
  - apply Decidable.not_or in H3. destruct H3.
    specialize (H2 H4). specialize (H _ _ H2). destruct H. apply H5. simpl. tauto.
Qed.


Require Import extraInv.
Require Import verif_cond_5.
Local Open Scope Z.

Theorem extra5: (commonStartnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\
 cond5 -> (extraInv hands1 dryer1 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H4.
inversion_clear H5.
inversion_clear H0.
inversion_clear H7.
inversion_clear H8.
inversion_clear H9.
inversion_clear H10.
(*ctrlState0[i]=ctrlState2[i]*)
assert (HctrlState0_ctrlState2_same : (forall i, (0<=i /\ i<=timer0  -> ctrlState0.[of_Z i]=ctrlState2.[of_Z i]))).
intros.
replace ctrlState2.[of_Z i] with ctrlState1.[of_Z i].
apply arr_same_before_upd  with ctrlState0.[of_Z (timer1-1)] timer1.
split.
auto with zarith.
assumption.
apply arr_same_before_upd with ctrlDrying timer1.
split.
auto with zarith.
assumption.
(*split extraInv in the hypothesis*)
inversion_clear H5.
inversion_clear H12.
inversion_clear H13.
inversion_clear H14.
inversion_clear H15.
inversion_clear H16.
inversion_clear H17.
inversion_clear H18.
inversion_clear H19.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
auto with zarith.
split.
auto with zarith.
split.
(*ctrlState[i]=ctrlWaiting \/ ctrlState[i]=ctrlDrying*)
intros.
elim Zle_lt_or_eq with i timer1.
(*case i<timer1*)
intros.
rewrite <- HctrlState0_ctrlState2_same.
apply H18.
auto with zarith.
auto with zarith.
(*case i=timer1*)
intros.
rewrite H21.
right.
rewrite H4.
apply get_set_same.
rewrite H8.
rewrite length_set.
apply ctrlState_inf.
inversion_clear H19.
assumption.
(*ctrlState[timer]=ctrlDrying -> ...*)
intros.
split.
assumption. (*ctrlTimer<10*)
(*hands [timer-ctrlTimer]=ON*)
split.
rewrite H3.
rewrite Z.sub_0_r.
assumption.
(*dryer [timer-ctrlTimer]=ON*)
split.
rewrite H3.
rewrite Z.sub_0_r.
rewrite H9.
rewrite get_set_same.
rewrite H8 in H1.
rewrite get_set_same in H1.
assert (Htimer0_timer1_1: timer0=timer1-1).
apply Zeq_plus_swap.
rewrite H0.
reflexivity.
rewrite <- Htimer0_timer1_1.
rewrite <- Htimer0_timer1_1 in H1.
apply H20 in H1.
inversion_clear H1.
inversion_clear H22.
inversion_clear H23.
apply Zcase_sign with ctrlTimer0.
intros.
rewrite H23 in H22.
rewrite Z.sub_0_r in H22.
assumption.
intros.
apply H24.
auto with zarith.
intros.
elimtype False.
auto with zarith.
apply ctrlState_inf.
apply dryer_inf.
(*hands[i]=OFF /\ dryer[i]=ON*)
intros.
elimtype False.
auto with zarith.
Qed.


From iris.base_logic Require Export invariants.
From iris.algebra Require Import auth frac agree gmap.
From iris.proofmode Require Import tactics.
From iris_io Require Import lang rules list.
From iris.program_logic Require Import weakestpre lifting.

Class channelIG Σ := ChannelIG {
   stream_inG :> inG Σ (prodR (fracR) (agreeR (leibnizC (Stream val))));
   streams_inG :> inG Σ (prodR (fracR) (agreeR (leibnizC ((Stream val) → Prop))))
}.

Definition channelΣ :=
  #[GFunctor (prodR (fracR) (agreeR (leibnizC (Stream val))));
      GFunctor (prodR (fracR) (agreeR (leibnizC ((Stream val) → Prop))))].

Global Instance subG_channelΣ Σ : subG channelΣ Σ → channelIG Σ.
Proof. solve_inG. Qed.

Section channels.

  Context `{!channelIG Σ, !heapIG Σ}.

  Definition own_stream γ q μ :=
    own γ (q, to_agree μ : (agreeR (leibnizC (Stream val)))).

  Definition own_streams γ q M :=
    own γ (q, to_agree M : (agreeR (leibnizC ((Stream val) → Prop)))).

  Definition channel_inv chan γs1 γs2 γR : iProp Σ :=
        (∃ vs (μ1 μ2 : Stream val) M queue l,
            ⌜chan = (PairV (PrV l) (LocV queue))⌝ ∗
            queue ↦ (of_list vs) ∗
            own_stream γs1 (1/2)%Qp μ1 ∗
            own_stream γs2 (1/2)%Qp μ2 ∗
            own_streams γR (1/2)%Qp M ∗
            ⌜∀ μ', interleaving μ1 μ2 μ' → M (append_l_s vs μ')⌝
        )%I.

  Definition sender chan μ :=
    (∃ γs γs1 γs2 γR,
        inv (nroot .@ "channel") (channel_inv chan γs1 γs2 γR) ∗
            own_stream γs (1/2)%Qp μ ∗ ⌜γs = γs1 ∨ γs = γs2⌝)%I.

  Definition receiver chan μ :=
    (∃ γs1 γs2 γR M queue l,
        ⌜chan = (PairV (PrV l) (LocV queue))⌝ ∗
        inv (nroot .@ "channel") (channel_inv chan γs1 γs2 γR)
            ∗ own_streams γR (1/2)%Qp M ∗ cpvar l M μ)%I.

  Definition new_channel :=
    Lam (Pair Create_Pr (Alloc (InjL Plang.Unit))).

  Lemma wp_new_channel μ1 μ2 :
    {{{True}}}
      App new_channel Plang.Unit
    {{{w, RET w;
       sender w μ1 ∗ sender w μ2 ∗
              ∃ μ, ⌜interleaving μ1 μ2 μ⌝ ∗ receiver w μ
    }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    iApply wp_pure_step_later; auto.
    iNext. asimpl.
    iApply (wp_bind (fill [PairLCtx _])); simpl.
    iApply (wp_create_pr _ (interleaving μ1 μ2)); eauto using interleaving_inh.
    iNext.
    iIntros (l); iDestruct 1 as (μ) "Hμ".
    iApply (wp_bind (fill [PairRCtx _])); simpl.
    iApply wp_alloc; auto.
    iNext. iIntros (q) "Hq".
    iApply wp_value_fupd.
    iMod (own_alloc (1%Qp, to_agree μ1 : (agreeR (leibnizC (Stream val)))))
      as (γs1) "[Hμ11 Hμ12]";
      first done.
    iMod (own_alloc (1%Qp, to_agree μ2 : (agreeR (leibnizC (Stream val)))))
      as (γs2) "[Hμ21 Hμ22]";
      first done.
    iMod (own_alloc (1%Qp, to_agree (interleaving μ1 μ2)
                     : (agreeR (leibnizC (Stream val → Prop)))))
      as (γR) "[HM1 HM2]";
      first done.
    iMod (inv_alloc (nroot .@ "channel") _
                    (channel_inv (PairV (PrV l) (LocV q)) γs1 γs2 γR)
            with "[Hμ11 Hμ21 HM1 Hq]") as "#Hinv".
    { iNext. unfold channel_inv.
      iExists [], _, _, _, _, _; iFrame; eauto. }
    iModIntro.
    iApply "HΦ".
    iSplitL "Hμ12"; first by iExists _, _, _, _; iFrame; iFrame "#"; eauto.
    iSplitL "Hμ22"; first by iExists _, _, _, _; iFrame; iFrame "#"; eauto.
    iExists μ; iSplit; first by iApply cpvar_contains.
    iExists _, _, _, _, _, _; iFrame "#"; iFrame; eauto.
  Qed.

  Definition send :=
    Lam
      (Rec
         (LetIn
            (Snd (Var 2))
            (LetIn
               (Load (Var 0))
               (If
                  (CAS (Var 1) (Var 0)
                       (App (App append.[ren (+5)]
                                          (Var 0))
                            (InjR (Pair (Var 3) (InjL Unit)))))
                  Unit
                  (App (Var 2) (Var 3))
               )
            )
         )
      ).

  Lemma send_closed f : send.[f] = send.
  Proof. by asimpl. Qed.

  Hint Rewrite send_closed : autosubst.

  Lemma wp_send chan v μ :
    {{{sender chan {| Shead := v; Stail := μ|} }}}
      App (App send (of_val chan)) (of_val v)
      {{{RET UnitV;  sender chan μ }}}.
  Proof.
    iIntros (Φ) "HP HΦ".
    iDestruct "HP" as (γs γs1 γs2 γR) "(#chinv & Hγs & #Hγseq)".
    iApply fupd_wp.
    iInv (nroot.@"channel") as "Hinv" "Hcl".
    iDestruct "Hinv" as (ws μ1 μ2 M queue l) "(>% & ? & ? & ? & ? & ?)";
      simplify_eq.
    iMod ("Hcl" with "[- Hγs HΦ]") as "_";
      first by iExists _, _, _, _, _, _; iNext; iFrame.
    iModIntro.
    clear ws μ1 μ2 M.
    iApply (wp_bind (fill [AppLCtx _])).
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply wp_value; simpl.
    iLöb as "IH".
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply (wp_bind (fill [LetInCtx _])).
    iApply wp_pure_step_later; trivial.
    iNext; iApply wp_value; simpl.
    iApply wp_pure_step_later; trivial.
    iNext; asimpl.
    iApply (wp_bind (fill [LetInCtx _])).
    iInv (nroot.@"channel") as "Hinv" "Hcl".
    iDestruct "Hinv" as (ws μ1 μ2 M queue' l') "(>% & Hq & ? & ? & ? & ?)";
      simplify_eq.
    iApply (wp_load with "Hq"); first iFrame.
    iNext. iIntros "Hq".
    iMod ("Hcl" with "[- Hγs HΦ]") as "_";
      first by iExists _, _, _, _, _, _; iNext; iFrame.
    clear μ1 μ2 M.
    iModIntro.
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply (wp_bind (fill [IfCtx _ _])).
    iApply (wp_bind (fill [CasRCtx (LocV _) _])); simpl.
    iApply (wp_append _ [v]); trivial.
    iNext; simpl.
    iIntros (w ?); subst w.
    iInv (nroot.@"channel") as "Hinv" "Hcl".
    iDestruct "Hinv" as (ws' μ1 μ2 M queue l)
                          "(>% & Hq & Hγs1 & Hγs2 & HγR & >Hintr)"; simplify_eq.
    iDestruct "Hintr" as %Hintr.
    destruct (decide (ws' = ws)) as [|Hneq]; first subst ws'.
    - iApply (wp_cas_suc with "Hq").
      iNext. iIntros "Hq".
      iAssert (|={⊤ ∖ ↑nroot.@"channel",⊤}=>
              own_stream γs (1 / 2)%Qp μ)%I with "[-HΦ]" as "Hcl".
      { iDestruct "Hγseq" as %[]; subst γs.
        - iDestruct (own_valid_2 with "Hγs Hγs1") as %[_ ?%agree_op_invL'];
          simpl in *; simplify_eq.
          iCombine "Hγs" "Hγs1" as "Hγs".
          iMod (own_update _ _ ((1%Qp, to_agree μ : agreeR (leibnizC _)))
                  with "Hγs") as "[Hγs Hγys1]".
          { by apply cmra_update_exclusive. }
          iMod ("Hcl" with "[- Hγs]") as "_"; last by iFrame.
          { iExists _, _, _, _, _, _; iNext; iFrame.
            iSplit; first by eauto.
            iPureIntro. intros; rewrite append_l_s_app.
            apply Hintr; by apply interR. }
        - iDestruct (own_valid_2 with "Hγs Hγs2") as %[_ ?%agree_op_invL'];
          simpl in *; simplify_eq.
          iCombine "Hγs" "Hγs2" as "Hγs".
          iMod (own_update _ _ ((1%Qp, to_agree μ : agreeR (leibnizC _)))
                  with "Hγs") as "[Hγs Hγs2]".
          { by apply cmra_update_exclusive. }
          iMod ("Hcl" with "[- Hγs]") as "_"; last by iFrame.
          { iExists _, _, _, _, _, _; iNext; iFrame.
            iSplit; first by eauto.
            iPureIntro. intros; rewrite append_l_s_app.
            apply Hintr; by apply interL. }
      }
      iMod "Hcl" as "Hγs".
      iModIntro.
      iApply wp_pure_step_later; trivial.
      iNext. asimpl.
      iApply wp_value.
      iApply "HΦ".
      iExists _, _, _, _; iFrame "#"; iFrame.
    - iApply (wp_cas_fail with "Hq").
      { intros ?; apply Hneq; eapply (@inj _ _ eq eq of_list _); eauto. }
      iNext. iIntros "Hq".
      iMod ("Hcl" with "[- Hγs HΦ]") as "_";
      first by iExists _, _, _, _, _, _; iNext; iFrame.
      iModIntro.
      iApply wp_pure_step_later; trivial.
      iNext. by iApply ("IH" with "Hγs").
  Qed.

  Typeclasses Opaque send.
  Global Opaque send.

  Definition receive :=
    Lam
      (LetIn
         (Fst (Var 0))
         (LetIn
            (Snd (Var 1))
            (App
               (Rec
                  (LetIn
                     (Load (Var 2))
                     (Case
                        (Var 0)
                        (App (Var 2) Unit)
                        (If
                           (CAS (Var 4) (Var 1) (Snd (Var 0)))
                           (LetIn
                              (Fst (Var 0))
                              (Seq
                                 (Assign_Pr (Var 6) (Var 0))
                                 (Var 0)
                              )
                           )
                           (App (Var 2) Unit)
                        )
                     )
                  )
               )
               Unit
            )
         )
      ).

  Lemma receive_closed f : receive.[f] = receive.
  Proof. by asimpl. Qed.

  Hint Rewrite receive_closed : autosubst.

  Lemma wp_receive chan v μ :
    {{{receiver chan {| Shead := v; Stail := μ|} }}}
      App receive (of_val chan)
      {{{RET v;  receiver chan μ }}}.
  Proof.
    iIntros (Φ) "HP HΦ".
    iDestruct "HP" as (γs1 γs2 γR M q l Hcn) "(#chinv & HR & Hpr)"; subst.
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply (wp_bind (fill [LetInCtx _])).
    iApply wp_pure_step_later; trivial.
    iNext; iApply wp_value; simpl.
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply (wp_bind (fill [LetInCtx _])).
    iApply wp_pure_step_later; trivial.
    iNext; iApply wp_value; simpl.
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iLöb as "IH".
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply (wp_bind (fill [LetInCtx _])).
    iInv (nroot.@"channel") as "Hinv" "Hcl".
    iDestruct "Hinv" as (ws μ1 μ2 M' queue' l') "(>% & Hq & ? & ? & ? & ?)";
      simplify_eq.
    iApply (wp_load with "Hq"); first iFrame.
    iNext. iIntros "Hq".
    iMod ("Hcl" with "[- HR Hpr HΦ]") as "_";
      first by iExists _, _, _, _, _, _; iNext; iFrame.
    clear μ1 μ2 M'.
    iModIntro.
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    destruct ws as [|w ws]; simpl.
    { iApply wp_pure_step_later; trivial.
      iNext. asimpl.
      by iApply ("IH" with "HR Hpr"). }
    iApply wp_pure_step_later; trivial.
    iNext. asimpl.
    iApply (wp_bind (fill [IfCtx _ _])).
    iApply (wp_bind (fill [CasRCtx (LocV _) (InjRV (PairV _ _))])); simpl.
    iApply wp_pure_step_later; trivial.
    iNext; iApply wp_value; simpl.
    iInv (nroot.@"channel") as "Hinv" "Hcl".
    iDestruct "Hinv" as (ws' μ1 μ2 M' queue l)
                          "(>% & Hq & Hγs1 & Hγs2 & HγR & >Hintr)"; simplify_eq.
    iDestruct "Hintr" as %Hintr.
    destruct (decide (ws' = w :: ws)) as [|Hneq]; first subst ws'.
    - iApply (wp_cas_suc with "Hq").
      iNext. iIntros "Hq".
      iDestruct (own_valid_2 with "HR HγR") as %[_ ?%agree_op_invL'];
        simpl in *; simplify_eq.
      iCombine "HR" "HγR" as "HR".
      iMod (own_update
              _ _
              ((1%Qp, to_agree (λ μ, M' {| Shead := w; Stail := μ |})
                : agreeR (leibnizC _)))
              with "HR") as "[HR HγR]".
      { by apply cmra_update_exclusive. }
      iMod ("Hcl" with "[- HR Hpr HΦ]") as "_".
      { iExists _, _, _, _, _, _; iNext; iFrame; eauto. }
      iModIntro.
      iApply wp_pure_step_later; trivial.
      iNext.
      iApply (wp_bind (fill [LetInCtx _])).
      iApply wp_pure_step_later; trivial.
      iNext; iApply wp_value; simpl.
      iApply wp_pure_step_later; trivial.
      iNext. asimpl.
      iApply (wp_bind (fill [SeqCtx _])).
      iApply (wp_assign_pr with "[$Hpr]").
      { iExists (append_l_s ws _); iPureIntro.
        eapply Hintr, interleaving_inh. }
      iNext. iIntros "[% Hpr]"; subst; simpl.
      iApply wp_pure_step_later; trivial.
      iNext; iApply wp_value.
      iApply "HΦ".
      iExists _, _, _, _, _, _; iFrame "#"; iFrame; eauto.
    - iApply (wp_cas_fail with "Hq").
      { intros ?; apply Hneq; eapply (@inj _ _ eq eq of_list _); eauto. }
      iNext. iIntros "Hq".
      iMod ("Hcl" with "[- HR Hpr HΦ]") as "_";
      first by iExists _, _, _, _, _, _; iNext; iFrame.
      iModIntro.
      iApply wp_pure_step_later; trivial.
      iNext. by iApply ("IH" with "HR Hpr").
  Qed.

  Typeclasses Opaque receive.
  Global Opaque receive.

End channels.

Hint Rewrite append_closed : autosubst.
Hint Rewrite send_closed : autosubst.
Hint Rewrite receive_closed : autosubst.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Structure.Terminal.
Require Import Category.Construction.Opposite.

Generalizable All Variables.

(* To be initial is just to be terminal in the opposite category; but to avoid
   confusion, we'd like a set of notations specific to categories with initial
   objects. *)

Notation "'Initial' C" := (@Terminal (C^op))
  (at level 9) : category_theory_scope.
Notation "@Initial C" := (@Terminal (C^op))
  (at level 9) : category_theory_scope.

Section Initial_.

Context `{I : @Initial C}.

Definition initial_obj : C := @terminal_obj _ I.
Definition zero {x} : initial_obj ~{C}~> x := @one _ I _.

Definition zero_unique {x} (f g : initial_obj ~{C}~> x) : f ≈ g :=
  @one_unique _ I _ _ _.

End Initial_.

Notation "0" := initial_obj : object_scope.

Notation "zero[ C ]" := (@zero _ _ C)
  (at level 9, format "zero[ C ]") : morphism_scope.

Corollary zero_comp `{T : @Initial C} {x y : C} {f : x ~> y} :
  f ∘ zero ≈ zero.
Proof. apply (@one_comp _ T). Qed.


From Undecidability.TM Require Import TM ProgrammingTools.
From Complexity.TM Require Import Code.Decode.

From Complexity.TM Require Single.EncodeTapesInvariants .
Require Import FunInd Lia Ring Arith Program.Wf.
Import EncodeTapes EncodeTapesInvariants.
From Undecidability.Shared.Libs.PSL Require Import BaseLists.

Lemma tape_encode_injective sig (t t' : tape sig): encode_tape t = encode_tape t' -> t = t'.
Proof.
  intros H. specialize (f_equal (fun l => hd_error (rev l)) H ) as Hlast. cbn in Hlast.
  destruct t;destruct t';cbn in H,Hlast|-*;inv H;repeat (autorewrite with list in Hlast;cbn in Hlast);inv Hlast.
  -easy.
  -eapply app_inv_tail in H2. apply map_injective in H2. congruence. now intros ? ? [=].
  -apply (f_equal (@rev _)) in H1. autorewrite with list in H1. cbn in H1.
   rewrite !map_rev,!rev_involutive in H1. inv H1. apply map_injective in H2. congruence. now intros ? ? [=].
  -rewrite <- (rev_involutive l), <- (rev_involutive l1);revert H1.
   generalize (rev l1), (rev l);clear l l1;intros t t' Heq.
   induction t in t',Heq|-*. all:destruct t';cbn in Heq;revert Heq. 2,3:now intros [=].
   +intros [= -> Heq].
    eapply app_inv_tail in Heq. apply map_injective in Heq. congruence. now intros ? ? [=].
   +intros [= ->  Heq]. cbn. apply IHt in Heq as [= <- <- <-]. easy.
Qed.

Lemma tape_encode_prefixInjective sig: prefixInjective (Encode_tape sig).
Proof.
  unfold encode;cbn.
  enough (H:(forall x x' : tape sig,
            | encode_tape x | <= | encode_tape x' | ->
                                                   forall t t' : list (sigTape sig), encode_tape x ++ t = encode_tape x' ++ t' -> x = x')).
  {intros x x'. decide (length (encode_tape x) <= length (encode_tape x')). now apply H.
   intros. symmetry. eapply H. nia. now setoid_rewrite H0. }
  intros x x' Hle t t' H.
  specialize encode_tape_invariants with (t0:=x) as [-> | (b__L&b__R&t__x&Hx&Hsymb__x&Hmark__x&neq__x)]. now destruct x';inv H.
  specialize encode_tape_invariants with (t0:=x') as [-> | (b__L'&b__R'&t__x'&Hx'&Hsymb__x'&Hmark__x'&neq__x')]. now destruct x;inv H.
  assert (Hl_eq:| encode_tape x | = | encode_tape x' |).
  { decide (| encode_tape x | < | encode_tape x' |) as [Hlt | Hlt]. 2:nia. exfalso.
    rewrite Hx, Hx' in Hlt. cbn in Hlt. apply Nat.succ_lt_mono in Hlt. autorewrite with list in Hlt. apply Nat.add_lt_mono_r in Hlt.
    assert (Hlast:nth_error (encode_tape x ++ t) (1 +  | t__x |) = Some (RightBlank b__R)).
    { rewrite Hx. rewrite nth_error_app1. 2:now cbn;autorewrite with list;cbn;nia.
      setoid_rewrite (nth_error_app2 (LeftBlank b__L :: t__x)). 2:cbn;nia.
      replace ((1 + (| t__x |) - (| LeftBlank b__L :: t__x |))) with 0 by (cbn;nia). easy.
    }
    rewrite H, Hx' in Hlast.
    rewrite nth_error_app1 in Hlast. 2:now cbn;autorewrite with list;cbn;nia.
    cbn in Hlast. setoid_rewrite nth_error_app1 in Hlast. 2:nia.
    ediscriminate (Hsymb__x' (RightBlank _)). eapply nth_error_In;eassumption.
  }
  specialize (f_equal (firstn (| encode_tape x |)) H) as Heq. rewrite Hl_eq in Heq at 2.
  rewrite !firstn_app , !Nat.sub_diag, !firstn_all in Heq. apply app_inv_tail in Heq.
  rewrite <- Heq in *. clear Hle Hl_eq Hmark__x'.
  now apply tape_encode_injective.
Qed.

Module CheckEncodesTape.
  Section checkEncodesTape.

    Import Mono Multi Copy Switch If Combinators.

    Context (sig : Type) (tau:finType) {I : Retract (sigTape sig) tau}.

    Local Remove Hints Retract_id : typeclass_instances.

    Notation sig__M := (sigTape sig).

    Let Rel : pRel tau bool 1 := ContainsEncoding.Rel (Encode_tape sig) Retr_f.

    Definition M__step : bool*bool -> pTM tau ((bool*bool) + bool) 1 :=
      fun '(haveSeenMark,haveSeenSymbol) =>
        Switch
          ReadChar
          (fun x =>
             match Option.bind Retr_g x with
               None => Return Nop (inr false)
             | Some c =>
               if (isMarked c && haveSeenMark) || isNilBlank c || isLeftBlank c || isVoidBlank c
               then Return Nop (inr (isVoidBlank c && (xorb haveSeenMark (isMarked c)) && haveSeenSymbol))
               else Return (Move Rmove) (inl (haveSeenMark || isMarked c,haveSeenSymbol || isSymbol c))
             end).

    (** We can do it as function here, althought that is not the prefered way. Instead, just define a "pretty" version o the relation you realise, then you don;t have to worry about termination *)
    Definition f__step bs t : (bool * bool + bool) * tape tau :=
      let (haveSeenMark,haveSeenSymbol) := (fst bs,snd bs) in
      match Option.bind Retr_g (current t) with
        None => (inr false,t)
      | Some c =>
        if (isMarked c && haveSeenMark) || isNilBlank c || isLeftBlank c || isVoidBlank c
        then (inr (isVoidBlank c && (xorb haveSeenMark (isMarked c)) && haveSeenSymbol),t)
        else (inl (haveSeenMark || isMarked c,haveSeenSymbol || isSymbol c),tape_move_right t)
      end.

    Definition M' (bs : bool*bool) :=
      StateWhile M__step bs.

    (* Program Fixpoint f' bs (t : tape tau) { measure (rlength t) } : (bool * tape tau)  :=
      let r := f__step bs t in
      match fst r with
        inl bs' => f' bs' (snd r)
      | inr b => (b,(snd r))
      end.
    Local Obligation Tactic := idtac.
    Next Obligation. cbn.
      intros [haveSeenMark haveSeenSymbol] [ | | | ? c' t__R] _ ?;cbn.
      1-3:now intros [=].
      destruct (Retr_g c') as [ c | ]. 2:now intros [= <-].
      destruct c as [ [] | [] | | | ];cbn. all:try solve [inversion 1].
      1-4:destruct haveSeenMark;cbn.
      all:intros [= ->]. all:destruct t__R;cbn. all:nia.
    Qed. *)

    Function f' bs (t : tape tau) { measure rlength t } : (bool * tape tau)  :=
      let r := f__step bs t in
      match fst r with
        inl bs' => f' bs' (snd r)
      | inr b => (b,(snd r))
      end.
    Proof.
      unfold f__step. intros [haveSeenMark haveSeenSymbol] [ | | | ? c' t__R] ?;cbn.
      1-3:now intros [=].
      destruct (Retr_g c') as [ c | ]. 2:now intros [= <-].
      destruct c as [ [] | [] | | | ];cbn. all:try solve [inversion 1].
      1-4:destruct haveSeenMark;cbn.
      all:intros [= <-]. all:destruct t__R;cbn. all:nia.
    Qed.

    Definition M : pTM tau bool 1:=
      If (Relabel ReadChar (fun c => Option.apply isLeftBlank false (Option.bind Retr_g c)))
         (Switch ReadChar (fun c => Move Rmove;; M' (Option.apply (@isMarked _) false (Option.bind Retr_g c),false)))
         (Relabel ReadChar (fun c => Option.apply isNilBlank false (Option.bind Retr_g c))).

    Definition f (t : tape tau) : (bool*tape tau) :=
      match Option.bind Retr_g (current t) with
        None => (false,t)
      | Some c =>
        if isLeftBlank c then  f' (isMarked c,false) (tape_move_right t)
        else (isNilBlank c, t)
      end.

    (** Verification*)

    Lemma Realises__step bs : M__step bs ⊨ (fun t '(y,t')=> f__step bs t[@Fin0] = (y,t'[@Fin0])).
    Proof.
      destruct bs as (seenMark, seenSymbol). eapply Realise_monotone.
      { unfold M__step;cbn. apply Switch_Realise. now TM_Correct.
        introsSwitch c'. destructBoth (Option.bind Retr_g (rT:=sig__M) c') as [c | ]. 2:now TM_Correct.
        destructBoth (isMarked c && seenMark || isNilBlank c || isLeftBlank c || isVoidBlank c). all:TM_Correct.
      }
      hnf;cbn. intros t (y&t') (?&?&[-> -> ]&H);revert H.
      destruct Option.bind. 2:{ cbn. now intros (->&_&->). }
      destruct _. all:cbn. all:intros (->&_&->). all:easy.
    Qed.

    Lemma Terminates__step bs : projT1 (M__step bs) ↓ (fun _ k => 3 <= k).
    Proof.
      destruct bs as (seenMark, seenSymbol). eapply TerminatesIn_monotone.
      { unfold M__step;cbn. apply Switch_TerminatesIn. 1,2:now TM_Correct.
        introsSwitch c'. destructBoth (Option.bind Retr_g (rT:=sig__M) c') as [c | ]. 2:now TM_Correct.
        destructBoth (isMarked c && seenMark || isNilBlank c || isLeftBlank c || isVoidBlank c). all:TM_Correct.
      }
      hnf;cbn. intros t y Hy. infTer 3. rewrite <- Hy.
      2:{ intros ? ? [-> ->]. destruct Option.bind. 2:lia. destruct _. 2:reflexivity. nia. }
      nia.
    Qed.

    Lemma Realises_intern : M ⊨ (fun tin '(b,tout) => f tin[@Fin0] = (b,tout[@Fin0])).
    Proof.
      eapply Realise_monotone.
      { unfold M. TM_Correct_step. 1,3:now TM_Correct.
        apply Switch_Realise. now TM_Correct.
        cbn;intros c. TM_Correct_step. now TM_Correct.
        unfold M'.
        eapply Realise_monotone with
            (R:= fun t '(y,t')=> f' (Option.apply (@isMarked _) false (Option.bind Retr_g (rT:=sig__M) c), false) t[@Fin0] = (y,t'[@Fin0])).
        { eapply StateWhile_Realise. now eapply Realises__step. }
        generalize (Option.apply (@isMarked _) false (Option.bind Retr_g c), false) as bs. clear c.
        apply StateWhileInduction. all:cbn - [f__step].
        -intros t bs b' t'. rewrite f'_equation. intros ->. reflexivity.
        -intros t bs bs' t' t'' v'. rewrite f'_equation with (t:=t[@Fin0]). intros -> <-. reflexivity.
      }
      hnf;cbn.
      intros t (y&t1) [H |H];revert H.
      all:intros (?&(?&H1&->&->)&H);revert H.
      -intros (?&?&[-> ->]&_&t2&Ht2&<-).
       unfold f. destruct Option.bind . 2:now inv H1.
       cbn in H1. rewrite <- H1. cbn. congruence.
      -intros (?&->&->&->). unfold f.
       destruct Option.bind . 2:easy.
       cbn in *. now rewrite <- H1.
    Qed.

    Definition Ter : tRel tau 1:=
      fun t k => 4 * (| right (t[@Fin0]) |) + 9 <= k.

    Lemma Terminates : projT1 M ↓ Ter.
    Proof.
      eapply TerminatesIn_monotone.
      { unfold M. TM_Correct_step. 1,2,4:TM_Correct.
        apply Switch_TerminatesIn. 1,2:TM_Correct.
        cbn;intros c. TM_Correct_step. 1,2:now TM_Correct.
        unfold M'.
        eapply TerminatesIn_monotone. 1:{ TM_Correct_step. now eapply Realises__step. now apply Terminates__step. }
        evar (c0:nat).
        evar (time : nat -> nat). [time]:intros n0.
        apply StateWhileCoInduction with (T:= fun _ t k => time (| right (t[@Fin0]) | + Option.apply (fun _ => 1) 0 (current (t[@Fin0]))) +c0 <= k). all:cbn - [f__step].
        -intros l t k Hk. infTer 2. intros y' t'.
         unfold f__step. destruct Option.bind eqn:Hc.
         2:{intros [= <- _]; rewrite <- Hk. enough (3 <= c0). now nia. shelve. }
         destruct _ eqn:Hs. all: intros [= <- Ht']. 1:{ enough (3 <= c0). now nia. shelve. }
         rewrite <- Ht'. infTer 2. rewrite <- Hk.
         destruct t[@Fin0] as [ | | | ? ? t__R]. 1-3:easy. destruct t__R;cbn - [plus mult];ring_simplify.
         [time]:refine (n0*4). all:unfold time. all:ring_simplify. all: nia.
      } Unshelve. [c0]:exact 3. 2-3:subst c0;nia.
      cbn. intros ? ? HT. infTer 5.
      2:{ intros t ? (?&->&->&<-). destruct _.
          { infTer 5. intros ? ? [-> ->]. infTer 5. intros ? ? ->. reflexivity. }
          nia.
      }
      ring_simplify. hnf in HT.  rewrite <- HT.
      destruct (x[@Fin0]) as [ | | | ? ? t__R];cbn - [plus mult];ring_simplify. 1-3:nia.
      destruct t__R;cbn - [plus mult];nia.
    Qed.

    Lemma f'_spec (seenMark seenSymbol b : bool) (c:tau) t__L' t__L t__R res tin:
      (length (filter (@isMarked _) (t__L'++[LeftBlank b])) = if seenMark then 1 else 0)
      -> (forall x, x el t__L' -> isSymbol x = true)
      -> reflect (t__L' <> []) seenSymbol
      -> tin = (midtape (map Retr_f (t__L'++[LeftBlank b])++t__L) c t__R)
      -> res = f' (seenMark,seenSymbol) tin
      ->  (if fst res then
           exists (x:tape sig) t__R1 (t__R2 : list tau) c',
             t__R = map Retr_f t__R1++t__R2
             /\ c = Retr_f c'
             /\ encode_tape x = LeftBlank b :: rev t__L'++c'::t__R1
             /\ snd res = midtape (tail (rev (map Retr_f t__R1)++[c])++map Retr_f (t__L'++[LeftBlank b])++t__L) (hd c (rev (map Retr_f t__R1)++[c])) t__R2
         else
           (forall x t__R1 (t__R2 : list tau) c',
             t__R = map Retr_f t__R1++t__R2 ->
             c = Retr_f c' ->
             encode_tape x <> LeftBlank b :: rev t__L'++c'::t__R1)) /\ exists k, snd res = nat_rect _ tin (fun _ => @tape_move_right _) k.
    Proof.
      rewrite map_app;cbn.
      remember (length t__R) as n0 eqn: Hn0. revert tin t__R Hn0 t__L' c res seenMark seenSymbol.
      induction n0 as [n0 IH] using lt_wf_ind. intros ? ? -> ? ? res ? ?;cbn in *.
      intros H__seenMark H__symbs H__seenSymbol -> Hres.
      rewrite f'_equation in Hres. remember (f__step _ _) as f eqn:Hf. unfold f__step in Hf;cbn in Hf.
      destruct (Retr_g c) as [ [] | ] eqn:Hgc ;cbn. 1-3,6:clear IH.
      -cbn in Hf. rewrite orb_true_r in Hf;cbn in Hf. subst f;cbn in Hres;subst res. cbn.
       split. 2:exists 0;now auto.
       intros ? ? ? ? -> [= ->] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *. 2:now setoid_rewrite <- in_rev.
       retract_adjoint. inv Hgc. destruct init__R;inv H__R.  ediscriminate (Hsym (LeftBlank _)). easy.
      -cbn in Hf. rewrite !orb_true_r in Hf. subst f. revert Hres. cbn.
       destruct marked;cbn in *. destruct seenMark;cbn in *. all:intros ->;cbn. 3:destruct seenMark;cbn. 2,3:destruct seenSymbol;cbn.
       +split. 2:exists 0;split;now auto.
        intros ? ? ? ? -> [= ->] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *. 2:now setoid_rewrite <- in_rev.
        retract_adjoint. inv Hgc. cbn in Hmarks;autorewrite with list in *. nia.
       +edestruct invert_symbols_0_marked with (t:= t__L') as (t__R2&->).
        1,2:autorewrite with list in *. now nia. now intros;eapply H__symbs.
        destruct b. 1:{exfalso. autorewrite with list in H__seenMark. now cbn in H__seenMark;nia. }
        destruct t__R2 as [ | c' cs] eqn:Htp. 1:{exfalso. inversion H__seenSymbol. easy. }
        apply retract_g_inv in Hgc as ->.
        split. 2:exists 0;split;now auto.
        eexists (rightof _ _),[],_,_. repeat eapply conj. 1,2,4:reflexivity. cbn.
        autorewrite with list;cbn.  setoid_rewrite <- map_rev with (l:=cs) at 2. easy.
       +split. 2:exists 0;split;now auto.
        intros ? ? ? ? -> [= ->] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *. 2:now setoid_rewrite <- in_rev.
        retract_adjoint. inv Hgc.
        destruct t__L'. all:inv H__seenSymbol. 2:now apply H. cbn in *;autorewrite with list in *.
        destruct init__R;inv H__R. 2:{ ediscriminate (Hsym (RightBlank _)). easy. }
        cbn in *. nia.
       +destruct b.
        *edestruct invert_symbols_0_marked with (t:= t__L') as (t__R2&->).
         1,2:autorewrite with list in *;cbn in *. now nia. now intros;eapply H__symbs.
         destruct t__R2 eqn:?. 1:{exfalso. inversion H__seenSymbol. easy. }
         destruct (rev t__R2) eqn:Htp. 1:{exfalso. subst. revert Htp. length_not_eq. }
         apply retract_g_inv in Hgc as ->.
         split. 2:exists 0;split;now auto.
         eexists (leftof _ _),[],_,_. repeat eapply conj. 1,2,4:reflexivity. rewrite <- Heql. cbn.
         setoid_rewrite <- map_rev with (l:=t__R2). now rewrite Htp.
        *edestruct @invert_symbols_1_marked with (t:= t__L') as (?&?&?&->).
         1,2:autorewrite with list in *;cbn in *. now nia. now intros;eapply H__symbs.
         apply retract_g_inv in Hgc as ->.
         split. 2:exists 0;split;now auto.
         eexists (midtape _ _ _),[],_,_. repeat eapply conj. 1,2,4:reflexivity. cbn.
         repeat (autorewrite with list;cbn).  setoid_rewrite map_rev. easy.
       +split. 2:exists 0;split;now auto. intros ? ? ? ? -> [= -> ] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *.
        2:now setoid_rewrite <- in_rev. retract_adjoint. inv Hgc.
        destruct init__R;inv H__R. 2:{ ediscriminate (Hsym (RightBlank _)). easy. }
        cbn in *. assert (t__L' = []) as ->. 1:{ destruct t__L'. easy. inversion H__seenSymbol. destruct H. easy. }
        cbn in *;nia.
       +split. 2:exists 0;split;now auto. intros ? ? ? ? -> [= ->] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *.
        2:now setoid_rewrite <- in_rev. retract_adjoint. inv Hgc.
        destruct init__R;inv H__R. 2:{ ediscriminate (Hsym (RightBlank _)). easy. }
        cbn in *. autorewrite with list in *. nia.
      -cbn in Hf; rewrite orb_true_r in Hf; cbn in Hf. subst f;cbn in Hres;subst res;cbn.
       split. 2:exists 0;split;now auto.
       intros ? ? ? ? -> [= ->]((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *. 2:now setoid_rewrite <- in_rev.
        retract_adjoint. inv Hgc.
       destruct init__R;inv H__R. discriminate (Hsym (NilBlank)). easy.
      -subst f res;cbn. split. 2:exists 0;split;now auto. intros ? ? ? ? _ ->. edestruct (retract_g_None Hgc). easy.
      -revert Hf Hres. cbn. destruct seenMark;cbn.
       {clear IH. intros -> ->;cbn.
        split. 2:exists 0;split;now auto.
        intros ? ? ? ? -> [= ->]((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *. 2:now setoid_rewrite <- in_rev.
        retract_adjoint. inv Hgc. cbn in *.
        autorewrite with list in *. nia.
       } intros ->;cbn.
       destruct t__R.
       { clear IH. cbn. rewrite f'_equation;cbn.
         intros ->;cbn. split. 2:exists 1;split;now auto.
         intros ? ? ? ? Hnil [= ->] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *.
         2:now setoid_rewrite <- in_rev. retract_adjoint. inv Hgc.
         destruct init__R;inv H__R. length_not_eq in Hnil.
       }
       cbn. intros H.
       autorewrite with list in H__seenMark. destruct b;cbn in H__seenMark. now nia.
       specialize IH with (t__L' := MarkedSymbol s :: t__L');cbn in IH. erewrite <- !(retract_g_inv Hgc) in IH.
       pose (H' := H);eapply IH in H';clear IH.
       3,7:reflexivity. 2:nia. 2:now autorewrite with list in *;nia. 2:now intros ? [<- | ];eauto.
       2:now rewrite orb_true_r;constructor.
       destruct res as [[] t'];cbn in *.
       +destruct H' as [(x&t__R1&t__R2&c'&->&->&Hx&->) Hres].
        split. 2:{ destruct Hres as (k&->). exists (S k). now rewrite nat_rect_succ_r. } clear Hres.
        eexists x,(_::t__R1),t__R2,_.
        repeat (cbn in Hx|-*;autorewrite with list in Hx|-* ).
        apply retract_g_inv in Hgc as ->.
        split. 2:split. 3:split.
        1,2:reflexivity. easy.
        destruct (rev (map Retr_f t__R1));cbn;now autorewrite with list.
       +split. 2:{ destruct H' as [_ [k H']]. exists (S k). now rewrite nat_rect_succ_r. }
        intros x ? ? ? H__R [= ->] Hx. specialize encode_tape_invariants_partial with (1:=Hx) as ((init__R&b__R&H__R'&Hsym)&Hmarks&Hlength);cbn in *. now setoid_rewrite <- in_rev.
        retract_adjoint. inv Hgc.
        destruct init__R;inv H__R'.
        destruct (init__R ++ [RightBlank b__R]) eqn:eq. now length_not_eq in eq. revert H__R;intros [= -> ->].
        eapply H'. 1,2:easy. rewrite Hx;cbn;autorewrite with list;cbn. reflexivity.
      -revert Hf Hres. cbn. intros ->;cbn.
       destruct t__R.
       { clear IH. cbn. rewrite f'_equation;cbn.
         intros ->;cbn. split. 2:{ cbn. now exists 1. }
         intros ? ? ? ? Hnil [= ->] ((init__R&b__R&H__R&Hsym)&Hmarks&Hlength)%encode_tape_invariants_partial;cbn in *.
         retract_adjoint. inv Hgc.
         2:now setoid_rewrite <- in_rev.  destruct t__R1. 2:easy. destruct init__R.  2:length_not_eq in H__R. inv H__R.
       }
       cbn;intros H.
       specialize IH with (t__L' := UnmarkedSymbol s :: t__L');cbn in IH. erewrite <- !(retract_g_inv Hgc) in IH.
       pose (H' := H);eapply IH in H';clear IH.
       3,7:reflexivity. 2:lia. 3:now intros ? [<- | ];eauto. 3:now rewrite orb_true_r;constructor.
       2:{ autorewrite with list in *. destruct seenMark;cbn in *;nia. }
       destruct H' as [H' Hres].
       split. 2:{ destruct Hres as (k&->). exists (S k). now rewrite nat_rect_succ_r. } clear Hres.
       destruct res as [[] t'];cbn in *.
       +destruct H' as (x&t__R1&t__R2&c'&->&->&Hx&->).
        apply retract_g_inv in Hgc as ->.
        eexists x,(_::t__R1),t__R2,_. cbn.
        repeat (cbn in Hx|-*;autorewrite with list in Hx|-* ). split. 2:split. 3:split. 1,2:reflexivity. easy.
        destruct (rev (map Retr_f t__R1));cbn;now autorewrite with list.
       +intros x ? ? ? H__R [= ->] Hx. specialize encode_tape_invariants_partial with (1:=Hx) as ((init__R&b__R&H__R'&Hsym)&Hmarks&Hlength);cbn in *. now setoid_rewrite <- in_rev.
        retract_adjoint. inv Hgc.
        setoid_rewrite <- app_assoc in H'. cbn in H'.
        destruct t__R1;inv H__R. 1:{ destruct init__R. easy. length_not_eq in H__R'. }
        eapply H'. 1,2:reflexivity. now rewrite Hx.
    Qed.

    Lemma f_spec t b t':
      f t = (b,t')
      -> Rel [|t|] (b,[|t'|]).
    Proof.
      unfold f,Rel;cbn. rewrite ContainsEncoding.legacy_iff. 2:now intros []. destruct Option.bind eqn:Hcur.
      2:{ intros [= <- <-];cbn;split. 2:now exists 0. intros ? ? ?. destruct x;cbn;eexists _,_;(split;[reflexivity| ]). all:intros ->;cbn in Hcur. all:now rewrite retract_g_adjoint in Hcur. }
      destruct t as [ | | | t__L s' t__R];cbn in *. 1-3:now inversion Hcur.
      apply retract_g_inv in Hcur as ->.
      unfold ContainsEncoding.Rel. cbn.
      destruct isLeftBlank eqn:H__LB.
      2:destruct isNilBlank eqn:H__NB.
      2:{ intros [= <- <- ]. destruct s;inv H__NB. split. 2:now eexists 0. eexists (@niltape _),t__L,t__R;cbn.
          split. eexists _, nil;cbn. easy. eexists nil,_;cbn. easy. }
      2:{ intros [= <- <- ]. split. 2:now eexists 0. intros ? x ?. destruct x;cbn;eexists _,_;(split;[reflexivity | ]).
          all:intros [= <- ->%retract_f_injective ->]. all:easy. }
      destruct s;inv H__LB.
      destruct t__R. 1:{ cbn. rewrite f'_equation. cbn. intros [= <- <-]. split. 2:{now exists 1. } intros ? x ?.
                       destruct x;cbn;eexists _,_;(split;[reflexivity | ]). all:intros [= <- ?%retract_f_injective HH]. easy. all:revert HH.
                       all:length_not_eq. }
      intros H';symmetry in H'. assert (H:=H'). revert H. eintros [H Hres]%(f'_spec (t__L':=[])). 5:reflexivity.
      2:now destruct marked;cbn;nia. 2:easy. 2:now constructor.
        split. 2:{ cbn in Hres;destruct Hres as (k&->). exists (S k). now rewrite nat_rect_succ_r. } clear Hres.
      destruct b;cbn  in H.
      -destruct H as (x&t__R1&t__R2&c'&->& -> &Hx&->).
       eexists _,_,_;split.
       +rewrite Hx;cbn. do 3 eexists. easy. cbn. eauto.
       +destruct (exists_last (l:=encode_tape x)) as (?&?&eqx). congruence. rewrite eqx in *.
        repeat eexists.
        apply (f_equal (fun t => rev (map (Retr_f (Y:=tau)) t))) in Hx. cbn in  Hx.
        autorewrite with list in Hx;cbn in Hx. f_equal.

        *rewrite (app_comm_cons' _ _ (Retr_f (LeftBlank marked))). rewrite <- tl_app. 2: length_not_eq.
         rewrite <- app_assoc. cbn. rewrite <- Hx. cbn. now rewrite map_rev.
        *apply (f_equal (hd (Retr_f c'))) in Hx. destruct rev;cbn in *. all: easy.
      -hnf. intros ? x ?.
       destruct encode_tape eqn:eqx. now destruct x.
       do 3 eexists. cbn. easy. intros [= <- <-%retract_f_injective H''].
       destruct l. 1:{ destruct x;cbn in eqx;try now inv eqx. all:length_not_eq in eqx. }
       inv H''. eapply H. 1,2:reflexivity. eassumption.
    Qed.

    Lemma Realise : M ⊨ Rel.
    Proof.
      eapply Realise_monotone. now apply Realises_intern. intros t [? t'] ?%f_spec.
      unfold tapes in *.
      destruct_vector. easy.
    Qed.

  End checkEncodesTape.
End CheckEncodesTape.


(* -------------------------------------------------------------------- *)
(* ------- *) Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis
  Require Import boolp reals realseq realsum distr.
From xhl.pwhile
  Require Import notations inhabited pwhile psemantic passn range.
(* ------- *) Require Import range ellora.

Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.
Local Open Scope syn_scope.
Local Open Scope sem_scope.
Local Open Scope mem_scope.

(* -------------------------------------------------------------------- *)
Local Notation dmem  := (Distr cmem).
Local Notation dassn := (pred  dmem).

Implicit Types P Q S : dassn.
Implicit Types c : cmd.
Implicit Types mu : dmem.

(* -------------------------------------------------------------------- *)
Local Notation iwhilen k b c := (iterc k (IfT b then c)).

(* -------------------------------------------------------------------- *)
Inductive sellora : dassn -> dassn -> cmd -> Prop :=
| ESkip P : sellora P P skip

| EAbort P : sellora P (□ pred0) abort

| ESeq S P Q c1 c2 :
    sellora P S c1 -> sellora S Q c2 -> sellora P Q (c1 ;; c2)

| EConseq P' Q' P Q c :
       (forall mu, mu \in P  -> mu \in P')
    -> (forall mu, mu \in Q' -> mu \in Q )
    -> sellora P' Q' c
    -> sellora P  Q  c

| ESem c1 P Q c2 :
       (forall mu, mu \in P -> dssem c1 mu = dssem c2 mu)
    -> sellora P Q c1 -> sellora P Q c2

| ESemCond P Q (e : expr bool) c1 c2 :
       (forall mu, mu \in P -> forall m, m \in dinsupp mu -> `[{ e }] m)
    -> sellora P Q c1 -> sellora P Q (If e then c1 else c2)

| ESemCondF P Q (e : expr bool) c1 c2 :
       (forall mu, mu \in P -> forall m, m \in dinsupp mu -> `[{ ~~ e }] m)
    -> sellora P Q c2 -> sellora P Q (If e then c1 else c2)

| EDframe P c :
    separated (mod c) P -> lossless predT c -> sellora P P c

| EAnd P Q1 Q2 c :
    sellora P Q1 c -> sellora P Q2 c -> sellora P (Q1 /\ Q2)%A c

| EOr P1 P2 c Q :
    sellora P1 Q c -> sellora P2 Q c -> sellora (P1 \/ P2)%A Q c

| EAssign {t : ihbType} P (x : vars t) (e : expr t) :
    sellora (P.[fun mu => dssem (x <<- e) mu])%A P (x <<- e)

| ESample {t : ihbType} P (x : vars t) (d : dexpr t) :
    sellora (P.[fun mu => dssem (x <$- d) mu])%A P (x <$- d)

| ECond P P' Q Q' e c1 c2 :
    let SP := (P /\ □ [pred m | `[{    e }] m])%A in
    let SQ := (Q /\ □ [pred m | `[{ ~~ e }] m])%A in

       sellora SP P' c1
    -> sellora SQ Q' c2
    -> sellora (SP ⊕ SQ) (P' ⊕ Q') (If e then c1 else c2)

| EWhileDClosed P b c :
       dclosed P -> sellora P P (IfT b then c)
    -> sellora P (P /\ □ `[{~~ b}])%A (While b Do c)

| EWhileTClosed (P Q : nat -> dassn) Qinf b c :
       (forall n, sellora (P n) (P n.+1) (IfT b then c))
    -> (forall n, sellora (P n) (Q n) (IfT b then abort))
    -> tclosed Q Qinf
    -> sellora (P 0%N) (Qinf /\ □ `[{~~ b}])%A (While b Do c)

| EWhileUClosed (P Q : nat -> dassn) Qinf b c :
       (forall n, sellora (P n) (P n.+1) (IfT b then c))
    -> (forall n, sellora (P n) (Q n) (IfT b then abort))
    -> uclosed Q Qinf
    -> sellora (P 0%N) (Qinf /\ □ `[{~~ b}])%A (While b Do c)

| EWhileCertainCT P b c :
    (forall mu, mu \in P -> exists k,
       \P_[dssem (iwhilen k b c) mu] [eta `[{ b }]] = 0)
  -> sellora P P (IfT b then c)
  -> sellora P (P /\ □ `[{ ~~ b}])%A (While b Do c)

| EWhileCertain (P : nat -> dassn) k e c :
     (forall n, sellora (P n) (P n.+1) (IfT e then c))
  -> (forall mu, P 0%N mu -> dssem (While e Do c) =
                             dssem (iterc k (IfT e then c)))
  -> sellora (P 0%N) (P k /\ □ `[{~~ e}])%A (While e Do c)

| ESplit P P' Q Q' c :
    sellora P Q c -> sellora P' Q' c -> sellora (P) (Q) c.

(* -------------------------------------------------------------------- *)
Lemma sound P Q c : sellora P Q c -> ellora P Q c.
Proof. by elim=> {P Q c}; eauto 2 using ellora_cond with ellora. Qed.


Require Import Ssreflect.ssreflect Ssreflect.ssrbool Ssreflect.ssrnat Ssreflect.eqtype Ssreflect.seq Ssreflect.fintype.
Require Import x86proved.x86.procstate x86proved.x86.procstatemonad x86proved.bitsops x86proved.bitsprops x86proved.bitsopsprops.
Require Import x86proved.spred x86proved.septac x86proved.spec x86proved.spectac x86proved.x86.basic x86proved.x86.program x86proved.x86.macros.
Require Import x86proved.x86.instr x86proved.x86.instrsyntax x86proved.x86.instrcodec x86proved.x86.instrrules x86proved.reader x86proved.pointsto x86proved.cursor.
Require Import x86proved.chargetac x86proved.latertac.

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

Local Open Scope instr_scope.
(* Allocation invariant:
     infoBlock points to a pair of DWORDs:
       base, a pointer to the current available heap
       count, the number of bytes currently available
   Furthermore, "count" bytes of memory starting at "base" is defined
*)
Definition allocInv (infoBlock: DWORD) :=
  Exists base: DWORD,
  Exists count: DWORD,
  infoBlock :-> base **
  infoBlock +#4 :-> count **
  memAny base count.

(* Allocate memory.
     infoBlock: Src  is pointer to two-word heap information block
     n: nat representing number of bytes to be allocated
     failed: DWORD is label to branch to on failure
   If successful, EDI contains pointer to byte just beyond allocated block.
*)
Definition allocImp (infoBlock:DWORD) (n: nat) (failed: DWORD) : program :=
  MOV EDI, [infoBlock];;
  ADD EDI, n;;
  JC  failed;;  (* A carry indicates unsigned overflow *)
  CMP [infoBlock+#4:DWORD], EDI;;
  JC  failed;;  (* A carry indicates unsigned underflow *)
  MOV [infoBlock], EDI.

Definition allocSpec n (fail:DWORD) inv code :=
  Forall i j : DWORD, (
      safe @ (EIP ~= fail ** EDI?) //\\
      safe @ (EIP ~= j ** Exists p, EDI ~= p +# n ** memAny p (p +# n))
    -->>
      safe @ (EIP ~= i ** EDI?)
    )
    @ (OSZCP? ** inv)
    c@ (i -- j :-> code).

Hint Unfold allocSpec : specapply.

(* Perhaps put a |> on the failLabel case *)
Require Import x86proved.basicspectac.
Lemma inlineAlloc_correct n failed infoBlock : |-- allocSpec n failed (allocInv infoBlock) (allocImp infoBlock n failed).
Proof.
  rewrite /allocSpec/allocImp.
  specintros => *.
  unfold_program. specintros => *.
  (* Push invariant under implication so that we can instantiate existential pre and post *)
  rewrite spec_at_impl. rewrite /allocInv. specintros => base limit.

  (* MOV EDI, [infoBlock] *)
  superspecapply MOV_RanyInd_rule.

  (* ADD EDI, bytes *)
  superspecapply *.

  (* JC failed *)
  rewrite /OSZCP.
  superspecapply JC_rule.

  specsplit.
  simpllater. (*rewrite <- spec_frame. *) finish_logic_with sbazooka.

  (* CMP [infoBlock+#4], EDI *)
  specintro => /eqP => Hcarry.

  specapply CMP_IndR_ZC_rule; rewrite /stateIsAny; sbazooka.

  (* JC failed *)
  superspecapply JC_rule.
  specsplit.
  - simpllater. (*rewrite <- spec_frame. *) finish_logic_with sbazooka.

  (* MOV [infoBlock], EDI *)
  superspecapply MOV_IndR_rule.

  specintro => /eqP LT.

  { (*rewrite <- spec_frame. *) rewrite /stateIsAny/natAsDWORD. finish_logic. (*apply limplValid.
    autorewrite with push_at. *) apply landL2. finish_logic_with sbazooka.

    apply memAnySplit.
    { apply: addB_leB.
      apply injective_projections; [ by rewrite Hcarry
                                   | by generalize @adcB ]. }
    { simpl. rewrite ltBNle /natAsDWORD in LT. rewrite -> Bool.negb_false_iff in LT. by rewrite LT. } }
Qed.


From iVM Require Import DSet Mono Cert0 Cert1.
Import DSetNotations.

Unset Suggest Proof Using.

(* TODO: Place inside section or module. *)
Import OpCodes.

Local Notation not_terminated := (ret true) (only parsing).
Local Notation terminated := (ret false) (only parsing).

(*****************)

(* TODO: Move *)
Proposition get_mem''_spec a {X} (f: (available a -> option Cell) -> M X) :
  let* x := get' (MEM'' a) in
  f x =
    let* mem := get' MEM in
    f (mem a).
Proof.
  unfold MEM''.
  setoid_rewrite get_spec.
  smon_rewrite.
Qed.

(* TODO: Move *)
Proposition pointLens_restrLens
  {A : Type} {F : A -> Type}
  {H_eqdec: EqDec A} (a : A) :
  pointLens (F:=F) a ≃ restrLens !{a}.
Proof.
  intros f g.
  cbn.
  extensionality x.
  destruct (decide (x ∈ !{a})) as [Hx|Hx].
  - rewrite singleton_spec in Hx.
    symmetry in Hx.
    decided Hx.
    destruct H.
    reflexivity.
  - rewrite singleton_spec in Hx.
    assert (a <> x) as H; [ congruence | ].
    undecided H.
    reflexivity.
Qed.

Proposition not_member_independent
  {A : Type} {F : A -> Type}
  {H_eqdec: EqDec A} (a : A) (u: DSet A) (Ha: ~ (a ∈ u)) :
  Independent (pointLens (F:=F) a) (restrLens u).
Proof.
  intros f g h.
  cbn.
  extensionality x.
  destruct (decide (x ∈ u)) as [Hxu|Hxu]; [ | reflexivity ].
  assert (a <> x) as Hax; [ congruence | ].
  now undecided Hax.
Qed.

(* TODO: Move *)
Arguments confined_neutral {_ _ _ _} _ _ {_ _} _.

Instance lens_semiNeutral
{S M} {SM: SMonad S M}
{X A} (LA: Lens S A) (mx: M X)
(Hmx: mx =
  let* a := get' LA in
  let* x := mx in
  put' LA a;;
  ret x) : SemiNeutral LA mx.
Proof.
  unfold SemiNeutral.
  rewrite -> Hmx at 1.
  rewrite get_spec, put_spec, putM_spec.
  smon_rewrite.
Qed.

Instance semiNeutral_popMany n : SemiNeutral MEM (popMany n).
Proof.
  induction n;
    apply lens_semiNeutral;
    simp popMany;
    [ smon_rewrite | ].
  setoid_rewrite (semiNeutral_get_put MEM pop).
  setoid_rewrite (semiNeutral_get_put MEM (popMany n)) at 1.
  smon_rewrite.
Qed.

Lemma popMany_pushMany n :
  let* u := popMany n in
  pushMany u =
    let* sp := get' SP in
    sDefined (nAfter n sp).
Proof.
  rewrite popMany_defined.
  rewrite sDefined_spec.
  repeat setoid_rewrite bind_assoc.
  smon_ext' SP sp.
  setoid_rewrite lens_put_get.
  setoid_rewrite (confined_get MEM);
  [ | typeclasses eauto .. ].
  smon_ext' MEM mem.
  setoid_rewrite lens_put_get.
  destruct (decide _) as [H|H];
  [ | now smon_rewrite01 ].
  smon_rewrite2.
  revert sp mem H;
    induction n;
    intros sp mem H.
  - simp popMany.
    setoid_rewrite ret_bind.
    simp to_list.
    rewrite pushMany_empty.
    now smon_rewrite2.
  - rewrite popMany_S.
    setoid_rewrite to_list_action.
    setoid_rewrite pushMany_action.
    setoid_rewrite pushMany_one.
    setoid_rewrite (collapse_bind_lift pop_push).
    setoid_rewrite bind_assoc.
    setoid_rewrite popMany_getSP.
    setoid_rewrite lens_put_get.

    rewrite defined_spec.
    smon_rewrite01.
    set (a := offset n sp).
    assert (a ∈ nAfter (S n) sp) as Hin.
    + rewrite nAfter_nonempty.
      rewrite union_spec.
      right.
      rewrite singleton_spec.
      reflexivity.
    + destruct (H a Hin) as [Ha Hm].
      decided Ha.
      setoid_rewrite ret_bind.
      setoid_rewrite (semiNeutral_get_put MEM (popMany n)).
      setoid_rewrite <- (confined_put SP); [ | typeclasses eauto ].
      repeat setoid_rewrite lens_put_get.
      decided Hm.
      setoid_rewrite ret_tt_bind.
      setoid_rewrite (confined_put SP); [ | typeclasses eauto ].
      setoid_rewrite <- (semiNeutral_put_put MEM (popMany n)).
      setoid_rewrite <- (confined_put SP); [ | typeclasses eauto ].
      apply IHn.
      clear a Hin Ha Hm.
      intros a Hin.
      apply (H a).
      rewrite nAfter_nonempty.
      rewrite union_spec.
      now left.
Qed.


Require Import POCS.

Module BadSectorDisk.

  Inductive Op : Type -> Type :=
  | BadRead (a:addr) : Op block
  | BadWrite (a:addr) (b:block) : Op unit
  | GetBadSector : Op addr
  | BadDiskSize : Op nat.

  Record State :=
    mkState {
      stateDisk : disk;
      stateBadSector : addr;
    }.

  (* help out type inference *)
  Implicit Type (state:State).

  Inductive op_step : forall `(op: Op T), Semantics State T :=
  | step_read : forall a r (d : disk) bs,
      a <> bs -> d a = Some r ->
      op_step (BadRead a) (mkState d bs) r (mkState d bs)
  | step_read_oob : forall a r (d : disk) bs,
      a <> bs -> d a = None ->
      op_step (BadRead a) (mkState d bs) r (mkState d bs)
  | step_read_bad : forall a r (d : disk) bs,
      a = bs ->
      op_step (BadRead a) (mkState d bs) r (mkState d bs)
  | step_write : forall a b (d : disk) bs,
      op_step (BadWrite a b) (mkState d bs) tt (mkState (diskUpd d a b) bs)
  | step_get_bs : forall d bs,
      op_step GetBadSector (mkState d bs) bs (mkState d bs)
  | step_size : forall d bs,
      op_step BadDiskSize (mkState d bs) (size d) (mkState d bs).

  Definition crash_relation state state' := False.
  Definition inited state := True.

  Definition API : InterfaceAPI Op State :=
    {|
      op_sem := @op_step;
      crash_effect := crash_relation;
      init_sem := inited;
    |}.

  Ltac inv_step :=
    idtac;  (* Ltac evaluation order issue when passing tactics *)
    match goal with
    | [ H: op_step _ _ _ _ |- _ ] =>
      inversion H; subst; clear H;
      repeat sigT_eq;
      safe_intuition
    end.

End BadSectorDisk.


Require compcert.backend.CleanupLabelsproof.
Require LinearX.

Import Coqlib.
Import Globalenvs.
Import Events.
Import Smallstep.
Import LinearX.
Import CleanupLabels.
Export CleanupLabelsproof.

Section WITHCONFIG.
  Context `{external_calls_prf: ExternalCalls}.

  Variable prog: program.
  Let tprog := transf_program prog.
  Let ge := Genv.globalenv prog.
  Let tge := Genv.globalenv tprog.

  Let MATCH_PROG: match_prog prog tprog.
  Proof.
    apply transf_program_match.
  Qed.

  Lemma transf_initial_states:
    forall init_ls i sg args m,
    forall st1, initial_state init_ls prog i sg args m st1 ->
           exists st2, initial_state init_ls tprog i sg args m st2 /\ match_states st1 st2.
  Proof.
    intros. inv H.
    econstructor; split.
    eapply initial_state_intro with (f0 := transf_fundef f).
    unfold tprog. erewrite symbols_preserved; eauto.
    eapply function_ptr_translated; eauto.
    erewrite sig_function_translated. auto.
    reflexivity.
    constructor; auto. constructor.
  Qed.

  Lemma transf_final_states:
    forall init_ls,
    forall sg,
    forall st1 st2 r,
      match_states st1 st2 -> final_state init_ls sg st1 r -> final_state init_ls sg st2 r.
  Proof.
    intros. inv H0. inv H. inv H4. econstructor; eauto.
  Qed.

  Theorem transf_program_correct:
    forall init_ls i sg args m,
      forward_simulation (semantics init_ls prog i sg args m) (semantics init_ls tprog i sg args m).
  Proof.
    intros.
    eapply forward_simulation_opt.
    apply senv_preserved; auto.
    apply transf_initial_states.
    apply transf_final_states.
    apply transf_step_correct; auto.
  Qed.

End WITHCONFIG.


Require Import language.
Require Import msl.base.
Require Import msl.seplog.
Require Import msl.alg_seplog.

Local Open Scope logic.

Module Type SEMAX.

  Parameter mpred : Type.
  Parameter Nm: NatDed mpred.  Existing Instance Nm.
  Parameter Sm: SepLog mpred.  Existing Instance Sm.
  Parameter Cm: ClassicalSep mpred.  Existing Instance Cm.
  Parameter Im: Indir mpred.  Existing Instance Im.
  Parameter Rm: RecIndir mpred.  Existing Instance Rm.
  Parameter SIm: SepIndir mpred.  Existing Instance SIm.
  Parameter SRm: SepRec mpred.  Existing Instance SRm.

  Parameter mapsto: forall (v1 v2: adr), mpred.

  Axiom mapsto_conflict:  forall a b c, mapsto a b  *  mapsto a c |-- FF.

  Definition assert := env -> mpred.
  Bind Scope logic with assert.

  Definition funspec := (list var * assert)%type.
  Definition funspecs := table adr funspec.

  Definition call (P: list var * assert) (vl: list adr) : mpred :=
     (!! (length vl = length (fst P)) && snd P (arguments (fst P) vl)).
  Parameter cont: forall (nP: funspec)  (v: adr), mpred.

Definition funassert (G: funspecs) : mpred :=
   (ALL  i:_, ALL P:_,  !! (table_get G i = Some P) --> cont P i)  &&
   (ALL  i:_, ALL P:_,  cont P i --> !! exists P', table_get G i = Some P').

  Axiom funassert_get:
  forall G v nP,  funassert  G && cont nP v |--
                      EX P':assert, (ALL vl:list adr, |> ! (call nP vl <=> call (fst nP,P') vl)) && !! (table_get G v = Some (fst nP,P')).

  Parameter allocpool: forall (b: adr), mpred.
  Axiom alloc: forall b, allocpool b = ((!! (b > 0) && mapsto b 0) * allocpool (S b)).

  Parameter semax : varset -> funspecs -> assert -> control -> Prop.
  Parameter semax_func: forall (G: funspecs) (p: program) (G': funspecs), Prop.

  Axiom semax_func_nil: forall G, semax_func G nil nil.
  Axiom semax_func_cons:
   forall  fs id f vars P (G G': funspecs),
      inlist id (map (@fst adr (list var * control)) fs) = false ->
      list_nodups vars = true ->
      length vars = length (fst P) ->
      semax vars G (fun s => call P (map s vars)) f ->
      semax_func G fs G' ->
      semax_func G ((id, (vars,f))::fs) ((id, P) :: G').

  Definition program_proved (p: program) :=
   exists G, semax_func G p G
                            /\ table_get G 0 = Some  (0::nil, fun s => allocpool (eval (Var 0) s)).

  Axiom semax_sound:
  forall p, program_proved p -> forall n, run p n <> None.

  Axiom semax_go:  forall vars G (P: funspec) x ys,
    typecheck vars (Go x ys) = true ->
    semax vars G (fun s => cont P (eval x s) && call P (eval_list ys s)) (Go x ys) .

Axiom semax_assign: forall x y c vars G P,
    expcheck vars y = true ->
    semax (vs_add x vars) G P c ->
    semax vars G (fun s => |> subst x (eval y s) P s) (Do x := y ; c).

Axiom semax_if: forall x c1 c2 vars G (P: assert),
    expcheck vars x = true ->
    semax vars G (fun s => !!(eval x s <> 0) && P s) c1 ->
    semax vars G (fun s => !! (eval x s = 0) && P s) c2 ->
    semax vars G P (If x Then c1 Else c2).

Axiom semax_load:  forall x y z c vars G P,
    expcheck vars y = true ->
    semax (vs_add x vars) G P c ->
    semax vars G (fun s => (mapsto (eval y s) z * TT) && |> subst x z P s)
               (Do x := Mem y ; c).

Axiom semax_store: forall x y v c vars G (P: assert),
    expcheck vars x = true ->
    expcheck vars y = true ->
    semax vars G (fun s => mapsto (eval x s) (eval y s) * P s) c ->
    semax vars G (fun s => mapsto (eval x s) v  * P s)  (Do Mem x  := y ; c).

Axiom semax_pre:
  forall P P' vars G c, (forall s, P s |-- P' s) -> semax vars G P' c -> semax vars G P c.

Axiom semax_exp: forall A vars G (P: A -> assert) c,
    typecheck vars c = true ->
    (forall v:A, semax vars G (P v) c) ->
    semax vars G (fun s => EX v:A, (P v s)) c.

Axiom semax_exp': forall A (any: A) vars G (P: A -> assert) c,
    (forall v:A, semax vars G (P v) c) ->
    semax vars G (fun s => EX v:A, (P v s)) c.

Axiom semax_prop:
  forall (R: Prop) vars G P c,
      typecheck vars c = true ->
      (R -> semax vars G P c) ->
      semax vars G (fun s => !! R && P s) c.

Axiom semax_G:
   forall vars G P c, semax vars G (fun s => P s && funassert G) c -> semax vars G P c.

End SEMAX.