(*  Title:      HOL/HOLCF/IOA/SimCorrectness.thy
    Author:     Olaf Müller
*)

section \<open>Correctness of Simulations in HOLCF/IOA\<close>

theory SimCorrectness
imports Simulations
begin

(*Note: s2 instead of s1 in last argument type!*)
definition corresp_ex_simC ::
    "('a, 's2) ioa \<Rightarrow> ('s1 \<times> 's2) set \<Rightarrow> ('a, 's1) pairs \<rightarrow> ('s2 \<Rightarrow> ('a, 's2) pairs)"
  where "corresp_ex_simC A R =
    (fix \<cdot> (LAM h ex. (\<lambda>s. case ex of
      nil \<Rightarrow> nil
    | x ## xs \<Rightarrow>
        (flift1
          (\<lambda>pr.
            let
              a = fst pr;
              t = snd pr;
              T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s a t'
            in (SOME cex. move A cex s a T') @@ ((h \<cdot> xs) T')) \<cdot> x))))"

definition corresp_ex_sim ::
    "('a, 's2) ioa \<Rightarrow> ('s1 \<times> 's2) set \<Rightarrow> ('a, 's1) execution \<Rightarrow> ('a, 's2) execution"
  where "corresp_ex_sim A R ex \<equiv>
    let S' = SOME s'. (fst ex, s') \<in> R \<and> s' \<in> starts_of A
    in (S', (corresp_ex_simC A R \<cdot> (snd ex)) S')"

subsection \<open>\<open>corresp_ex_sim\<close>\<close>

lemma corresp_ex_simC_unfold:
  "corresp_ex_simC A R =
    (LAM ex. (\<lambda>s. case ex of
      nil \<Rightarrow> nil
    | x ## xs \<Rightarrow>
        (flift1
          (\<lambda>pr.
            let
              a = fst pr;
              t = snd pr;
              T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s a t'
            in (SOME cex. move A cex s a T') @@ ((corresp_ex_simC A R \<cdot> xs) T')) \<cdot> x)))"
  apply (rule trans)
  apply (rule fix_eq2)
  apply (simp only: corresp_ex_simC_def)
  apply (rule beta_cfun)
  apply (simp add: flift1_def)
  done

lemma corresp_ex_simC_UU [simp]: "(corresp_ex_simC A R \<cdot> UU) s = UU"
  apply (subst corresp_ex_simC_unfold)
  apply simp
  done

lemma corresp_ex_simC_nil [simp]: "(corresp_ex_simC A R \<cdot> nil) s = nil"
  apply (subst corresp_ex_simC_unfold)
  apply simp
  done

lemma corresp_ex_simC_cons [simp]:
  "(corresp_ex_simC A R \<cdot> ((a, t) \<leadsto> xs)) s =
    (let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s a t'
     in (SOME cex. move A cex s a T') @@ ((corresp_ex_simC A R \<cdot> xs) T'))"
  apply (rule trans)
  apply (subst corresp_ex_simC_unfold)
  apply (simp add: Consq_def flift1_def)
  apply simp
  done

subsection \<open>Properties of move\<close>

lemma move_is_move_sim:
   "is_simulation R C A \<Longrightarrow> reachable C s \<Longrightarrow> s \<midarrow>a\<midarrow>C\<rightarrow> t \<Longrightarrow> (s, s') \<in> R \<Longrightarrow>
     let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'
     in (t, T') \<in> R \<and> move A (SOME ex2. move A ex2 s' a T') s' a T'"
  supply Let_def [simp del]
  apply (unfold is_simulation_def)
  (* Does not perform conditional rewriting on assumptions automatically as
     usual. Instantiate all variables per hand. Ask Tobias?? *)
  apply (subgoal_tac "\<exists>t' ex. (t, t') \<in> R \<and> move A ex s' a t'")
  prefer 2
  apply simp
  apply (erule conjE)
  apply (erule_tac x = "s" in allE)
  apply (erule_tac x = "s'" in allE)
  apply (erule_tac x = "t" in allE)
  apply (erule_tac x = "a" in allE)
  apply simp
  (* Go on as usual *)
  apply (erule exE)
  apply (drule_tac x = "t'" and P = "\<lambda>t'. \<exists>ex. (t, t') \<in> R \<and> move A ex s' a t'" in someI)
  apply (erule exE)
  apply (erule conjE)
  apply (simp add: Let_def)
  apply (rule_tac x = "ex" in someI)
  apply assumption
  done

lemma move_subprop1_sim:
  "is_simulation R C A \<Longrightarrow> reachable C s \<Longrightarrow> s \<midarrow>a\<midarrow>C\<rightarrow> t \<Longrightarrow> (s, s') \<in> R \<Longrightarrow>
    let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'
    in is_exec_frag A (s', SOME x. move A x s' a T')"
  apply (cut_tac move_is_move_sim)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop2_sim:
  "is_simulation R C A \<Longrightarrow> reachable C s \<Longrightarrow> s \<midarrow>a\<midarrow>C\<rightarrow> t \<Longrightarrow> (s, s') \<in> R \<Longrightarrow>
    let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'
    in Finite (SOME x. move A x s' a T')"
  apply (cut_tac move_is_move_sim)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop3_sim:
  "is_simulation R C A \<Longrightarrow> reachable C s \<Longrightarrow> s \<midarrow>a\<midarrow>C\<rightarrow> t \<Longrightarrow> (s, s') \<in> R \<Longrightarrow>
    let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'
    in laststate (s', SOME x. move A x s' a T') = T'"
  apply (cut_tac move_is_move_sim)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop4_sim:
  "is_simulation R C A \<Longrightarrow> reachable C s \<Longrightarrow> s \<midarrow>a\<midarrow>C\<rightarrow> t \<Longrightarrow> (s, s') \<in> R \<Longrightarrow>
    let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'
    in mk_trace A \<cdot> (SOME x. move A x s' a T') = (if a \<in> ext A then a \<leadsto> nil else nil)"
  apply (cut_tac move_is_move_sim)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop5_sim:
  "is_simulation R C A \<Longrightarrow> reachable C s \<Longrightarrow> s \<midarrow>a\<midarrow>C\<rightarrow> t \<Longrightarrow> (s, s') \<in> R \<Longrightarrow>
    let T' = SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'
    in (t, T') \<in> R"
  apply (cut_tac move_is_move_sim)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

subsection \<open>TRACE INCLUSION Part 1: Traces coincide\<close>

subsubsection "Lemmata for <=="

text \<open>Lemma 1: Traces coincide\<close>

lemma traces_coincide_sim [rule_format (no_asm)]:
  "is_simulation R C A \<Longrightarrow> ext C = ext A \<Longrightarrow>
    \<forall>s s'. reachable C s \<and> is_exec_frag C (s, ex) \<and> (s, s') \<in> R \<longrightarrow>
      mk_trace C \<cdot> ex = mk_trace A \<cdot> ((corresp_ex_simC A R \<cdot> ex) s')"
  supply if_split [split del]
  apply (pair_induct ex simp: is_exec_frag_def)
  text \<open>cons case\<close>
  apply auto
  apply (rename_tac ex a t s s')
  apply (simp add: mk_traceConc)
  apply (frule reachable.reachable_n)
  apply assumption
  apply (erule_tac x = "t" in allE)
  apply (erule_tac x = "SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'" in allE)
  apply (simp add: move_subprop5_sim [unfolded Let_def]
    move_subprop4_sim [unfolded Let_def] split: if_split)
  done

text \<open>Lemma 2: \<open>corresp_ex_sim\<close> is execution\<close>

lemma correspsim_is_execution [rule_format]:
  "is_simulation R C A \<Longrightarrow>
    \<forall>s s'. reachable C s \<and> is_exec_frag C (s, ex) \<and> (s, s') \<in> R
      \<longrightarrow> is_exec_frag A (s', (corresp_ex_simC A R \<cdot> ex) s')"
  apply (pair_induct ex simp: is_exec_frag_def)
  text \<open>main case\<close>
  apply auto
  apply (rename_tac ex a t s s')
  apply (rule_tac t = "SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'" in lemma_2_1)

  text \<open>Finite\<close>
  apply (erule move_subprop2_sim [unfolded Let_def])
  apply assumption+
  apply (rule conjI)

  text \<open>\<open>is_exec_frag\<close>\<close>
  apply (erule move_subprop1_sim [unfolded Let_def])
  apply assumption+
  apply (rule conjI)

  text \<open>Induction hypothesis\<close>
  text \<open>\<open>reachable_n\<close> looping, therefore apply it manually\<close>
  apply (erule_tac x = "t" in allE)
  apply (erule_tac x = "SOME t'. \<exists>ex1. (t, t') \<in> R \<and> move A ex1 s' a t'" in allE)
  apply simp
  apply (frule reachable.reachable_n)
  apply assumption
  apply (simp add: move_subprop5_sim [unfolded Let_def])
  text \<open>laststate\<close>
  apply (erule move_subprop3_sim [unfolded Let_def, symmetric])
  apply assumption+
  done

subsection \<open>Main Theorem: TRACE - INCLUSION\<close>

text \<open>
  Generate condition \<open>(s, S') \<in> R \<and> S' \<in> starts_of A\<close>, the first being
  interesting for the induction cases concerning the two lemmas
  \<open>correpsim_is_execution\<close> and \<open>traces_coincide_sim\<close>, the second for the start
  state case.
  \<open>S' := SOME s'. (s, s') \<in> R \<and> s' \<in> starts_of A\<close>, where \<open>s \<in> starts_of C\<close>
\<close>

lemma simulation_starts:
  "is_simulation R C A \<Longrightarrow> s\<in>starts_of C \<Longrightarrow>
    let S' = SOME s'. (s, s') \<in> R \<and> s' \<in> starts_of A
    in (s, S') \<in> R \<and> S' \<in> starts_of A"
  apply (simp add: is_simulation_def corresp_ex_sim_def Int_non_empty Image_def)
  apply (erule conjE)+
  apply (erule ballE)
  prefer 2 apply blast
  apply (erule exE)
  apply (rule someI2)
  apply assumption
  apply blast
  done

lemmas sim_starts1 = simulation_starts [unfolded Let_def, THEN conjunct1]
lemmas sim_starts2 = simulation_starts [unfolded Let_def, THEN conjunct2]

lemma trace_inclusion_for_simulations:
  "ext C = ext A \<Longrightarrow> is_simulation R C A \<Longrightarrow> traces C \<subseteq> traces A"
  apply (unfold traces_def)
  apply (simp add: has_trace_def2)
  apply auto

  text \<open>give execution of abstract automata\<close>
  apply (rule_tac x = "corresp_ex_sim A R ex" in bexI)

  text \<open>Traces coincide, Lemma 1\<close>
  apply (pair ex)
  apply (rename_tac s ex)
  apply (simp add: corresp_ex_sim_def)
  apply (rule_tac s = "s" in traces_coincide_sim)
  apply assumption+
  apply (simp add: executions_def reachable.reachable_0 sim_starts1)

  text \<open>\<open>corresp_ex_sim\<close> is execution, Lemma 2\<close>
  apply (pair ex)
  apply (simp add: executions_def)
  apply (rename_tac s ex)

  text \<open>start state\<close>
  apply (rule conjI)
  apply (simp add: sim_starts2 corresp_ex_sim_def)

  text \<open>\<open>is_execution-fragment\<close>\<close>
  apply (simp add: corresp_ex_sim_def)
  apply (rule_tac s = s in correspsim_is_execution)
  apply assumption
  apply (simp add: reachable.reachable_0 sim_starts1)
  done

end


theory TelephoneExchange
  imports "Z_Machines.Z_Machine"
begin unbundle Z_Syntax

type_synonym digit = integer
type_synonym subs = "digit list"

definition Digit :: "\<bbbP> digit" where "Digit = integer_of_int ` {0..9}"

consts
  Subs :: "\<bbbP> (digit list)"

definition "Valid = {n \<in> blists 6 Digit. \<exists> s \<in> Subs. n \<le> s}"

definition
  "TelephoneExchange_axioms = (Subs \<in> \<bbbP> (seq Digit))"

enumtype Status = seize | dialling | unobtainable | connecting | ringing | speech | engaged | suspended

definition "Connected = {ringing , speech, suspended}"

definition "Established = Connected \<union> {connecting , engaged}"

type_synonym subrec = "Status \<times> digit list"

definition SubRec :: "Status \<leftrightarrow> digit list" where
"SubRec = {(s, n). (s = seize \<longleftrightarrow> n = [])
                 \<and> (s = dialling \<longleftrightarrow> n \<in> Valid - Subs - {[]})
                 \<and> (s = unobtainable \<longleftrightarrow> n \<notin> Valid)
                 \<and> (s \<in> Established \<longleftrightarrow> n \<in> Subs)}"

definition st :: "subrec \<Zpfun> Status" where [simp]: "st = (\<lambda> x \<bullet> first x)"
definition num :: "subrec \<Zpfun> subs" where [simp]: "num = (\<lambda> x \<bullet> second x)"

no_syntax
  "_kleisli_comp" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<Zcomp>" 54)

schema Exchange =
  Free :: "\<bbbP> subs"
  Unavailable :: "\<bbbP> subs"
  Callers :: "\<bbbP> subs"
  cal :: "subs \<leftrightarrow> subrec"
  connected :: "subs \<leftrightarrow> subs"
where
  "[Free, Unavailable, dom cal \<union> dom connected] partitions Subs"
  "Callers = dom ((cal \<Zcomp> st) \<Zrres> Connected)"
  "connected = Callers \<Zdres> (cal \<Zcomp> num)"
  "functional cal"

record_default Exchange

definition "InitExchange = [Free\<Zprime> = Subs, Unavailable\<Zprime> = {}, Callers\<Zprime> = {}, cal\<Zprime> = {}, connected\<Zprime> = {}]"

zoperation LiftFree =
  params s \<in> Subs
  pre "s \<in> Free"
  update "[Free\<Zprime> = Free - {s}
          ,cal\<Zprime> = cal \<union> {s \<mapsto> (seize, [])}]"

declare list_partitions_def [simp]

lemma "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange\<^bold>}LiftFree s\<^bold>{Exchange\<^bold>}"
  unfolding LiftFree_def Exchange_inv_def Connected_def
  apply (hoare_wlp_auto)
  apply (simp add: Domain_iff disjoint_iff rel_ranres_def)
   apply (simp_all add: Domain_iff disjoint_iff rel_ranres_def)
  apply (rule compatible_relI)
  apply (simp add: pfun_graph_domres[THEN sym])
  apply (subgoal_tac "s \<notin> dom cal")
  apply (auto)
  done

zoperation LiftSuspended =
  params s \<in> Subs
  pre "(s, suspended) \<in> connected\<^sup>\<sim> \<Zcomp> cal \<Zcomp> st"
  update "[cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (speech, s)}]"

zoperation Answer =
  params s \<in> Subs
  pre "(s, ringing) \<in> connected\<^sup>\<sim> \<Zcomp> cal \<Zcomp> st"
  update "[ Free\<Zprime> = Free - {s}
          , cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (speech, s)}]"

definition "nextstate n =
  (if n \<in> Subs then connecting
   else if n \<in> Valid - Subs then dialling
   else unobtainable)"

zoperation Dial =
  params s \<in> Subs d \<in> Digit
  pre "(s, seize) \<in> cal \<Zcomp> st \<or> (s, dialling) \<in> cal \<Zcomp> st"
  update "[cal\<Zprime> = (let newnum = (cal \<Zcomp> num) s @ [d] in cal \<oplus> {s \<mapsto> (nextstate newnum, newnum)})]"

zoperation ClearAttempt =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {seize, dialling , connecting , engaged, unobtainable}"
  update "[Free\<Zprime> = Free \<union> {s}, cal\<Zprime> = {s} \<Zndres> cal]"

zoperation ClearLine =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {ringing , suspended}"
  update "[ Free\<Zprime> = Free \<union> {s, connected s}, cal\<Zprime> = {s} \<Zndres> cal
          , Callers\<Zprime> = Callers - {s, connected s}
          , connected\<Zprime> = {s} \<Zndres> connected]"

zoperation ClearConnect =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = speech"
  update "[ Free\<Zprime> = Free \<union> {s}
          , cal\<Zprime> = ({s} \<Zndres> cal) \<oplus> {connected s \<mapsto> (seize, [])}
          , Callers\<Zprime> = Callers - {s}
          , connected\<Zprime> = {s} \<Zndres> connected]"

zoperation ClearSuspend =
  params s \<in> Subs
  pre "s \<in> ran connected"
  update "[cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (suspended, s)}]"

zoperation ClearUnavail =
  params s \<in> Subs
  pre "s \<in> Unavailable"
  update "[Free\<Zprime> = Free \<union> {s}, Unavailable\<Zprime> = Unavailable - {s}]"

zoperation MakeUnavail =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {seize, dialling}"
  update "[Unavailable\<Zprime> = Unavailable \<union> {s}, cal\<Zprime> = {s} \<Zndres> cal]"

zoperation Connect2Ringing =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = connecting \<and> s \<notin> dom connected \<and> (cal \<Zcomp> num) s \<in> Free \<and> (cal \<Zcomp> num) s \<notin> ran connected"
  update "[ Free\<Zprime> = Free - {s}
          , cal\<Zprime> = cal \<oplus> {s \<mapsto> (ringing, (cal \<Zcomp> num) s)}
          , Callers\<Zprime> = Callers \<union> {s}
          , connected\<Zprime> = connected \<oplus> {s \<mapsto> (cal \<Zcomp> num) s}]"

zoperation Connect2Engaged =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = connecting \<and> s \<notin> dom connected \<and> (cal \<Zcomp> num) s \<notin> Free"
  update "[ cal\<Zprime> = cal \<oplus> {s \<mapsto> (engaged, (cal \<Zcomp> num) s)} ]"

zmachine TelephoneExchange =
  over Exchange
  init "InitExchange"
  operations
    LiftFree LiftSuspended Answer Dial
    ClearAttempt ClearLine ClearConnect ClearSuspend ClearUnavail
    MakeUnavail
    Connect2Ringing Connect2Engaged

def_consts Subs = "{[1,2,3], [3,4,5], [6,7,8]}"

animate TelephoneExchange

end


theory IICF_List_List
imports
  "../../Sepref"
begin

  context begin
    private abbreviation (input) "LR A \<equiv> \<langle>\<langle>A\<rangle>list_rel\<rangle>list_rel"

    sepref_decl_op list_list_lempty: "\<lambda>n. replicate n []" :: "nat_rel \<rightarrow> LR A" .
    sepref_decl_op list_list_push_back: "\<lambda>xss i x. xss[i:=xss!i@[x]]"
      :: "[\<lambda>((xss,i),_). i<length xss]\<^sub>f (LR A \<times>\<^sub>r nat_rel) \<times>\<^sub>r A \<rightarrow> LR A" .

    sepref_decl_op list_list_pop_back: "\<lambda>xss i. (last (xss!i), xss[i:=butlast (xss!i)])"
      :: "[\<lambda>(xss,i). i<length xss \<and> xss!i\<noteq>[]]\<^sub>f (LR A \<times>\<^sub>r nat_rel)\<rightarrow> A \<times>\<^sub>r LR A"
      unfolding conv_to_is_Nil short_circuit_conv
      by parametricity

    sepref_decl_op list_list_idx: "\<lambda>xss i j. xss!i!j" :: "[\<lambda>((xss,i),j). i<length xss \<and> j<length (xss!i)]\<^sub>f ((LR A \<times>\<^sub>r nat_rel) \<times>\<^sub>r nat_rel) \<rightarrow> A"
      unfolding short_circuit_conv
      by parametricity

    sepref_decl_op list_list_llen: "\<lambda>xss i. length (xss!i)" :: "[\<lambda>(xss,i). i<length xss]\<^sub>f LR A \<times>\<^sub>r nat_rel \<rightarrow> nat_rel" .
    sepref_decl_op list_list_len: "length :: _ list list \<Rightarrow> _" :: "LR A \<rightarrow> nat_rel" .

    sepref_decl_op list_list_take: "\<lambda>xss i l. (xss[i:=take l (xss!i)])"
      :: "[\<lambda>((xss,i),l). i<length xss \<and> l\<le>length (xss!i)]\<^sub>f ((LR A \<times>\<^sub>r nat_rel) \<times>\<^sub>r nat_rel)\<rightarrow> LR A"
      unfolding conv_to_is_Nil short_circuit_conv
      by parametricity

  end

  locale list_list_custom_empty =
    fixes rel empty PRE and op_custom_empty :: "nat \<Rightarrow> 'a list list"
    assumes customize_hnr_aux: "(empty,(RETURN o (op_list_list_lempty::nat \<Rightarrow> 'a list list))) \<in> [PRE]\<^sub>a snat_assn\<^sup>k \<rightarrow> rel"
    assumes op_custom_empty_def: "op_custom_empty = op_list_list_lempty"
  begin
    sepref_register op_custom_empty :: "nat \<Rightarrow> 'c list list"

    lemma fold_custom_empty:
      "replicate n [] = op_custom_empty n"
      "op_list_list_lempty = op_custom_empty"
      "mop_list_list_lempty n = RETURN (op_custom_empty n)"
      unfolding op_custom_empty_def by simp_all

    lemmas custom_hnr[sepref_fr_rules] = customize_hnr_aux[folded op_custom_empty_def]
  end

end


(*  Title:      Containers/Closure_set.thy
    Author:     Andreas Lochbihler, KIT *)

theory Closure_Set imports Equal begin

section \<open>Sets implemented as Closures\<close>

context equal_base begin

definition fun_upd :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b"
where fun_upd_apply: "fun_upd f a b a' = (if equal a a' then b else f a')"

end

lemmas [code] = equal_base.fun_upd_apply
lemmas [simp] = equal_base.fun_upd_apply

lemma fun_upd_conv_fun_upd: "equal_base.fun_upd (=) = fun_upd"
by(simp add: fun_eq_iff)

end


chapter \<open>Basic Control Flow\<close>

theory PhiSem_CF_Basic
  imports PhiSem_Generic_Boolean
begin

section \<open>Instructions\<close>

subsection \<open>Non-Branching Selection\<close>

definition op_sel :: "TY \<Rightarrow> (VAL \<times> VAL \<times> VAL, VAL) proc'"
  where "op_sel TY =
    \<phi>M_caseV (\<lambda>vc. \<phi>M_caseV (\<lambda>va vb.
    \<phi>M_getV bool V_bool.dest vc (\<lambda>c.
    \<phi>M_getV TY id va (\<lambda>a.
    \<phi>M_getV TY id vb (\<lambda>b.
    Return (\<phi>arg (if c then b else a)))))))"

subsection \<open>Branch\<close>

definition op_if :: "'ret proc
                  \<Rightarrow> 'ret proc
                  \<Rightarrow> (VAL,'ret::VALs) proc'"
  where "op_if brT brF v =
    \<phi>M_getV bool V_bool.dest v (\<lambda>c. (if c then brT else brF))"

subsection \<open>While Loop\<close>

inductive SemDoWhile :: "VAL proc \<Rightarrow> resource \<Rightarrow> unit comp \<Rightarrow> bool" where
  "Success (\<phi>arg (V_bool.mk False)) res \<in> f s \<Longrightarrow> SemDoWhile f s (Success (\<phi>arg ()) res)"
| "Success (\<phi>arg (V_bool.mk True)) res \<in> f s \<Longrightarrow> SemDoWhile f res s'' \<Longrightarrow> SemDoWhile f s s''"
| "Abnormality v e \<in> f s \<Longrightarrow> SemDoWhile f s (Abnormality v e)"
| "NonTerm \<in> f s \<Longrightarrow> SemDoWhile f s NonTerm"
| "AssumptionBroken \<in> f s \<Longrightarrow> SemDoWhile f s AssumptionBroken"
| "Invalid \<in> f s \<Longrightarrow> SemDoWhile f s Invalid"

lemma "\<nexists> y. SemDoWhile ((\<lambda>res. Return (\<phi>arg (V_bool.mk True)) res) :: VAL proc) res y"
  apply rule apply (elim exE) subgoal for y
    apply (induct "((\<lambda>res. Return (\<phi>arg (V_bool.mk True)) (res::resource)) :: VAL proc)" res y
           rule: SemDoWhile.induct)
       apply (simp_all add: Return_def det_lift_def) . .

definition op_do_while :: " VAL proc \<Rightarrow> unit proc"
  where "op_do_while f s = Collect (SemDoWhile f s)"

(* lemma SemDoWhile_deterministic:
  assumes "SemDoWhile c s s1"
      and "SemDoWhile c s s2"
    shows "s1 = s2"
proof -
  have "SemDoWhile c s s1 \<Longrightarrow> (\<forall>s2. SemDoWhile c s s2 \<longrightarrow> s1 = s2)"
    apply (induct rule: SemDoWhile.induct)
    by (subst SemDoWhile.simps, simp)+
  thus ?thesis
    using assms by simp
qed

lemma SemDoWhile_deterministic2:
    "SemDoWhile body s x \<Longrightarrow> The ( SemDoWhile body s) = x"
  using SemDoWhile_deterministic by blast *)

subsection \<open>Recursion\<close>

inductive SemRec :: "(('a,'a) proc' \<Rightarrow> ('a,'a) proc')
            \<Rightarrow> 'a \<phi>arg \<Rightarrow> resource \<Rightarrow> 'a comp set \<Rightarrow> bool"
where
  SemRec_I0: "(\<And>g. F g x res = y) \<Longrightarrow> SemRec F x res y"
| SemRec_IS: "SemRec (F o F) x res y \<Longrightarrow> SemRec F x res y"

definition op_fix_point :: "(('a,'a) proc' \<Rightarrow> ('a,'a) proc')
                         \<Rightarrow> ('a,'a) proc'"
  where "op_fix_point F x s = (if (\<exists>t. SemRec F x s t) then The (SemRec F x s) else {})"

subsubsection \<open>Simple Properties\<close>

lemma SemRec_IR: "SemRec F x r y \<Longrightarrow> SemRec (F o F) x r y"
  by (induct rule: SemRec.induct, rule SemRec_I0, simp)

lemma SemRec_deterministic:
  assumes "SemRec c s r s1" and "SemRec c s r s2" shows "s1 = s2"
proof -
  have "SemRec c s r s1 \<Longrightarrow> (\<forall>s2. SemRec c s r s2 \<longrightarrow> s1 = s2)"
    apply (induct rule: SemRec.induct)
     apply clarify
    subgoal for F a b y s2 apply (rotate_tac 1)
      apply (induct rule: SemRec.induct) by auto
    apply clarify apply (blast intro: SemRec_IR) done
  thus ?thesis using assms by simp
qed

lemma SemRec_deterministic2: " SemRec body s r x \<Longrightarrow> The (SemRec body s r) = x"
  using SemRec_deterministic by (metis theI_unique)

section \<open>Abstraction of Procedures\<close>

subsubsection \<open>Syntax for Annotations\<close>

consts Invariant :: \<open>bool \<Rightarrow> bool\<close> ("Inv: _" [100] 36)
consts Guard :: \<open>bool \<Rightarrow> bool\<close> ("Guard: _" [100] 36)
consts End   :: \<open>bool \<Rightarrow> bool\<close> ("End: _" [100] 36)

subsection \<open>Branch-like\<close>

lemma op_sel_\<phi>app:
  \<open> \<phi>SemType (a \<Ztypecolon> A) TY
\<Longrightarrow> \<phi>SemType (b \<Ztypecolon> B) TY
\<Longrightarrow> \<p>\<r>\<o>\<c> op_sel TY (\<phi>V_pair rawc (\<phi>V_pair rawb rawa)) \<lbrace>
        a \<Ztypecolon> \<v>\<a>\<l>[rawa] A\<heavy_comma> b \<Ztypecolon> \<v>\<a>\<l>[rawb] B\<heavy_comma> c \<Ztypecolon> \<v>\<a>\<l>[rawc] \<bool>
    \<longmapsto> (if c then a else b) \<Ztypecolon> \<v>\<a>\<l> (if c then A else B)
    \<rbrace>\<close>
  unfolding op_sel_def
  by (cases rawc; cases rawb; cases rawa; cases c; simp add: \<phi>SemType_def subset_iff,
      rule, rule, rule, simp add: \<phi>expns WT_bool, blast, rule, simp add: \<phi>expns WT_bool, rule,
      simp add: \<phi>expns WT_bool, rule, simp add: \<phi>expns WT_bool)

lemma branch_\<phi>app:
  \<open> (\<p>\<r>\<e>\<m>\<i>\<s>\<e>   C \<longrightarrow> \<p>\<r>\<o>\<c> br\<^sub>T \<lbrace> X \<longmapsto> Y\<^sub>T \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E\<^sub>T )
\<Longrightarrow> (\<p>\<r>\<e>\<m>\<i>\<s>\<e> \<not> C \<longrightarrow> \<p>\<r>\<o>\<c> br\<^sub>F \<lbrace> X \<longmapsto> Y\<^sub>F \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E\<^sub>F )
\<Longrightarrow> (\<And>v. If C (Y\<^sub>T v) (Y\<^sub>F v) \<i>\<m>\<p>\<l>\<i>\<e>\<s> Y v @action invoke_branch_convergence)
\<Longrightarrow> \<p>\<r>\<o>\<c> op_if br\<^sub>T br\<^sub>F rawc \<lbrace> X\<heavy_comma> C \<Ztypecolon> \<v>\<a>\<l>[rawc] \<bool> \<longmapsto> Y \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> (\<lambda>e. (E\<^sub>T e \<s>\<u>\<b>\<j> C) + (E\<^sub>F e \<s>\<u>\<b>\<j> \<not> C)) \<close>
  unfolding op_if_def Premise_def Action_Tag_def
  apply (cases rawc; cases C; simp; rule; simp add: \<phi>expns WT_bool)
  using \<phi>CONSEQ view_shift_by_implication view_shift_refl by blast+

proc "if":
  assumes C: \<open>\<p>\<r>\<o>\<c> cond \<lbrace> X \<longmapsto> X1\<heavy_comma> \<v>\<a>\<l> C \<Ztypecolon> \<bool> \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E \<close>
      and brT: \<open>\<p>\<r>\<e>\<m>\<i>\<s>\<e>   C \<longrightarrow> \<p>\<r>\<o>\<c> brT \<lbrace> X1 \<longmapsto> Y\<^sub>T \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E\<^sub>T \<close>
      and brF: \<open>\<p>\<r>\<e>\<m>\<i>\<s>\<e> \<not> C \<longrightarrow> \<p>\<r>\<o>\<c> brF \<lbrace> X1 \<longmapsto> Y\<^sub>F \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E\<^sub>F \<close>
      and BC: \<open>(\<And>v. If C (Y\<^sub>T v) (Y\<^sub>F v) \<i>\<m>\<p>\<l>\<i>\<e>\<s> Y v @action invoke_branch_convergence)\<close>
  input  \<open>X\<close>
  output \<open>Y\<close>
  throws \<open>E + E\<^sub>T + E\<^sub>F\<close>
  \<medium_left_bracket> C branch brT brF BC \<medium_right_bracket>. .

subsection \<open>Loops\<close>

lemma "__DoWhile__rule_\<phi>app":
  " \<p>\<r>\<o>\<c> body \<lbrace> X x \<s>\<u>\<b>\<j> x. P x \<longmapsto> (\<exists>*x'. X x' \<heavy_comma> \<v>\<a>\<l> P x' \<Ztypecolon> \<bool>) \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> \<p>\<r>\<o>\<c> op_do_while body \<lbrace> X x \<s>\<u>\<b>\<j> x. P x \<longmapsto> X x' \<s>\<u>\<b>\<j> x'. \<not> P x' \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E "
  unfolding op_do_while_def \<phi>Procedure_def
  apply (simp add: subset_iff LooseStateSpec_expn')
  apply (rule allI impI conjI)+
  subgoal for comp R s
  apply (rotate_tac 2)
    apply (induct body comp s rule: SemDoWhile.induct; clarsimp simp add: \<phi>expns times_list_def)
    apply fastforce
    subgoal premises prems for res f s s'' c u v proof -
      have t1: \<open>\<exists>c. (\<exists>fic. (\<exists>u v. fic = u * v \<and> u \<in> R \<and> v \<in> X c \<and> u ## v) \<and> s \<in> INTERP_RES fic) \<and> P c\<close>
        using prems(5) prems(6) prems(7) prems(8) prems(9) by blast
      show ?thesis
        apply (insert \<open>\<forall>_ _. (\<exists>_. _) \<longrightarrow> _\<close>[THEN spec[where x=s], THEN spec[where x=R], THEN mp, OF t1])
        using prems(1) prems(3) by fastforce
    qed
    apply fastforce
    by blast .

proc (nodef) do_while:
assumes \<open>\<p>\<a>\<r>\<a>\<m> ( X' x \<s>\<u>\<b>\<j> x. Inv: invariant x \<and> Guard: cond x)\<close>
    and V: \<open>X \<i>\<m>\<p>\<l>\<i>\<e>\<s> ( X' x \<s>\<u>\<b>\<j> x. invariant x \<and> cond x) \<a>\<n>\<d> Any @action ToSA\<close>
assumes B: \<open>\<forall>x. \<p>\<r>\<e>\<m>\<i>\<s>\<e> cond x \<longrightarrow> \<p>\<r>\<e>\<m>\<i>\<s>\<e> invariant x
    \<longrightarrow> \<p>\<r>\<o>\<c> body \<lbrace> X' x \<longmapsto> (X' x'\<heavy_comma> \<v>\<a>\<l> cond x' \<Ztypecolon> \<bool> \<s>\<u>\<b>\<j> x'. invariant x') \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E \<close>
input  \<open>X\<close>
output \<open>X' x' \<s>\<u>\<b>\<j> x'. invariant x' \<and> \<not> cond x'\<close>
throws E
  \<medium_left_bracket>
    V[unfolded Action_Tag_def]
    "__DoWhile__rule_\<phi>app"[where P=cond and X=\<open>\<lambda>x'. X' x' \<s>\<u>\<b>\<j> invariant x'\<close>, simplified]
  \<medium_left_bracket> B \<medium_right_bracket>.
  \<medium_right_bracket> by simp .

proc while:
  assumes \<open>\<p>\<a>\<r>\<a>\<m> ( X x \<s>\<u>\<b>\<j> x. Inv: invariant x \<and> Guard: cond x)\<close>
  assumes V[unfolded Action_Tag_def]:
           "X' \<i>\<m>\<p>\<l>\<i>\<e>\<s> ((X x \<r>\<e>\<m>\<a>\<i>\<n>\<s> R) \<s>\<u>\<b>\<j> x. invariant x) \<a>\<n>\<d> Any @action ToSA"
    and C: "\<forall>x. \<p>\<r>\<e>\<m>\<i>\<s>\<e> invariant x \<longrightarrow> \<p>\<r>\<o>\<c> Cond \<lbrace> R\<heavy_comma> X x \<longmapsto> R\<heavy_comma> X x'\<heavy_comma> \<v>\<a>\<l> cond x' \<Ztypecolon> \<bool> \<s>\<u>\<b>\<j> x'. invariant x' \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E1"
    and B: "\<forall>x. \<p>\<r>\<e>\<m>\<i>\<s>\<e> invariant x \<longrightarrow> \<p>\<r>\<e>\<m>\<i>\<s>\<e> cond x \<longrightarrow> \<p>\<r>\<o>\<c> Body \<lbrace> R\<heavy_comma> X x \<longmapsto> R\<heavy_comma> X x' \<s>\<u>\<b>\<j> x'. invariant x' \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E2"
  input  \<open>X'\<close>
  output \<open>R\<heavy_comma> X x \<s>\<u>\<b>\<j> x. invariant x \<and> \<not> cond x\<close>
  throws \<open>E1 + E2\<close>
  \<medium_left_bracket> V C
    branch \<medium_left_bracket>
      do_while \<open>R\<heavy_comma> X vars \<s>\<u>\<b>\<j> vars. Inv: invariant vars \<and> Guard: cond vars\<close>
      \<medium_left_bracket> B C \<medium_right_bracket>.
      \<medium_right_bracket>.
    \<medium_left_bracket> \<medium_right_bracket> for \<open>R\<heavy_comma> X vars \<s>\<u>\<b>\<j> vars. invariant vars \<and> \<not> cond vars\<close> ..
  \<medium_right_bracket> .. .

(*
We fail to infer the abstraction of the loop guard automatically but
require users to give by an annotation.
The main difficulty is about the nondeterminancy in higher-order unification.
In \<^term>\<open>cond x' \<Ztypecolon> \<bool>\<close> in the above rule, both \<open>cond\<close> and \<open>x'\<close> are schematic variables,
which means we cannot determine either of them via unification.
Even though the abstract state \<open>x'\<close> may be determined possibly in the unification of \<open>X x'\<close>,
to infer \<open>cond x'\<close> it is still a problem especially when \<open>x'\<close> is not a variable but a compounded
term and its expression may be shattered in and mixed up with the expression of \<open>cond\<close> after
simplifications like beta reduction,
causing it is very difficult to recover the actual abstract guard
\<open>cond\<close> from the reduced composition \<open>cond x'\<close>.
*)

subsection \<open>Recursion\<close>

lemma "__op_recursion_simp__":
  "(\<And>g x' v'. (\<And>x'' v''. \<p>\<r>\<o>\<c> g v''  \<lbrace> X x'' v'' \<longmapsto> \<lambda>ret. Y x'' ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E x'')
                      \<Longrightarrow> \<p>\<r>\<o>\<c> F g v' \<lbrace> X x' v'   \<longmapsto> \<lambda>ret. Y x'  ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E x' )
\<Longrightarrow> \<forall>x v. \<p>\<r>\<o>\<c> op_fix_point F v \<lbrace> X x v \<longmapsto> \<lambda>ret. Y x ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E x"
  unfolding op_fix_point_def \<phi>Procedure_def atomize_all
  apply (clarsimp simp add: SemRec_deterministic2 del: subsetI)

  subgoal for x v comp a R
    apply (rotate_tac 1) apply (induct rule: SemRec.induct)

    subgoal premises prems for F v res y
      using prems(3)[of \<open>\<lambda>_ _. {AssumptionBroken}\<close> x v, simplified, THEN spec[where x=res],
                     THEN spec[where x=R], THEN mp, OF prems(2), unfolded prems(1)] .
    by simp .

text \<open>Instead, we use a variant of the above rule which in addition annotates the names
  of the values.\<close>

lemma "__op_recursion__":
  "(\<And>g x' (v':: 'a::VALs \<phi>arg <named> 'names).
          P x'
      \<Longrightarrow> PROP Labelled label (HIDDEN_PREM
          (\<And>x'' (v''::'a \<phi>arg <named> 'names).
              P x'' \<Longrightarrow>
              \<p>\<r>\<o>\<c> g (case_named id v'') \<lbrace> case_named (X x'') v'' \<longmapsto> \<lambda>ret. Y x'' ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E x''))
      \<Longrightarrow> \<p>\<r>\<o>\<c> F g (case_named id v') \<lbrace> case_named (X x') v'   \<longmapsto> \<lambda>ret. Y x'  ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E x' )
\<Longrightarrow> PROP Pure.prop (
      P x \<Longrightarrow>
      \<p>\<r>\<o>\<c> op_fix_point F v \<lbrace> X x v \<longmapsto> \<lambda>ret. Y x ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E x
)"
  unfolding op_fix_point_def \<phi>Procedure_def atomize_all \<phi>arg_forall \<phi>arg_All HIDDEN_PREM_def
            Pure.prop_def
  apply (clarsimp simp add: SemRec_deterministic2 del: subsetI)

  subgoal for comp a R
    apply (rotate_tac 2) apply (induct rule: SemRec.induct)

    subgoal premises prems for F v res y
      using prems(3)[OF prems(4),
                     of \<open>\<lambda>_ _. {AssumptionBroken}\<close> v, simplified, THEN spec[where x=res],
                     THEN spec[where x=R], THEN mp, OF prems(2), unfolded prems(1)] .
    by simp .

ML_file \<open>library/basic_recursion.ML\<close>

attribute_setup recursive = \<open>Scan.repeat (Scan.lift Parse.term) >> (fn vars =>
    Phi_Modifier.wrap_to_attribute (fn (ctxt,sequent) =>
      case Phi_Toplevel.name_of_the_building_procedure ctxt
        of NONE => error "Name binding of the recursive procedure is mandatory."
         | SOME b => (
            if Binding.is_empty b
            then error "Name binding of the recursive procedure is mandatory."
            else if null vars then tracing "You may want to use syntax \<open>recursive vars\<close> to indicate \
                 \which variables are varied between the recursive callings." else ();
            PhiSem_Control_Flow.basic_recursive_mod Syntax.read_terms b vars (ctxt,sequent)
           )
  ))\<close>

end


section \<open>Preparing Partial Order Reduction\<close>
theory SM_Visible
imports "../RefPoint/SM_LTL" Rename_Cfg
begin

  section \<open>Visible Part of State\<close>

  locale visible_prog = well_typed_prog +
    fixes is_vis_var :: "ident \<Rightarrow> bool"
  begin
    abbreviation "vis_vars \<equiv> Collect is_vis_var"

    definition interp_gs :: "global_state \<Rightarrow> exp set" where
      "interp_gs gs \<equiv> sm_props (global_state.variables gs |` vis_vars)"

    definition interp_gc :: "global_config \<Rightarrow> exp set" where
      "interp_gc gc \<equiv> interp_gs (global_config.state gc)"

    sublocale lv: Gen_Scheduler'_linit
      cfgc la_en' la_ex'
      "{init_gc}" interp_gc .

    lemma lv_accept_conv: "lv.sa.accept w
      \<longleftrightarrow> (\<exists>w'. w=interp_gs o w' \<and> ref_accept prog w')"
      unfolding lih'_accept_eq[symmetric]
      unfolding lih'.sa.accept_def lv.sa.accept_def
      unfolding lih'.sa.is_run_def
      unfolding lv.sa.is_run_def
      apply simp
      unfolding interp_gc_def[abs_def]
      by fastforce

  end
end


theory X86_Parse_Hoare_Triples
  imports X86_InstructionSemantics
  keywords "htriple" :: thy_decl

  and "Separations" "Assertions" "Pre" "Post" "Instruction" "FunctionConstraints" :: quasi_command

begin

context semantics
begin

lemma ucast_take_bits_8[simp]:
  fixes a :: "'b::len word"
  assumes "LENGTH('b) > 8"
  shows "((ucast (\<langle>0,8\<rangle>a)::'a ::len word) = ucast (ucast a :: 8 word))"
  using assms
  by (auto simp add: word_eq_iff word_size nth_ucast nth_takebits)

lemma ucast_take_bits_16[simp]:
  fixes a :: "'b::len word"
  assumes "LENGTH('b) > 16"
  shows "((ucast (\<langle>0,16\<rangle>a)::'a::len word) = ucast (ucast a :: 16 word))"
  using assms
  by (auto simp add: word_eq_iff word_size nth_ucast nth_takebits)

lemma ucast_take_bits_32[simp]:
  fixes a :: "'b::len word"
  assumes "LENGTH('b) > 32"
  shows "((ucast (\<langle>0,32\<rangle>a)::'a::len word) = ucast (ucast a :: 32 word))"
  using assms
  by (auto simp add: word_eq_iff word_size nth_ucast nth_takebits)

lemma ucast_ucast_ucast[simp]:
  assumes "LENGTH('c) < LENGTH('b)"
  shows  "(ucast (ucast (ucast (w::'a::len word)::'b::len word)::'c::len word)::'d::len word) = ucast (ucast w::'c::len word)"
  using assms
  by (auto simp add: word_eq_iff nth_ucast)

lemma scast_ucast_ucast[simp]:
  assumes "LENGTH('c) < LENGTH('b)"
  shows  "(scast (ucast (ucast (w::'a::len word)::'b::len word)::'c::len word)::'d::len word) = scast (ucast w::'c::len word)"
  using assms
  by (auto simp add: word_eq_iff nth_ucast nth_scast)

lemma test_bit_mem_read:
  shows "mem_read \<sigma> a si !! n \<Longrightarrow> n < si*8"
  by (auto simp add: mem_read_def test_bit_rcat word_size rev_nth length_read_bytes)

lemma ucast_ucast_mem_read_8[simp]:
assumes "LENGTH('a) > 8"
  shows "(ucast (ucast (mem_read \<sigma> a 1)::'a::len word) :: 8 word) = ucast (mem_read \<sigma> a 1)"
  apply (subst word_eq_iff)+
  using test_bit_mem_read[of \<sigma> a 4] assms
  by (auto simp add: word_size nth_ucast)

lemma ucast_ucast_mem_read_16[simp]:
assumes "LENGTH('a) > 16"
  shows "(ucast (ucast (mem_read \<sigma> a 2)::'a::len word) :: 16 word) = ucast (mem_read \<sigma> a 2)"
  apply (subst word_eq_iff)+
  using test_bit_mem_read[of \<sigma> a 4] assms
  by (auto simp add: word_size nth_ucast)

lemma ucast_ucast_mem_read_32[simp]:
  assumes "LENGTH('a) > 32"
  shows "(ucast (ucast (mem_read \<sigma> a 4)::'a::len word) :: 32 word) = ucast (mem_read \<sigma> a 4)"
  apply (subst word_eq_iff)+
  using test_bit_mem_read[of \<sigma> a 4] assms
  by (auto simp add: word_size nth_ucast)

lemma ucast_ucast_mem_read_1byte[simp]:
assumes "LENGTH('a) > 8" and "LENGTH('b) > 8"
  shows "(ucast (ucast (mem_read \<sigma> a 1)::'a::len word) :: 'b::len word) = ucast (mem_read \<sigma> a 1)"
  apply (subst word_eq_iff)+
  using test_bit_mem_read[of \<sigma> a 1] assms
  apply (auto simp add: word_size nth_ucast)
  by (meson le_eq_less_or_eq le_less_trans)

lemma ucast_ucast_mem_read_2bytes[simp]:
assumes "LENGTH('a) > 16" and "LENGTH('b) > 16"
  shows "(ucast (ucast (mem_read \<sigma> a 2)::'a::len word) :: 'b::len word) = ucast (mem_read \<sigma> a 2)"
  apply (subst word_eq_iff)+
  using test_bit_mem_read[of \<sigma> a 2] assms
  apply (auto simp add: word_size nth_ucast)
  by (meson le_eq_less_or_eq le_less_trans)

lemma ucast_ucast_mem_read_4bytes[simp]:
assumes "LENGTH('a) > 32" and "LENGTH('b) > 32"
  shows "(ucast (ucast (mem_read \<sigma> a 4)::'a::len word) :: 'b::len word) = ucast (mem_read \<sigma> a 4)"
  apply (subst word_eq_iff)+
  using test_bit_mem_read[of \<sigma> a 4] assms
  apply (auto simp add: word_size nth_ucast)
  by (meson le_eq_less_or_eq le_less_trans)

lemma ucast_mem_read_cmp_8[simp]:
fixes \<sigma> :: state and b :: "'a::len word"
assumes "LENGTH('a) > 8"
  shows "(ucast (mem_read \<sigma> a 1)) = b \<longleftrightarrow> ucast (ucast (mem_read \<sigma> a 1)::8 word) = b"
  using test_bit_mem_read[of \<sigma> a 1] test_bit_size[of b]
  by (auto simp add: word_eq_iff word_size nth_ucast nth_takebits)

lemma ucast_mem_read_cmp_16[simp]:
fixes \<sigma> :: state and b :: "'a::len word"
assumes "LENGTH('a) > 16"
  shows "(ucast (mem_read \<sigma> a 2)) = b \<longleftrightarrow> ucast (ucast (mem_read \<sigma> a 2)::16 word) = b"
  using test_bit_mem_read[of \<sigma> a 2] test_bit_size[of b]
  by (auto simp add: word_eq_iff word_size nth_ucast nth_takebits)

lemma ucast_mem_read_cmp_32[simp]:
fixes \<sigma> :: state and b :: "'a::len word"
assumes "LENGTH('a) > 32"
  shows "(ucast (mem_read \<sigma> a 4)) = b \<longleftrightarrow> ucast (ucast (mem_read \<sigma> a 4)::32 word) = b"
  using test_bit_mem_read[of \<sigma> a 4] test_bit_size[of b]
  by (auto simp add: word_eq_iff word_size nth_ucast nth_takebits)

lemma ucast_overwrite[simp]:
  shows "ucast (overwrite 0 n a b) = overwrite 0 n (ucast a) (ucast b)"
  using test_bit_size[of a] test_bit_size[of b]
  by (auto simp add: word_eq_iff nth_ucast overwrite_def nth_shiftl nth_takebits word_size)

lemma takebits_overwrite[simp]:
  shows "(\<langle>0,h\<rangle> (overwrite 0 n a b)) = overwrite 0 n (\<langle>0,h\<rangle> a) (\<langle>0,h\<rangle> b)"
  using test_bit_size[of a] test_bit_size[of b]
  by (auto simp add: word_eq_iff nth_ucast overwrite_def nth_shiftl nth_takebits word_size)

lemma overwrite_overwrite_l[simp]:
  shows "overwrite 0 h (overwrite 0 h a b) c = overwrite 0 h a c"
  by (auto simp add: word_eq_iff nth_ucast overwrite_def nth_shiftl nth_takebits word_size)

lemma overwrite_overwrite_r[simp]:
  shows "overwrite 0 h a (overwrite 0 h b c) = overwrite 0 h a c"
  by (auto simp add: word_eq_iff nth_ucast overwrite_def nth_shiftl nth_takebits word_size)

lemma overwrite_all_8[simp]:
  fixes a :: "8 word"
  shows "overwrite 0 8 a b = b"
  by (auto simp add: word_eq_iff overwrite_def nth_shiftl nth_takebits)

lemma overwrite_all_16[simp]:
  fixes a :: "16 word"
  shows "overwrite 0 16 a b = b"
  by (auto simp add: word_eq_iff overwrite_def nth_shiftl nth_takebits)

lemma ucast_AND[simp]:
  shows "ucast (a AND b) = ucast a AND ucast b"
  by (auto simp add: word_eq_iff nth_ucast)

lemma ucast_OR[simp]:
  shows "ucast (a OR b) = ucast a OR ucast b"
  by (auto simp add: word_eq_iff nth_ucast)

lemma ucast_XOR[simp]:
  shows "ucast (a XOR b) = ucast a XOR ucast b"
  by (auto simp add: word_eq_iff nth_ucast)

lemma take_bits_AND[simp]:
  shows "(\<langle>l,h\<rangle> (a AND b)) = (\<langle>l,h\<rangle> a) AND (\<langle>l,h\<rangle> b)"
  by (auto simp add: word_eq_iff nth_ucast nth_takebits)

lemma take_bits_OR[simp]:
  shows "(\<langle>l,h\<rangle> (a OR b)) = (\<langle>l,h\<rangle> a) OR (\<langle>l,h\<rangle> b)"
  by (auto simp add: word_eq_iff nth_ucast nth_takebits)

lemma take_bits_XOR[simp]:
  shows "(\<langle>l,h\<rangle> (a XOR b)) = (\<langle>l,h\<rangle> a) XOR (\<langle>l,h\<rangle> b)"
  by (auto simp add: word_eq_iff nth_ucast nth_takebits)

lemma dummy:
  assumes "LENGTH('a) < 0" and "LENGTH('b) < 0"
  shows "(ucast (a::'a::len word) ::'b::len word) = x"
  using assms
  by auto

lemma dummy':
  assumes "LENGTH('a) < 0" and "LENGTH('b) < 0"
  shows "(scast (a::'a::len word) ::'b::len word) = x"
  using assms
  by auto

ML_file \<open>X86_Parse_Hoare_Triple.ML\<close>

ML \<open>
(*
  If thm is of the form (thm0 \<and> thm1), return the conjuncts.
*)
fun split_conj thm =
  case (Thm.prop_of thm) of
    (Const ("HOL.Trueprop", _) $ (Const ("HOL.conj", _) $ _ $ _)) => SOME (thm RS @{thm conjunct1} ,thm RS @{thm conjunct2})
  | _ => NONE;

(*
  conjs = thm0 \<and> thm1 \<and> ...
  Searches a conjunct equal to thm.
  If found, insert the found conjunct as assumption.
*)

fun insert_assumption_from_conjunct ctxt conjs thm =
  case split_conj conjs of
    NONE =>
      if Envir.aeconv (Thm.prop_of conjs,Thm.major_prem_of thm) then
        SOME (Method.insert_tac ctxt [conjs])
      else if Envir.aeconv (Thm.prop_of conjs,Thm.major_prem_of thm) then
        SOME (Method.insert_tac ctxt [conjs])
      else
        NONE
  | SOME (conj0,conj1) =>
      case insert_assumption_from_conjunct ctxt conj0 thm of
        NONE => insert_assumption_from_conjunct ctxt conj1 thm
      | SOME thm' => SOME thm'

fun from_conjunctive_assm_tactic assm ctxt i thm =
   if Thm.no_prems thm then
     Seq.single thm
   else case insert_assumption_from_conjunct ctxt assm thm of
        NONE => Seq.empty
      | SOME tac => Seq.maps (Seq.single o Thm.eq_assumption i) (tac i thm)

infix 1 DETERM_THEN AND_IF_NOT_SOLVED;

fun tac1 DETERM_THEN tac2 = fn thm =>
  let val result = tac1 thm
  in
    case Seq.pull result of
      NONE => Seq.empty
    | SOME (thm',_) => tac2 thm'
  end

fun tac1 AND_IF_NOT_SOLVED tac2 = fn thm =>
  let val result = tac1 thm
  in
    case Seq.pull result of
      NONE => tac2 thm
    | SOME (thm',_) => if Thm.nprems_of thm' < Thm.nprems_of thm then Seq.single thm' else tac2 thm'
  end

fun add_simps simp_theorems = fold Simplifier.add_simp simp_theorems

(*
  apply (subst mem_read_mem_write_separate)
  apply (from_conjunctive_assm conjI[OF seps asserts,simplified])
  apply (insert conjI[OF seps asserts,simplified])[1]
  apply (erule conjE)+
  apply (simp (no_asm_simp) add: state_simps BitByte_simps separate_simps)
  apply (simp only: algeba_simps_small)?
  apply (simp add: state_simps BitByte_simps separate_simps)
  apply (simp only: algeba_simps_small)?
*)
fun resolve_mem_read_tactic seps ctxt i =
  let val tac1 = CHANGED (EqSubst.eqsubst_tac ctxt [0] [@{thm mem_read_mem_write_separate}] i)
      val tac2 = HEADGOAL (from_conjunctive_assm_tactic seps ctxt)
      val tac3 = HEADGOAL (Method.insert_tac ctxt [seps])
      val tac4 = REPEAT_DETERM (HEADGOAL (eresolve_tac ctxt [@{thm conjE}]))
      val simp_theorems = @{thms state_simps BitByte_simps separate_simps}
      val ctxt' = add_simps simp_theorems ctxt
      val tac5 = HEADGOAL (asm_simp_tac ctxt')
      val ctxt_only_commutes = add_simps @{thms algebra_simps} (Raw_Simplifier.clear_simpset ctxt)
      val tac6 = HEADGOAL (full_simp_tac ctxt_only_commutes)
      val tac7 = HEADGOAL (asm_full_simp_tac ctxt')
      val tac8 = tac6
  in
    CHANGED (
      tac1 DETERM_THEN
        (  (DETERM tac2)
        ORELSE
           (tac3 DETERM_THEN tac4 DETERM_THEN (tac5 AND_IF_NOT_SOLVED tac6 AND_IF_NOT_SOLVED tac7 AND_IF_NOT_SOLVED tac8))
        )
    )
  end
\<close>
method_setup from_conjunctive_assm = \<open>
   Attrib.thm >> (fn (assm) => fn ctxt =>
     SIMPLE_METHOD' (fn i => fn thm =>
        if Thm.no_prems thm then
          Seq.single thm
        else case insert_assumption_from_conjunct ctxt assm thm of
             NONE => Seq.empty
           | SOME tac => Seq.maps (Seq.single o Thm.eq_assumption i) (tac i thm)
        ))
\<close>

method_setup resolve_mem_read = \<open>
   Attrib.thm >> (fn (assm) => fn ctxt =>
      SIMPLE_METHOD' (fn i => fn thm =>
        if Thm.no_prems thm then
          Seq.single thm
        else
          resolve_mem_read_tactic assm ctxt i thm
     ))
\<close>

method_setup eq_assumption = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (PRIMITIVE o Thm.eq_assumption))\<close>

ML \<open>
fun REPEAT_WHILE_CHANGING tac = fn thm =>
  let val result = (CHANGED tac) thm
  in
    case Seq.pull result of
      NONE => Seq.single thm
    | SOME (thm',_) => REPEAT_WHILE_CHANGING tac thm'
  end

fun REPEAT_WHILE_SOLVING tac = fn thm =>
  let val result = (CHANGED tac) thm
  in
    case Seq.pull result of
      NONE => Seq.single thm
    | SOME (thm',_) => if Thm.nprems_of thm' < Thm.nprems_of thm then REPEAT_WHILE_SOLVING tac thm' else Seq.single thm
  end

fun FAIL_IF_GENERATES_NEW_GOALS tac = fn thm =>
  let val result = (CHANGED tac) thm
  in
    case Seq.pull result of
      NONE => Seq.empty
    | SOME (thm',_) => if Thm.nprems_of thm' > Thm.nprems_of thm then Seq.empty else Seq.single thm'
  end
\<close>

method_setup repeat_while_changing = \<open>
  Method.text_closure >> (fn m => fn ctxt => fn _ =>
      CONTEXT_TACTIC (REPEAT_WHILE_CHANGING (NO_CONTEXT_TACTIC ctxt (Method.evaluate m ctxt []))))
\<close>

method_setup fail_if_generates_new_goals = \<open>
  Method.text_closure >> (fn m => fn ctxt => fn _ =>
    CONTEXT_TACTIC (FAIL_IF_GENERATES_NEW_GOALS (NO_CONTEXT_TACTIC ctxt (Method.evaluate m ctxt []))))
\<close>

method_setup repeat_while_solving = \<open>
  Method.text_closure >> (fn m => fn ctxt => fn _ =>
    CONTEXT_TACTIC (REPEAT_WHILE_SOLVING (NO_CONTEXT_TACTIC ctxt (Method.evaluate m ctxt []))))
\<close>

method se_step uses assms seps = (
  (insert assms)[1],
  (erule conjE)+,
  (  (simp (no_asm_use) add: state_simps BitByte_simps separate_simps)? ;
     (repeat_while_changing
         \<open>(simp only: algebra_simps)?,
          (simp (no_asm_simp) add: state_simps BitByte_simps separate_simps)?,
          (fail_if_generates_new_goals \<open>resolve_mem_read seps\<close>)?\<close>
     )
  )
 )

method htriple_solver uses seps assms = (
    (simp add: semantics_simps state_simps BitByte_simps separate_simps del: Let_def),
    (auto simp add: semantics_simps state_simps BitByte_simps separate_simps)?,
    (repeat_while_solving \<open>se_step assms: assms seps: seps\<close>)
 )

(*
  apply (simp add: semantics_simps state_simps BitByte_simps separate_simps del: Let_def)
  apply (auto simp add: semantics_simps state_simps BitByte_simps separate_simps)?
  apply (repeat_while_changing \<open>se_step assms: assms seps: conjI[OF seps asserts,simplified]\<close>)
  apply (se_step assms: assms seps: conjI[OF seps asserts,simplified])

  apply (insert assms)[1]
  apply (erule conjE)+
  apply (simp (no_asm_use) add: state_simps BitByte_simps separate_simps)
  (* repeat *)
  apply (simp only: algebra_simps)
  apply (simp (no_asm_simp) add: state_simps BitByte_simps separate_simps)
  apply (simp only: algebra_simps)
  apply (fail_if_generates_new_goals \<open>resolve_mem_read conjI[OF seps asserts,simplified]\<close>)

*)

end

abbreviation ucast\<^sub>3\<^sub>2\<^sub>_\<^sub>6\<^sub>4 :: "32 word \<Rightarrow> 64 word"
  where "ucast\<^sub>3\<^sub>2\<^sub>_\<^sub>6\<^sub>4 \<equiv> ucast"
abbreviation ucast\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2 :: "64 word \<Rightarrow> 32 word"
  where "ucast\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2 \<equiv> ucast"
abbreviation ucast\<^sub>1\<^sub>6\<^sub>_\<^sub>6\<^sub>4 :: "16 word \<Rightarrow> 64 word"
  where "ucast\<^sub>1\<^sub>6\<^sub>_\<^sub>6\<^sub>4 \<equiv> ucast"
abbreviation ucast\<^sub>6\<^sub>4\<^sub>_\<^sub>1\<^sub>6 :: "64 word \<Rightarrow> 16 word"
  where "ucast\<^sub>6\<^sub>4\<^sub>_\<^sub>1\<^sub>6 \<equiv> ucast"
abbreviation ucast\<^sub>8\<^sub>_\<^sub>6\<^sub>4 :: "8 word \<Rightarrow> 64 word"
  where "ucast\<^sub>8\<^sub>_\<^sub>6\<^sub>4 \<equiv> ucast"
abbreviation ucast\<^sub>6\<^sub>4\<^sub>_\<^sub>8 :: "64 word \<Rightarrow> 8 word"
  where "ucast\<^sub>6\<^sub>4\<^sub>_\<^sub>8 \<equiv> ucast"
abbreviation ucast\<^sub>3\<^sub>2\<^sub>_\<^sub>1\<^sub>6 :: "32 word \<Rightarrow> 16 word"
  where "ucast\<^sub>3\<^sub>2\<^sub>_\<^sub>1\<^sub>6 \<equiv> ucast"
abbreviation ucast\<^sub>8\<^sub>_\<^sub>3\<^sub>2 :: "8 word \<Rightarrow> 32 word"
  where "ucast\<^sub>8\<^sub>_\<^sub>3\<^sub>2 \<equiv> ucast"
abbreviation ucast\<^sub>3\<^sub>2\<^sub>_\<^sub>8 :: "32 word \<Rightarrow> 8 word"
  where "ucast\<^sub>3\<^sub>2\<^sub>_\<^sub>8 \<equiv> ucast"
abbreviation ucast\<^sub>1\<^sub>6\<^sub>_\<^sub>8 :: "16 word \<Rightarrow> 8 word"
  where "ucast\<^sub>1\<^sub>6\<^sub>_\<^sub>8 \<equiv> ucast"
abbreviation ucast\<^sub>8\<^sub>_\<^sub>1\<^sub>6 :: "8 word \<Rightarrow> 16 word"
  where "ucast\<^sub>8\<^sub>_\<^sub>1\<^sub>6 \<equiv> ucast"

end