theory Executions
imports IOA "~~/src/HOL/Library/Sublist"
begin

(* Author: Giuliano Losa. This theory is an adaptation of the one by Olaf Mueller found in
  Isabelle/HOLCF *)

context IOA begin

declare Let_def[simp]

definition proj_exec  ("_ \<downharpoonright> _ _") where
  "proj_exec e i sig \<equiv>
    (fst e i, map (\<lambda> p . (fst p, snd p i)) (filter (\<lambda> p . fst p \<in> actions sig) (snd e)))"

section "Composition is monotonic with respect to the implementation relation"

(*  Should also hold with the stuttering version of projection, would even be simpler *)
lemma last_state_proj:
  fixes fam i e
  assumes "i \<in> ids fam" and "is_exec_frag_of (par fam) e"
  shows "(last_state e) i = last_state (e \<downharpoonright> i (ioa.asig (memb fam i)))"
proof -
  have "is_exec_frag_of (par fam) e
        \<Longrightarrow> (last_state e) i = last_state (e \<downharpoonright> i (ioa.asig (memb fam i)))"
  proof (induction "snd e" arbitrary: e)
    case Nil show ?case
      by (simp add:proj_exec_def)
      (metis last_state.simps(1) Nil.hyps filter.simps(1) list.simps(8) prod.collapse)
  next
    case (Cons p ps e)
    from "Cons.prems" have 1:"is_exec_frag_of (par fam) (fst e, ps)"
      by (metis Cons.hyps(2) is_exec_frag_of.simps(1) is_exec_frag_of.simps(3) list.exhaust surjective_pairing)
    from 1 and "Cons.hyps"
      have 2:"(last_state (fst e, ps)) i = last_state ((fst e, ps) \<downharpoonright> i (ioa.asig (memb fam i)))"
        by simp
    show ?case
    proof (cases "fst p \<in> act (memb fam i)")
      case True
      hence "last_state (fst e, p#ps) i = last_state ((fst e, p#ps) \<downharpoonright> i (ioa.asig (memb fam i)))"
        by (simp add:proj_exec_def)
      with Cons.hyps(2) show ?thesis by simp
    next
      case False
      from False have 3: "((fst e, p#ps) \<downharpoonright> i (ioa.asig (memb fam i)))
                          = ((fst e, ps) \<downharpoonright> i (ioa.asig (memb fam i)))"
          by (simp add:proj_exec_def)
      from False and `i \<in> ids fam` and Cons.prems and Cons.hyps(2)
        have 4:"last_state (fst e, p#ps) i = last_state (fst e, ps) i"
          by  (cases "(par fam, fst e, snd e)" rule:is_exec_frag_of.cases)
              (auto simp add:is_trans_def par_def)
      from 2 3 4 Cons.hyps(2) show ?thesis by simp
    qed
  qed
  with assms(2) show ?thesis by simp
qed

lemma proj_execs:
  fixes fam i e
  assumes "is_exec_frag_of (par fam) e"
  and "i \<in> ids fam"
  defines sig_def:"sig \<equiv> ioa.asig (memb fam i)"
  and A_i_def:"A_i \<equiv> memb fam i"
  shows "is_exec_frag_of A_i (e \<downharpoonright> i sig)" (* Here we would have a problem with the stuttering version of projections *)
proof -
  have "is_exec_frag_of (par fam) e
        \<Longrightarrow> is_exec_frag_of A_i (e \<downharpoonright> i sig)"
  proof (induction "snd e" arbitrary:e)
    case Nil
    thus ?case by (simp add:proj_exec_def)
  next
    case (Cons p ps e)
    let ?e = "(fst e, p#ps)"
    let ?e' = "(fst e, ps)"
    thm Cons.hyps
    from Cons.prems and Cons.hyps(2) have prems:"is_exec_frag_of (par fam) ?e" by simp
    from Cons.hyps have ih:"is_exec_frag_of (par fam) ?e'
                          \<Longrightarrow> is_exec_frag_of A_i (?e' \<downharpoonright> i sig)" by simp
    from prems have 0:"is_exec_frag_of (par fam) ?e'" by (metis is_exec_frag_of.simps(1,3) list.exhaust)
    from 0 and ih have 1:"is_exec_frag_of A_i (?e' \<downharpoonright> i sig)" by auto
    have "is_exec_frag_of A_i (?e \<downharpoonright> i sig)"
    proof (cases "fst p \<in> act A_i")
      case False
      hence "(?e \<downharpoonright> i sig) = (?e' \<downharpoonright> i sig)" by (simp add:proj_exec_def sig_def A_i_def)
      with 1 show ?thesis by simp
    next
      case True
      from True and prems and `i \<in> ids fam`
        have 2:"(last_state ?e' i)\<midarrow>(fst p)\<midarrow>A_i\<longrightarrow>(snd p i)"
          by  (cases "(par fam, ?e')" rule:is_exec_frag_of.cases)
              (auto simp add:A_i_def is_trans_def par_def split: if_splits)
      from True have 3:"(?e \<downharpoonright> i sig) = cons_exec  (?e' \<downharpoonright> i sig) (fst p, snd p i)"
        by (simp add:proj_exec_def A_i_def sig_def cons_exec_def)
      from `i \<in> ids fam` and last_state_proj and 0
        have 4:"last_state ?e' i = last_state (?e' \<downharpoonright>i sig)" by (metis sig_def)
      from 1 2 3 4 and trans_from_last_state show ?thesis by fastforce
    qed
    thus ?case using Cons.hyps(2) by simp
  qed
  with assms(1) show ?thesis by simp
qed

(*  This one is trickier. In the HOLCF theory, projection on a component does not remove steps but
    instead results in suttering sequences. Stuttering sequences can be pasted easily. *)
lemma paste_execs:
  fixes fam and es and t::"'a trace"
  assumes "\<forall> i \<in> ids fam . is_exec_of (memb fam i) (es i)"
    and "\<forall> i \<in> ids fam . let sig_i = ioa.asig (memb fam i) in (t \<bar> sig_i) = trace sig_i (es i)"
  obtains e where "is_exec_of (par fam) e" and "trace (ioa.asig (par fam)) e = t"
    and "\<forall> i \<in> ids fam . (e \<downharpoonright> i (ioa.asig (memb fam i))) = es i" oops

end


theory METASINVAR_SystemBoundary
imports SINVAR_BLPtrusted_impl
        SINVAR_SubnetsInGW_impl
        "../TopoS_Composition_Theory_impl"
begin

subsubsection {* Meta SecurityInvariant: System Boundaries *}

datatype system_components = SystemComponent
                           | SystemBoundaryInput
                           | SystemBoundaryOutput
                           | SystemBoundaryInputOutput

fun system_components_to_subnets :: "system_components \<Rightarrow> subnets" where
  "system_components_to_subnets SystemComponent = Member" |
  "system_components_to_subnets SystemBoundaryInput = InboundGateway" |
  "system_components_to_subnets SystemBoundaryOutput = Member" |
  "system_components_to_subnets SystemBoundaryInputOutput = InboundGateway"

fun system_components_to_blp :: "system_components \<Rightarrow> SINVAR_BLPtrusted.node_config" where
  "system_components_to_blp SystemComponent = \<lparr> security_level = 1, trusted = False \<rparr>" |
  "system_components_to_blp SystemBoundaryInput = \<lparr> security_level = 1, trusted = False \<rparr>" |
  "system_components_to_blp SystemBoundaryOutput = \<lparr> security_level = 0, trusted = True \<rparr>" |
  "system_components_to_blp SystemBoundaryInputOutput = \<lparr> security_level = 0, trusted = True \<rparr>"

definition new_meta_system_boundary :: "('v::vertex \<times> system_components) list \<Rightarrow> string \<Rightarrow> ('v SecurityInvariant) list" where
  "new_meta_system_boundary C description = [
      new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = map_of (map (\<lambda>(v,c). (v, system_components_to_subnets c)) C)
          \<rparr> (description @ '' (ACS)'')
      ,
      new_configured_list_SecurityInvariant SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = map_of (map (\<lambda>(v,c). (v, system_components_to_blp c)) C)
          \<rparr> (description @ '' (IFS)'')
      ]"

lemma system_components_to_subnets:
      "SINVAR_SubnetsInGW.allowed_subnet_flow
        SINVAR_SubnetsInGW.default_node_properties
        (system_components_to_subnets c) \<longleftrightarrow>
       c = SystemBoundaryInput \<or> c = SystemBoundaryInputOutput"
by(cases c)(simp_all add: SINVAR_SubnetsInGW.default_node_properties_def)

lemma system_components_to_blp:
      "(\<not> trusted SINVAR_BLPtrusted.default_node_properties \<longrightarrow>
       security_level (system_components_to_blp c) \<le> security_level SINVAR_BLPtrusted.default_node_properties)
       \<longleftrightarrow>
       c = SystemBoundaryOutput \<or> c = SystemBoundaryInputOutput"
by(cases c)(simp_all add: SINVAR_BLPtrusted.default_node_properties_def)

lemma "all_security_requirements_fulfilled (new_meta_system_boundary C description) G \<longleftrightarrow>
       (\<forall>(v\<^sub>1, v\<^sub>2) \<in> set (edgesL G). case ((map_of C) v\<^sub>1, (map_of C) v\<^sub>2)
          of
          (*No restrictions outside of the component*)
             (None, None) \<Rightarrow> True

          (*no restrictions inside the component*)
          |  (Some c1, Some c2) \<Rightarrow> True

          (*System Boundaries Input*)
          |  (None, Some SystemBoundaryInputOutput) \<Rightarrow> True
          |  (None, Some SystemBoundaryInput) \<Rightarrow> True

          (*System Boundaries Output*)
          |  (Some SystemBoundaryOutput, None) \<Rightarrow> True
          |  (Some SystemBoundaryInputOutput, None) \<Rightarrow> True

          (*everything else is prohibited*)
          |  _ \<Rightarrow> False
       )"
apply(simp)
apply(simp add: new_meta_system_boundary_def)
apply(simp add: all_security_requirements_fulfilled_def)
apply(simp add: Let_def)
apply(simp add: SINVAR_LIB_SubnetsInGW_def SINVAR_LIB_BLPtrusted_def)
apply(simp add: SINVAR_SubnetsInGW_impl.NetModel_node_props_def SINVAR_BLPtrusted_impl.NetModel_node_props_def)
apply(rule iffI)
 apply(clarsimp)
 subgoal for a b
 apply(erule_tac x="(a,b)" in ballE)+
  apply(simp_all)
 apply(case_tac "map_of C a")
  apply(case_tac "map_of C b")
   apply(simp_all)
  apply(simp add: map_of_map)
  apply(simp split: system_components.split)
  apply(simp add: system_components_to_subnets)
  apply blast
 apply(case_tac "map_of C b")
  apply(simp add: map_of_map)
  apply(simp split: system_components.split)
  apply(simp add: system_components_to_blp)
  apply blast
 apply(simp add: map_of_map)
 apply(simp split: system_components.split; fail)
 done
apply(intro conjI)
 apply(simp add: map_of_map)
 apply(clarsimp)
 subgoal for a b
 apply(erule_tac x="(a,b)" in ballE)+
  apply(simp_all)
 apply(simp split: option.split_asm system_components.split_asm)
    by(simp_all add: SINVAR_SubnetsInGW.default_node_properties_def)
apply(clarsimp)
subgoal for a b
apply(erule_tac x="(a,b)" in ballE)+
 apply(simp_all)
apply(simp add: map_of_map)
apply(simp split: option.split_asm system_components.split_asm)
  apply(simp add: SINVAR_BLPtrusted.default_node_properties_def; fail)
 apply(rename_tac x, case_tac x, simp_all)+
done
done

value[code] "let nodes = [1,2,3,4,8,9,10];
           sinvars = new_meta_system_boundary
              [(1::int, SystemBoundaryInput),
               (2, SystemComponent),
               (3, SystemBoundaryOutput),
               (4, SystemBoundaryInputOutput)
               ] ''foobar''
       in generate_valid_topology sinvars \<lparr>nodesL = nodes, edgesL = List.product nodes nodes \<rparr>"

end


(*  Title:      HOL/MicroJava/BV/LBVComplete.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

header {* \isaheader{Completeness of the LBV} *}

theory LBVComplete
imports LBVSpec Typing_Framework
begin

definition is_target :: "'s step_type \<Rightarrow> 's list \<Rightarrow> nat \<Rightarrow> bool" where
  "is_target step \<tau>s pc' \<longleftrightarrow> (\<exists>pc s'. pc' \<noteq> pc+1 \<and> pc < size \<tau>s \<and> (pc',s') \<in> set (step pc (\<tau>s!pc)))"

definition make_cert :: "'s step_type \<Rightarrow> 's list \<Rightarrow> 's \<Rightarrow> 's certificate" where
  "make_cert step \<tau>s B = map (\<lambda>pc. if is_target step \<tau>s pc then \<tau>s!pc else B) [0..<size \<tau>s] @ [B]"

locale lbvc = lbv +
  fixes \<tau>s :: "'a list"
  fixes c :: "'a list"
  defines cert_def: "c \<equiv> make_cert step \<tau>s \<bottom>"

  assumes mono: "mono r step (size \<tau>s) A"
  assumes pres: "pres_type step (size \<tau>s) A"
  assumes \<tau>s:  "\<forall>pc < size \<tau>s. \<tau>s!pc \<in> A \<and> \<tau>s!pc \<noteq> \<top>"
  assumes bounded: "bounded step (size \<tau>s)"

  assumes B_neq_T: "\<bottom> \<noteq> \<top>"

lemma (in lbvc) cert: "cert_ok c (size \<tau>s) \<top> \<bottom> A"
(*<*)
proof (unfold cert_ok_def, intro strip conjI)
  note [simp] = make_cert_def cert_def nth_append

  show "c!size \<tau>s = \<bottom>" by simp

  fix pc assume pc: "pc < size \<tau>s"
  from pc \<tau>s B_A show "c!pc \<in> A" by simp
  from pc \<tau>s B_neq_T show "c!pc \<noteq> \<top>" by simp
qed
(*>*)

lemmas [simp del] = split_paired_Ex

lemma (in lbvc) cert_target [intro?]:
  "\<lbrakk> (pc',s') \<in> set (step pc (\<tau>s!pc));
      pc' \<noteq> pc+1; pc < size \<tau>s; pc' < size \<tau>s \<rbrakk>
  \<Longrightarrow> c!pc' = \<tau>s!pc'"
(*<*) by (auto simp add: cert_def make_cert_def nth_append is_target_def) (*>*)

lemma (in lbvc) cert_approx [intro?]:
  "\<lbrakk> pc < size \<tau>s; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> c!pc = \<tau>s!pc"
(*<*) by (auto simp add: cert_def make_cert_def nth_append) (*>*)

lemma (in lbv) le_top [simp, intro]: "x <=_r \<top>"
(*<*) by (insert top) simp (*>*)

lemma (in lbv) merge_mono:
  assumes less:  "set ss\<^sub>2 {\<sqsubseteq>\<^bsub>r\<^esub>} set ss\<^sub>1"
  assumes x:     "x \<in> A"
  assumes ss\<^sub>1:   "snd`set ss\<^sub>1 \<subseteq> A"
  assumes ss\<^sub>2:   "snd`set ss\<^sub>2 \<subseteq> A"
  shows "merge c pc ss\<^sub>2 x \<sqsubseteq>\<^sub>r merge c pc ss\<^sub>1 x" (is "?s\<^sub>2 \<sqsubseteq>\<^sub>r ?s\<^sub>1")
(*<*)
proof-
  have "?s\<^sub>1 = \<top> \<Longrightarrow> ?thesis" by simp
  moreover {
    assume merge: "?s\<^sub>1 \<noteq> T"
    from x ss\<^sub>1 have "?s\<^sub>1 =
      (if \<forall>(pc',s')\<in>set ss\<^sub>1. pc' \<noteq> pc + 1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'
      then (map snd [(p', t') \<leftarrow> ss\<^sub>1 . p'=pc+1]) \<Squnion>\<^bsub>f\<^esub> x
      else \<top>)" by (rule merge_def)
    with merge obtain
      app: "\<forall>(pc',s')\<in>set ss\<^sub>1. pc' \<noteq> pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'"
           (is "?app ss\<^sub>1") and
      sum: "(map snd [(p',t') \<leftarrow> ss\<^sub>1 . p' = pc+1] \<Squnion>\<^bsub>f\<^esub> x) = ?s\<^sub>1"
           (is "?map ss\<^sub>1 \<Squnion>\<^bsub>f\<^esub> x = _" is "?sum ss\<^sub>1 = _")
      by (simp split: split_if_asm)
    from app less have "?app ss\<^sub>2" by (blast dest: trans_r lesub_step_typeD)
    moreover {
      from ss\<^sub>1 have map1: "set (?map ss\<^sub>1) \<subseteq> A" by auto
      with x and semilat Semilat_axioms have "?sum ss\<^sub>1 \<in> A" by (auto intro!: plusplus_closed)
      with sum have "?s\<^sub>1 \<in> A" by simp
      moreover
      have mapD: "\<And>x ss. x \<in> set (?map ss) \<Longrightarrow> \<exists>p. (p,x) \<in> set ss \<and> p=pc+1" by auto
      from x map1 have "\<forall>x \<in> set (?map ss\<^sub>1). x \<sqsubseteq>\<^sub>r ?sum ss\<^sub>1" by clarify (rule pp_ub1)
      with sum have "\<forall>x \<in> set (?map ss\<^sub>1). x \<sqsubseteq>\<^sub>r ?s\<^sub>1" by simp
      with less have "\<forall>x \<in> set (?map ss\<^sub>2). x \<sqsubseteq>\<^sub>r ?s\<^sub>1"
        by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
      moreover from map1 x have "x \<sqsubseteq>\<^sub>r (?sum ss\<^sub>1)" by (rule pp_ub2)
      with sum have "x \<sqsubseteq>\<^sub>r ?s\<^sub>1" by simp
      moreover from ss\<^sub>2 have "set (?map ss\<^sub>2) \<subseteq> A" by auto
      ultimately  have "?sum ss\<^sub>2 \<sqsubseteq>\<^sub>r ?s\<^sub>1" using x by - (rule pp_lub)
    }
    moreover from x ss\<^sub>2 have "?s\<^sub>2 =
      (if \<forall>(pc', s')\<in>set ss\<^sub>2. pc' \<noteq> pc + 1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'
      then map snd [(p', t') \<leftarrow> ss\<^sub>2 . p' = pc + 1] \<Squnion>\<^bsub>f\<^esub> x
      else \<top>)" by (rule merge_def)
    ultimately have ?thesis by simp
  }
  ultimately show ?thesis by (cases "?s\<^sub>1 = \<top>") auto
qed
(*>*)

lemma (in lbvc) wti_mono:
  assumes less: "s\<^sub>2 \<sqsubseteq>\<^sub>r s\<^sub>1"
  assumes pc: "pc < size \<tau>s" and s\<^sub>1: "s\<^sub>1 \<in> A" and s\<^sub>2: "s\<^sub>2 \<in> A"
  shows "wti c pc s\<^sub>2 \<sqsubseteq>\<^sub>r wti c pc s\<^sub>1" (is "?s\<^sub>2' \<sqsubseteq>\<^sub>r ?s\<^sub>1'")
(*<*)
proof -
  from mono pc s\<^sub>2 less have "set (step pc s\<^sub>2) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step pc s\<^sub>1)" by (rule monoD)
  moreover from cert B_A pc have "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover from pres s\<^sub>1 pc have "snd`set (step pc s\<^sub>1) \<subseteq> A" by (rule pres_typeD2)
  moreover from pres s\<^sub>2 pc have "snd`set (step pc s\<^sub>2) \<subseteq> A" by (rule pres_typeD2)
  ultimately show ?thesis by (simp add: wti merge_mono)
qed
(*>*)

lemma (in lbvc) wtc_mono:
  assumes less: "s\<^sub>2 \<sqsubseteq>\<^sub>r s\<^sub>1"
  assumes pc: "pc < size \<tau>s" and s\<^sub>1: "s\<^sub>1 \<in> A" and s\<^sub>2: "s\<^sub>2 \<in> A"
  shows "wtc c pc s\<^sub>2 \<sqsubseteq>\<^sub>r wtc c pc s\<^sub>1" (is "?s\<^sub>2' \<sqsubseteq>\<^sub>r ?s\<^sub>1'")
(*<*)
proof (cases "c!pc = \<bottom>")
  case True
  moreover from less pc s\<^sub>1 s\<^sub>2 have "wti c pc s\<^sub>2 \<sqsubseteq>\<^sub>r wti c pc s\<^sub>1" by (rule wti_mono)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  have "?s\<^sub>1' = \<top> \<Longrightarrow> ?thesis" by simp
  moreover {
    assume "?s\<^sub>1' \<noteq> \<top>"
    with False have c: "s\<^sub>1 \<sqsubseteq>\<^sub>r c!pc" by (simp add: wtc split: split_if_asm)
    with less have "s\<^sub>2 \<sqsubseteq>\<^sub>r c!pc" ..
    with False c have ?thesis by (simp add: wtc)
  }
  ultimately show ?thesis by (cases "?s\<^sub>1' = \<top>") auto
qed
(*>*)

lemma (in lbv) top_le_conv [simp]: "\<top> \<sqsubseteq>\<^sub>r x = (x = \<top>)"
(*<*) by (insert semilat) (simp add: top top_le_conv)  (*>*)

lemma (in lbv) neq_top [simp, elim]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<noteq> \<top> \<rbrakk> \<Longrightarrow> x \<noteq> \<top>"
(*<*) by (cases "x = T") auto (*>*)

lemma (in lbvc) stable_wti:
  assumes stable:  "stable r step \<tau>s pc" and pc: "pc < size \<tau>s"
  shows "wti c pc (\<tau>s!pc) \<noteq> \<top>"
(*<*)
proof -
  let ?step = "step pc (\<tau>s!pc)"
  from stable
  have less: "\<forall>(q,s')\<in>set ?step. s' \<sqsubseteq>\<^sub>r \<tau>s!q" by (simp add: stable_def)

  from cert B_A pc have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover from \<tau>s pc have "\<tau>s!pc \<in> A" by simp
  with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    (if \<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'
    then map snd [(p',t') \<leftarrow> ?step.p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!Suc pc
    else \<top>)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
  moreover {
    fix pc' s' assume s': "(pc',s') \<in> set ?step" and suc_pc: "pc' \<noteq> pc+1"
    with less have "s' \<sqsubseteq>\<^sub>r \<tau>s!pc'" by auto
    also from bounded pc s' have "pc' < size \<tau>s" by (rule boundedD)
    with s' suc_pc pc have "c!pc' = \<tau>s!pc'" ..
    hence "\<tau>s!pc' = c!pc'" ..
    finally have "s' \<sqsubseteq>\<^sub>r c!pc'" .
  } hence "\<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'" by auto
  moreover from pc have "Suc pc = size \<tau>s \<or> Suc pc < size \<tau>s" by auto
  hence "map snd [(p',t') \<leftarrow> ?step.p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!Suc pc \<noteq> \<top>" (is "?map \<Squnion>\<^bsub>f\<^esub> _ \<noteq> _")
  proof (rule disjE)
    assume pc': "Suc pc = size \<tau>s"
    with cert have "c!Suc pc = \<bottom>" by (simp add: cert_okD2)
    moreover
    from pc' bounded pc
    have "\<forall>(p',t')\<in>set ?step. p'\<noteq>pc+1" by clarify (drule boundedD, auto)
    hence "[(p',t') \<leftarrow> ?step. p'=pc+1] = []" by (blast intro: filter_False)
    hence "?map = []" by simp
    ultimately show ?thesis by (simp add: B_neq_T)
  next
    assume pc': "Suc pc < size \<tau>s"
    from pc' \<tau>s have "\<tau>s!Suc pc \<in> A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map \<subseteq> A" by auto
    moreover have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
    with less have "\<forall>s' \<in> set ?map. s' \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by auto
    moreover from pc' have "c!Suc pc \<sqsubseteq>\<^sub>r \<tau>s!Suc pc"
      by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
    ultimately have "?map \<Squnion>\<^bsub>f\<^esub> c!Suc pc \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule pp_lub)
    moreover from pc' \<tau>s have "\<tau>s!Suc pc \<noteq> \<top>" by simp
    ultimately show ?thesis by auto
  qed
  ultimately have "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by simp
  thus ?thesis by (simp add: wti)
qed
(*>*)

lemma (in lbvc) wti_less:
  assumes stable: "stable r step \<tau>s pc" and suc_pc: "Suc pc < size \<tau>s"
  shows "wti c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" (is "?wti \<sqsubseteq>\<^sub>r _")
(*<*)
proof -
  let ?step = "step pc (\<tau>s!pc)"

  from stable
  have less: "\<forall>(q,s')\<in>set ?step. s' \<sqsubseteq>\<^sub>r \<tau>s!q" by (simp add: stable_def)

  from suc_pc have pc: "pc < size \<tau>s" by simp
  with cert B_A have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover from \<tau>s pc have "\<tau>s!pc \<in> A" by simp
  with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
  moreover from stable pc have "?wti \<noteq> \<top>" by (rule stable_wti)
  hence "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by (simp add: wti)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    map snd [(p',t') \<leftarrow> ?step.p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!Suc pc" by (rule merge_not_top_s)
  hence "?wti = \<dots>" (is "_ = (?map \<Squnion>\<^bsub>f\<^esub> _)" is "_ = ?sum") by (simp add: wti)
  also {
    from suc_pc \<tau>s have "\<tau>s!Suc pc \<in> A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map \<subseteq> A" by auto
    moreover have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
    with less have "\<forall>s' \<in> set ?map. s' \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by auto
    moreover from suc_pc have "c!Suc pc \<sqsubseteq>\<^sub>r \<tau>s!Suc pc"
      by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
    ultimately have "?sum \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule pp_lub)
  }
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) stable_wtc:
  assumes stable: "stable r step \<tau>s pc" and pc: "pc < size \<tau>s"
  shows "wtc c pc (\<tau>s!pc) \<noteq> \<top>"
(*<*)
proof -
  from stable pc have wti: "wti c pc (\<tau>s!pc) \<noteq> \<top>" by (rule stable_wti)
  show ?thesis
  proof (cases "c!pc = \<bottom>")
    case True with wti show ?thesis by (simp add: wtc)
  next
    case False
    with pc have "c!pc = \<tau>s!pc" ..
    with False wti show ?thesis by (simp add: wtc)
  qed
qed
(*>*)

lemma (in lbvc) wtc_less:
  assumes stable: "stable r step \<tau>s pc" and suc_pc: "Suc pc < size \<tau>s"
  shows "wtc c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" (is "?wtc \<sqsubseteq>\<^sub>r _")
(*<*)
proof (cases "c!pc = \<bottom>")
  case True
  moreover from stable suc_pc have "wti c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule wti_less)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  from suc_pc have pc: "pc < size \<tau>s" by simp
  with stable have "?wtc \<noteq> \<top>" by (rule stable_wtc)
  with False have "?wtc = wti c pc (c!pc)"
    by (unfold wtc) (simp split: split_if_asm)
  also from pc False have "c!pc = \<tau>s!pc" ..
  finally have "?wtc = wti c pc (\<tau>s!pc)" .
  also from stable suc_pc have "wti c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule wti_less)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) wt_step_wtl_lemma:
  assumes wt_step: "wt_step r \<top> step \<tau>s"
  shows "\<And>pc s. pc+size ls = size \<tau>s \<Longrightarrow> s \<sqsubseteq>\<^sub>r \<tau>s!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
                wtl ls c pc s \<noteq> \<top>"
  (is "\<And>pc s. _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> ?wtl ls pc s \<noteq> _")
(*<*)
proof (induct ls)
  fix pc s assume "s\<noteq>\<top>" thus "?wtl [] pc s \<noteq> \<top>" by simp
next
  fix pc s i ls
  assume "\<And>pc s. pc+size ls=size \<tau>s \<Longrightarrow> s \<sqsubseteq>\<^sub>r \<tau>s!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
                  ?wtl ls pc s \<noteq> \<top>"
  moreover
  assume pc_l: "pc + size (i#ls) = size \<tau>s"
  hence suc_pc_l: "Suc pc + size ls = size \<tau>s" by simp
  ultimately
  have IH: "\<And>s. s \<sqsubseteq>\<^sub>r \<tau>s!Suc pc \<Longrightarrow> s \<in> A \<Longrightarrow> s \<noteq> \<top> \<Longrightarrow> ?wtl ls (Suc pc) s \<noteq> \<top>" .

  from pc_l obtain pc: "pc < size \<tau>s" by simp
  with wt_step have stable: "stable r step \<tau>s pc" by (simp add: wt_step_def)
  moreover note pc
  ultimately have wt_\<tau>s: "wtc c pc (\<tau>s!pc) \<noteq> \<top>" by (rule stable_wtc)

  assume s_\<tau>s: "s \<sqsubseteq>\<^sub>r \<tau>s!pc"
  assume sA: "s \<in> A"
  from \<tau>s pc have \<tau>s_pc: "\<tau>s!pc \<in> A" by simp
  from s_\<tau>s pc \<tau>s_pc sA have wt_s_\<tau>s: "wtc c pc s \<sqsubseteq>\<^sub>r wtc c pc (\<tau>s!pc)" by (rule wtc_mono)
  with wt_\<tau>s have wt_s: "wtc c pc s \<noteq> \<top>" by simp
  moreover assume s: "s \<noteq> \<top>"
  ultimately have "ls = [] \<Longrightarrow> ?wtl (i#ls) pc s \<noteq> \<top>" by simp
  moreover {
    assume "ls \<noteq> []"
    with pc_l have suc_pc: "Suc pc < size \<tau>s" by (auto simp add: neq_Nil_conv)
    with stable have "wtc c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule wtc_less)
    with wt_s_\<tau>s have "wtc c pc s \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule trans_r)
    moreover from cert suc_pc have "c!pc \<in> A" "c!(pc+1) \<in> A"
      by (auto simp add: cert_ok_def)
    from pres this sA pc have "wtc c pc s \<in> A" by (rule wtc_pres)
    ultimately have "?wtl ls (Suc pc) (wtc c pc s) \<noteq> \<top>" using IH wt_s by blast
    with s wt_s have "?wtl (i#ls) pc s \<noteq> \<top>" by simp
  }
  ultimately show "?wtl (i#ls) pc s \<noteq> \<top>" by (cases ls) blast+
qed
(*>*)

theorem (in lbvc) wtl_complete:
  assumes wt: "wt_step r \<top> step \<tau>s"
  assumes s: "s \<sqsubseteq>\<^sub>r \<tau>s!0" "s \<in> A" "s \<noteq> \<top>" and eq: "size ins = size \<tau>s"
  shows "wtl ins c 0 s \<noteq> \<top>"
(*<*)
proof -
  from eq have "0+size ins = size \<tau>s" by simp
  from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed
(*>*)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
section \<open>Abstract Matching\<close>

theory Abstract_Matching
  imports
    Term_Pair_Multiset
    "Abstract-Rewriting.Abstract_Rewriting"
begin

(*FIXME: move(?)*)
lemma singleton_eq_union_iff [iff]:
  "{#x#} = M + {#y#} \<longleftrightarrow> M = {#} \<and> x = y"
  by (metis multi_self_add_other_not_self single_eq_single single_is_union)

text \<open>Turning functional maps into substitutions.\<close>
definition "subst_of_map d \<sigma> x =
  (case \<sigma> x of
    None \<Rightarrow> d x
  | Some t \<Rightarrow> t)"

definition matchers :: "(('f, 'v) term \<times> ('f, 'w) term) set \<Rightarrow> ('f, 'v, 'w) gsubst set"
  where
    "matchers P = {\<sigma>. \<forall>e\<in>P. fst e \<cdot> \<sigma> = snd e}"

lemma matchers_vars_term_eq:
  assumes "\<sigma> \<in> matchers P" and "\<tau> \<in> matchers P"
    and "(s, t) \<in> P"
  shows "\<forall>x\<in>vars_term s. \<sigma> x = \<tau> x"
  using assms unfolding term_subst_eq_conv [symmetric] by (force simp: matchers_def)

lemma matchers_empty [simp]:
  "matchers {} = UNIV"
  by (simp add: matchers_def)

lemma matchers_insert [simp]:
  "matchers (insert e P) = {\<sigma>. fst e \<cdot> \<sigma> = snd e} \<inter> matchers P"
  by (auto simp: matchers_def)

lemma matchers_Un [simp]:
  "matchers (P \<union> P') = matchers P \<inter> matchers P'"
  by (auto simp: matchers_def)

lemma matchers_set_zip [simp]:
  assumes "length ss = length ts"
  shows "matchers (set (zip ss ts)) = {\<sigma>. map (\<lambda>t. t \<cdot> \<sigma>) ss = ts}"
  using assms by (induct ss ts rule: list_induct2) auto

definition "matchers_map m = matchers ((\<lambda>x. (Var x, the (m x))) ` Map.dom m)"

lemma matchers_map_empty [simp]:
  "matchers_map Map.empty = UNIV"
  by (simp add: matchers_map_def)

lemma matchers_map_upd [simp]:
  assumes "\<sigma> x = None \<or> \<sigma> x = Some t"
  shows "matchers_map (\<lambda>y. if y = x then Some t else \<sigma> y) =
    matchers_map \<sigma> \<inter> {\<tau>. \<tau> x = t}" (is "?L = ?R")
proof
  show "?L \<supseteq> ?R" by (auto simp: matchers_map_def matchers_def)
next
  show "?L \<subseteq> ?R"
    by (rule subsetI)
       (insert assms, auto simp: matchers_map_def matchers_def dom_def)
qed

lemma matchers_map_upd' [simp]:
  assumes "\<sigma> x = None \<or> \<sigma> x = Some t"
  shows "matchers_map (\<sigma> (x \<mapsto> t)) = matchers_map \<sigma> \<inter> {\<tau>. \<tau> x = t}"
  using matchers_map_upd [of \<sigma> x t, OF assms]
  by (simp add: matchers_map_def matchers_def dom_def)

inductive MATCH1 where
  Var [intro!, simp]: "\<sigma> x = None \<or> \<sigma> x = Some t \<Longrightarrow>
    MATCH1 (P + {#(Var x, t)#}, \<sigma>) (P, \<sigma> (x \<mapsto> t))" |
  Fun [intro]: "length ss = length ts \<Longrightarrow>
    MATCH1 (P + {#(Fun f ss, Fun f ts)#}, \<sigma>) (P + mset (zip ss ts), \<sigma>)"

lemma MATCH1_matchers [simp]:
  assumes "MATCH1 x y"
  shows "matchers_map (snd x) \<inter> matchers (set_mset (fst x)) =
    matchers_map (snd y) \<inter> matchers (set_mset (fst y))"
  using assms by (induct) (simp_all add: ac_simps)

definition "matchrel = {(x, y). MATCH1 x y}"

lemma MATCH1_matchrel_conv:
  "MATCH1 x y \<longleftrightarrow> (x, y) \<in> matchrel"
  by (simp add: matchrel_def)

lemma matchrel_rtrancl_matchers [simp]:
  assumes "(x, y) \<in> matchrel\<^sup>*"
  shows "matchers_map (snd x) \<inter> matchers (set_mset (fst x)) =
    matchers_map (snd y) \<inter> matchers (set_mset (fst y))"
  using assms by (induct) (simp_all add: matchrel_def)

lemma subst_of_map_in_matchers_map [simp]:
  "subst_of_map d m \<in> matchers_map m"
  by (auto simp: subst_of_map_def [abs_def] matchers_map_def matchers_def)

lemma matchrel_sound:
  assumes "((P, Map.empty), ({#}, \<sigma>)) \<in> matchrel\<^sup>*"
  shows "subst_of_map d \<sigma> \<in> matchers (set_mset P)"
  using matchrel_rtrancl_matchers [OF assms] by simp

lemma MATCH1_size_mset:
  assumes "MATCH1 x y"
  shows "size_mset (fst x) > size_mset (fst y)"
  using assms by (cases) (auto simp: pair_size_def)+

definition "matchless = inv_image (measure size_mset) fst"

lemma wf_matchless:
  "wf matchless"
  by (auto simp: matchless_def)

lemma MATCH1_matchless:
  assumes "MATCH1 x y"
  shows "(y, x) \<in> matchless"
  using MATCH1_size_mset [OF assms]
  by (simp add: matchless_def)

lemma converse_matchrel_subset_matchless:
  "matchrel\<inverse> \<subseteq> matchless"
  using MATCH1_matchless by (auto simp: matchrel_def)

lemma wf_converse_matchrel:
  "wf (matchrel\<inverse>)"
  by (rule wf_subset [OF wf_matchless converse_matchrel_subset_matchless])

lemma MATCH1_singleton_Var [intro]:
  "\<sigma> x = None \<Longrightarrow> MATCH1 ({#(Var x, t)#}, \<sigma>) ({#}, \<sigma> (x \<mapsto> t))"
  "\<sigma> x = Some t \<Longrightarrow> MATCH1 ({#(Var x, t)#}, \<sigma>) ({#}, \<sigma> (x \<mapsto> t))"
  using MATCH1.Var [of \<sigma> x t "{#}"] by simp_all

lemma MATCH1_singleton_Fun [intro]:
  "length ss = length ts \<Longrightarrow> MATCH1 ({#(Fun f ss, Fun f ts)#}, \<sigma>) (mset (zip ss ts), \<sigma>)"
  using MATCH1.Fun [of ss ts "{#}" f \<sigma>] by simp

lemma not_MATCH1_singleton_Var [dest]:
  "\<not> MATCH1 ({#(Var x, t)#}, \<sigma>) ({#}, \<sigma> (x \<mapsto> t)) \<Longrightarrow> \<sigma> x \<noteq> None \<and> \<sigma> x \<noteq> Some t"
  by auto

lemma not_matchrelD:
  assumes "\<not> (\<exists>y. (({#e#}, \<sigma>), y) \<in> matchrel)"
  shows "(\<exists>f ss x. e = (Fun f ss, Var x)) \<or>
    (\<exists>x t. e = (Var x, t) \<and> \<sigma> x \<noteq> None \<and> \<sigma> x \<noteq> Some t) \<or>
    (\<exists>f g ss ts. e = (Fun f ss, Fun g ts) \<and> (f \<noteq> g \<or> length ss \<noteq> length ts))"
proof (rule ccontr)
  assume *: "\<not> ?thesis"
  show False
  proof (cases e)
    case (Pair s t)
    with assms and * show ?thesis
      by (cases s) (cases t, auto simp: matchrel_def)+
  qed
qed

lemma ne_matchers_imp_matchrel:
  assumes "matchers_map \<sigma> \<inter> matchers {e} \<noteq> {}"
  shows "\<exists>y. (({#e#}, \<sigma>), y) \<in> matchrel"
proof (rule ccontr)
  assume "\<not> ?thesis"
  from not_matchrelD [OF this] and assms
    show False by (auto simp: matchers_map_def matchers_def dom_def)
qed

lemma MATCH1_mono:
  assumes "MATCH1 (P, \<sigma>) (P', \<sigma>')"
  shows "MATCH1 (P + M, \<sigma>) (P' + M, \<sigma>')"
  using assms apply (cases) apply (auto simp: ac_simps)
  using Var apply force
  using Var apply force
  using Fun
  by (metis (no_types, lifting) add.assoc add_mset_add_single)

lemma matchrel_mono:
  assumes "(x, y) \<in> matchrel"
  shows "((fst x + M, snd x), (fst y + M, snd y)) \<in> matchrel"
  using assms and MATCH1_mono [of "fst x"]
  by (simp add: MATCH1_matchrel_conv)

lemma matchrel_rtrancl_mono:
  assumes "(x, y) \<in> matchrel\<^sup>*"
  shows "((fst x + M, snd x), (fst y + M, snd y)) \<in> matchrel\<^sup>*"
  using assms by (induct) (auto dest:  matchrel_mono [of _ _ M])

lemma ne_matchers_imp_empty_or_matchrel:
  assumes "matchers_map \<sigma> \<inter> matchers (set_mset P) \<noteq> {}"
  shows "P = {#} \<or> (\<exists>y. ((P, \<sigma>), y) \<in> matchrel)"
proof (cases P)
  case (add e P')
  then have [simp]: "P = P' + {#e#}" by simp
  from assms have "matchers_map \<sigma> \<inter> matchers {e} \<noteq> {}" by auto
  from ne_matchers_imp_matchrel [OF this]
    obtain P'' \<sigma>' where "MATCH1 ({#e#}, \<sigma>) (P'', \<sigma>')"
    by (auto simp: matchrel_def)
  from MATCH1_mono [OF this, of P'] have "MATCH1 (P, \<sigma>) (P' + P'', \<sigma>')" by (simp add: ac_simps)
  then show ?thesis by (auto simp: matchrel_def)
qed simp

lemma matchrel_imp_converse_matchless [dest]:
  "(x, y) \<in> matchrel \<Longrightarrow> (y, x) \<in> matchless"
  using MATCH1_matchless by (cases x, cases y) (auto simp: matchrel_def)

lemma ne_matchers_imp_empty:
  fixes P :: "(('f, 'v) term \<times> ('f, 'w) term) multiset"
  assumes "matchers_map \<sigma> \<inter> matchers (set_mset P) \<noteq> {}"
  shows "\<exists>\<sigma>'. ((P, \<sigma>), ({#}, \<sigma>')) \<in> matchrel\<^sup>*"
using assms
proof (induct P arbitrary: \<sigma> rule: wf_induct [OF wf_measure [of size_mset]])
  fix P :: "(('f, 'v) term \<times> ('f, 'w) term) multiset"
    and \<sigma>
  presume IH: "\<And>P' \<sigma>. \<lbrakk>(P', P) \<in> measure size_mset; matchers_map \<sigma> \<inter> matchers (set_mset P') \<noteq> {}\<rbrakk> \<Longrightarrow>
    \<exists>\<sigma>'. ((P', \<sigma>), {#}, \<sigma>') \<in> matchrel\<^sup>*"
    and *: "matchers_map \<sigma> \<inter> matchers (set_mset P) \<noteq> {}"
  show "\<exists>\<sigma>'. ((P, \<sigma>), {#}, \<sigma>') \<in> matchrel\<^sup>*"
  proof (cases "P = {#}")
    assume "P \<noteq> {#}"
    with ne_matchers_imp_empty_or_matchrel [OF *]
      obtain P' \<sigma>' where **: "((P, \<sigma>), (P', \<sigma>')) \<in> matchrel" by (auto)
    with * have "(P', P) \<in> measure size_mset"
      and "matchers_map \<sigma>' \<inter> matchers (set_mset P') \<noteq> {}"
      using MATCH1_matchers [of "(P, \<sigma>)" "(P', \<sigma>')"]
      by (auto simp: matchrel_def dest: MATCH1_size_mset)
    from IH [OF this] and **
      show ?thesis by (auto intro: converse_rtrancl_into_rtrancl)
  qed force
qed simp

lemma empty_not_reachable_imp_matchers_empty:
  assumes "\<And>\<sigma>'. ((P, \<sigma>), ({#}, \<sigma>')) \<notin> matchrel\<^sup>*"
  shows "matchers_map \<sigma> \<inter> matchers (set_mset P) = {}"
  using ne_matchers_imp_empty [of \<sigma> P] and assms by blast

lemma irreducible_reachable_imp_matchers_empty:
  assumes "((P, \<sigma>), y) \<in> matchrel\<^sup>!" and "fst y \<noteq> {#}"
  shows "matchers_map \<sigma> \<inter> matchers (set_mset P) = {}"
proof -
  have "((P, \<sigma>), y) \<in> matchrel\<^sup>*"
    and "\<And>\<tau>. (y, ({#}, \<tau>)) \<notin> matchrel\<^sup>*"
    using assms by  auto (metis NF_not_suc fst_conv normalizability_E)
  moreover with empty_not_reachable_imp_matchers_empty
    have "matchers_map (snd y) \<inter> matchers (set_mset (fst y)) = {}" by (cases y) auto
  ultimately show ?thesis using matchrel_rtrancl_matchers [of "(P, \<sigma>)"] by simp
qed

lemma matchers_map_not_empty [simp]:
  "matchers_map \<sigma> \<noteq> {}"
  "{} \<noteq> matchers_map \<sigma>"
  by (auto simp: matchers_map_def matchers_def)

lemma matchers_empty_imp_not_empty_NF:
  assumes "matchers (set_mset P) = {}"
  shows "\<exists>y. fst y \<noteq> {#} \<and> ((P, Map.empty), y) \<in> matchrel\<^sup>!"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "\<And>y. ((P, Map.empty), y) \<in> matchrel\<^sup>! \<Longrightarrow> fst y = {#}" by auto
  have "SN matchrel" using wf_converse_matchrel by (auto simp: SN_iff_wf)
  then obtain y where "((P, Map.empty), y) \<in> matchrel\<^sup>!"
    by (metis SN_imp_WN UNIV_I WN_onE)
  with * [OF this] obtain \<tau> where "((P, Map.empty), ({#}, \<tau>)) \<in> matchrel\<^sup>*" by (cases y) auto
  from matchrel_rtrancl_matchers [OF this] and assms
    show False by simp
qed

end


(*  Title:      Containers/Map_To_Mapping.thy
    Author:     Andreas Lochbihler, ETH Zurich *)

theory Map_To_Mapping imports
  "Mapping_Impl"
begin

section {* Infrastructure for operation identification *}

text {*
  To convert theorems from @{typ "'a \<Rightarrow> 'b option"} to @{typ "('a, 'b) mapping"} using lifting / transfer,
  we first introduce constants for the empty map and map lookup, then apply lifting / transfer,
  and finally eliminate the non-converted constants again.
*}

text {* Dynamic theorem list of rewrite rules that are applied before Transfer.transferred *}
ML {*
structure Containers_Pre = Named_Thms
(
  val name = @{binding containers_pre}
  val description = "Preprocessing rewrite rules in operation identification for Containers"
)
*}
setup {* Containers_Pre.setup *}

text {* Dynamic theorem list of rewrite rules that are applied after Transfer.transferred *}
ML {*
structure Containers_Post = Named_Thms
(
  val name = @{binding containers_post}
  val description = "Postprocessing rewrite rules in operation identification for Containers"
)
*}
setup {* Containers_Post.setup *}

context begin interpretation lifting_syntax .

definition map_empty :: "'a \<Rightarrow> 'b option"
where [code_unfold]: "map_empty = Map.empty"

declare map_empty_def[containers_post, symmetric, containers_pre]

declare Mapping.empty.transfer[transfer_rule del]

lemma map_empty_transfer [transfer_rule]:
  "(pcr_mapping A B) map_empty Mapping.empty"
unfolding map_empty_def by(rule Mapping.empty.transfer)

definition map_apply :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> 'b option"
where [code_unfold]: "map_apply = (\<lambda>m. m)"

lemma eq_map_apply: "m x \<equiv> map_apply m x"
by(simp add: map_apply_def)

declare eq_map_apply[symmetric, abs_def, containers_post]

text {* We cannot use @{thm [source] eq_map_apply} as a fold rule for operator identification,
  because it would loop. We use a simproc instead. *}
ML {*
val map_apply_simproc =
  Simplifier.simproc_global_i @{theory} "map_apply" [@{term "f x :: 'a option"}]
    (fn ctxt => fn redex => case redex of
      Const (@{const_name map_apply}, _) $ _ $ _ => NONE
    | f $ x =>
      let
        val thy = Proof_Context.theory_of ctxt;
        val cTr =
          redex
          |> fastype_of
          |> dest_Type
          |> snd |> hd
          |> ctyp_of thy;
        val cTx = ctyp_of thy (fastype_of x);
        val cts = map (SOME o cterm_of thy) [f, x];
      in
        SOME (Drule.instantiate' [SOME cTr, SOME cTx] cts @{thm eq_map_apply})
      end
    | _ => NONE);
*}

lemma map_apply_parametric [transfer_rule]:
  "((A ===> B) ===> A ===> B) map_apply map_apply"
unfolding map_apply_def by(transfer_prover)

lemma map_apply_transfer [transfer_rule]:
  "(pcr_mapping A B ===> A ===> rel_option B) map_apply Mapping.lookup"
by(auto simp add: pcr_mapping_def cr_mapping_def Mapping.lookup_def map_apply_def dest: rel_funD)

definition map_update :: "'a \<Rightarrow> 'b option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<Rightarrow> 'b option)"
where "map_update x y f = f(x := y)"

lemma map_update_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> rel_option B ===> (A ===> rel_option B) ===> (A ===> rel_option B)) map_update map_update"
unfolding map_update_def[abs_def] by transfer_prover

context begin
local_setup {* Local_Theory.map_naming (Name_Space.mandatory_path "Mapping") *}

lift_definition update' :: "'a \<Rightarrow> 'b option \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
is map_update parametric map_update_parametric .

lemma update'_code [simp, code, code_unfold]:
  "update' x None = Mapping.delete x"
  "update' x (Some y) = Mapping.update x y"
by(transfer, simp add: map_update_def fun_eq_iff)+

end

declare map_update_def[abs_def, containers_post] map_update_def[symmetric, containers_pre]

definition map_is_empty :: "('a \<Rightarrow> 'b option) \<Rightarrow> bool"
where "map_is_empty m \<longleftrightarrow> m = Map.empty"

lemma map_is_empty_folds:
  "m = map_empty \<longleftrightarrow> map_is_empty m"
  "map_empty = m \<longleftrightarrow> map_is_empty m"
by(auto simp add: map_is_empty_def map_empty_def)

declare map_is_empty_folds[containers_pre]
  map_is_empty_def[abs_def, containers_post]

lemma map_is_empty_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "(pcr_mapping A B ===> op =) map_is_empty Mapping.is_empty"
unfolding map_is_empty_def[abs_def] Mapping.is_empty_def[abs_def] dom_eq_empty_conv[symmetric]
by(rule rel_funI)+(auto simp del: dom_eq_empty_conv dest: rel_setD2 rel_setD1 Mapping.keys.transfer[THEN rel_funD, OF assms])

end

ML {*
signature CONTAINERS = sig
  val identify : Context.generic -> thm -> thm;
  val identify_attribute : attribute;
end

structure Containers: CONTAINERS =
struct

fun identify ctxt thm =
  let
    val ctxt' = Context.proof_of ctxt
    val ss = put_simpset HOL_basic_ss ctxt'
    val ctxt1 = ss addsimps Containers_Pre.get ctxt' addsimprocs [map_apply_simproc]
    val ctxt2 = ss addsimps Containers_Post.get ctxt'

    (* Hack to recover Transfer.transferred function from attribute *)
    fun transfer_transferred ctxt thm = Transfer.transferred_attribute [] (ctxt, thm) |> snd |> the
  in
    thm
    |> full_simplify ctxt1
    |> transfer_transferred ctxt
    |> full_simplify ctxt2
  end

val identify_attribute = Thm.rule_attribute identify

end
*}

attribute_setup "containers_identify" =
  {* Scan.succeed Containers.identify_attribute *}
  "Transfer theorems for operator identification in Containers"

hide_const (open) map_apply map_empty map_is_empty map_update
hide_fact (open) map_apply_def map_empty_def eq_map_apply

end


(*  Title:      HOL/Auth/n_mutualEx_lemma_inv__4_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualEx Protocol Case Study*}

theory n_mutualEx_lemma_inv__4_on_rules imports n_mutualEx_lemma_on_inv__4
begin
section{*All lemmas on causal relation between inv__4*}
lemma lemma_inv__4_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__4  p__Inv0)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__4) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      JinjaThreads/MM/HB_Completion.thy
    Author:     Andreas Lochbihler
*)

header {* \isaheader{Happens-before consistent completion of executions in the JMM} *}

theory HB_Completion imports
  "Non_Speculative"
begin

coinductive ta_hb_consistent :: "'m prog \<Rightarrow> ('thread_id \<times> ('addr, 'thread_id) obs_event action) list \<Rightarrow> ('thread_id \<times> ('addr, 'thread_id) obs_event action) llist \<Rightarrow> bool"
for P :: "'m prog"
where
  LNil: "ta_hb_consistent P obs LNil"
| LCons:
  "\<lbrakk> ta_hb_consistent P (obs @ [ob]) obs';
     case ob of (t, NormalAction (ReadMem ad al v))
        \<Rightarrow> (\<exists>w. w \<in> write_actions (llist_of (obs @ [ob])) \<and> (ad, al) \<in> action_loc P (llist_of (obs @ [ob])) w \<and>
               value_written P (llist_of (obs @ [ob])) w (ad, al) = v \<and>
             P,llist_of (obs @ [ob]) \<turnstile> w \<le>hb length obs \<and>
             (\<forall>w'\<in>write_actions (llist_of (obs @ [ob])). (ad, al) \<in> action_loc P (llist_of (obs @ [ob])) w' \<longrightarrow>
                (P,llist_of (obs @ [ob]) \<turnstile> w \<le>hb w' \<and> P,llist_of (obs @ [ob]) \<turnstile> w' \<le>hb length obs \<or>
                   is_volatile P al \<and> P,llist_of (obs @ [ob]) \<turnstile> w \<le>so w' \<and> P,llist_of (obs @ [ob]) \<turnstile> w' \<le>so length obs) \<longrightarrow>
                w' = w))
     | _ \<Rightarrow> True \<rbrakk>
  \<Longrightarrow> ta_hb_consistent P obs (LCons ob obs')"

inductive_simps ta_hb_consistent_LNil [simp]:
  "ta_hb_consistent P obs LNil"

inductive_simps ta_hb_consistent_LCons:
  "ta_hb_consistent P obs (LCons ob obs')"

lemma ta_hb_consistent_into_non_speculative:
  "ta_hb_consistent P obs0 obs
  \<Longrightarrow> non_speculative P (w_values P (\<lambda>_. {}) (map snd obs0)) (lmap snd obs)"
proof(coinduction arbitrary: obs0 obs)
  case (non_speculative obs0 obs)
  let ?vs = "w_values P (\<lambda>_. {}) (map snd obs0)"
  let ?CH = "\<lambda>vs obs'. \<exists>obs0 obs. vs = w_values P (\<lambda>_. {}) (map snd obs0) \<and> obs' = lmap snd obs \<and> ta_hb_consistent P obs0 obs"
  from non_speculative show ?case
  proof(cases)
    case LNil hence ?LNil by simp
    thus ?thesis ..
  next
    case (LCons tob obs'')
    note obs = `obs = LCons tob obs''`
    obtain t ob where tob: "tob = (t, ob)" by(cases tob)
    from `ta_hb_consistent P (obs0 @ [tob]) obs''` tob obs
    have "?CH (w_value P ?vs ob) (lmap snd obs'')" by(auto intro!: exI)
    moreover {
      fix ad al v
      assume ob: "ob = NormalAction (ReadMem ad al v)"
      with LCons tob obtain w where w: "w \<in> write_actions (llist_of (obs0 @ [tob]))"
        and adal: "(ad, al) \<in> action_loc P (llist_of (obs0 @ [tob])) w"
        and v: "value_written P (llist_of (obs0 @ [tob])) w (ad, al) = v" by auto
      from w obtain "is_write_action (action_obs (llist_of (obs0 @ [tob])) w)"
        and w_actions: "w \<in> actions (llist_of (obs0 @ [tob]))" by cases
      hence "v \<in> ?vs (ad, al)"
      proof(cases)
        case (WriteMem ad' al' v')
        hence "NormalAction (WriteMem ad al v) \<in> set (map snd obs0)"
          using adal ob tob v w_actions unfolding in_set_conv_nth
          by(auto simp add: action_obs_def nth_append value_written.simps actions_def cong: conj_cong split: split_if_asm)
        thus ?thesis by(rule w_values_WriteMemD)
      next
        case (NewHeapElem ad' hT)
        hence "NormalAction (NewHeapElem ad hT) \<in> set (map snd obs0)"
          using adal ob tob v w_actions unfolding in_set_conv_nth
          by(auto simp add: action_obs_def nth_append value_written.simps actions_def cong: conj_cong split: split_if_asm)
        thus ?thesis using NewHeapElem adal unfolding v[symmetric]
          by(fastforce simp add: value_written.simps intro!: w_values_new_actionD intro: rev_image_eqI)
      qed }
    hence "case ob of NormalAction (ReadMem ad al v) \<Rightarrow> v \<in> ?vs (ad, al) | _ \<Rightarrow> True"
      by(simp split: action.split obs_event.split)
    ultimately have ?LCons using obs tob by simp
    thus ?thesis ..
  qed
qed

lemma ta_hb_consistent_lappendI:
  assumes hb1: "ta_hb_consistent P E E'"
  and hb2: "ta_hb_consistent P (E @ list_of E') E''"
  and fin: "lfinite E'"
  shows "ta_hb_consistent P E (lappend E' E'')"
using fin hb1 hb2
proof(induction arbitrary: E)
  case lfinite_LNil thus ?case by simp
next
  case (lfinite_LConsI E' tob)
  from `ta_hb_consistent P E (LCons tob E')`
  have "ta_hb_consistent P (E @ [tob]) E'" by cases
  moreover from `ta_hb_consistent P (E @ list_of (LCons tob E')) E''` `lfinite E'`
  have "ta_hb_consistent P ((E @ [tob]) @ list_of E') E''" by simp
  ultimately have "ta_hb_consistent P (E @ [tob]) (lappend E' E'')" by(rule lfinite_LConsI.IH)
  thus ?case unfolding lappend_code apply(rule ta_hb_consistent.LCons)
    using `ta_hb_consistent P E (LCons tob E')`
    by cases (simp split: prod.split_asm action.split_asm obs_event.split_asm)
qed

lemma ta_hb_consistent_coinduct_append
  [consumes 1, case_names ta_hb_consistent, case_conclusion ta_hb_consistent LNil lappend]:
  assumes major: "X E tobs"
  and step: "\<And>E tobs. X E tobs
    \<Longrightarrow> tobs = LNil \<or>
       (\<exists>tobs' tobs''. tobs = lappend tobs' tobs'' \<and> tobs' \<noteq> LNil \<and> ta_hb_consistent P E tobs' \<and>
                    (lfinite tobs' \<longrightarrow> (X (E @ list_of tobs') tobs''\<or>
                                       ta_hb_consistent P (E @ list_of tobs') tobs'')))"
    (is "\<And>E tobs. _ \<Longrightarrow> _ \<or> ?step E tobs")
  shows "ta_hb_consistent P E tobs"
proof -
  from major
  have "\<exists>tobs' tobs''. tobs = lappend (llist_of tobs') tobs'' \<and> ta_hb_consistent P E (llist_of tobs') \<and>
                     X (E @ tobs') tobs''"
    by(auto intro: exI[where x="[]"])
  thus ?thesis
  proof(coinduct)
    case (ta_hb_consistent E tobs)
    then obtain tobs' tobs''
      where tobs: "tobs = lappend (llist_of tobs') tobs''"
      and hb_tobs': "ta_hb_consistent P E (llist_of tobs')"
      and X: "X (E @ tobs') tobs''" by blast

    show ?case
    proof(cases tobs')
      case Nil
      with X have "X E tobs''" by simp
      from step[OF this] show ?thesis
      proof
        assume "tobs'' = LNil"
        with Nil tobs show ?thesis by simp
      next
        assume "?step E tobs''"
        then obtain tobs''' tobs''''
          where tobs'': "tobs'' = lappend tobs''' tobs''''" and "tobs''' \<noteq> LNil"
          and sc_obs''': "ta_hb_consistent P E tobs'''"
          and fin: "lfinite tobs''' \<Longrightarrow> X (E @ list_of tobs''') tobs'''' \<or>
                                      ta_hb_consistent P (E @ list_of tobs''') tobs''''"
          by blast
        from `tobs''' \<noteq> LNil` obtain t ob tobs''''' where tobs''': "tobs''' = LCons (t, ob) tobs'''''"
          unfolding neq_LNil_conv by auto
        with Nil tobs'' tobs have concl1: "tobs = LCons (t, ob) (lappend tobs''''' tobs'''')" by simp

        have ?LCons
        proof(cases "lfinite tobs'''")
          case False
          hence "lappend tobs''''' tobs'''' = tobs'''''" using tobs''' by(simp add: lappend_inf)
          hence "ta_hb_consistent P (E @ [(t, ob)]) (lappend tobs''''' tobs'''')"
            using sc_obs''' tobs''' by(simp add: ta_hb_consistent_LCons)
          with concl1 show ?LCons apply(simp)
            using sc_obs'''[unfolded tobs'''] by cases simp
        next
          case True
          with tobs''' obtain tobs'''''' where tobs''''': "tobs''''' = llist_of tobs''''''"
            by simp(auto simp add: lfinite_eq_range_llist_of)
          from fin[OF True]
          have "ta_hb_consistent P (E @ [(t, ob)]) (llist_of tobs'''''') \<and> X (E @ (t, ob) # tobs'''''') tobs'''' \<or>
                ta_hb_consistent P (E @ [(t, ob)]) (lappend (llist_of tobs'''''') tobs'''')"
          proof
            assume X: "X (E @ list_of tobs''') tobs''''"
            hence "X (E @ (t, ob) # tobs'''''') tobs''''" using tobs''''' tobs''' by simp
            moreover have "ta_hb_consistent P (E @ [(t, ob)]) (llist_of tobs'''''')"
              using sc_obs''' tobs''' tobs''''' by(simp add: ta_hb_consistent_LCons)
            ultimately show ?thesis by simp
          next
            assume "ta_hb_consistent P (E @ list_of tobs''') tobs''''"
            with sc_obs''' tobs''''' tobs'''
            have "ta_hb_consistent P (E @ [(t, ob)]) (lappend (llist_of tobs'''''') tobs'''')"
              by(simp add: ta_hb_consistent_LCons ta_hb_consistent_lappendI)
            thus ?thesis ..
          qed
          hence "((\<exists>tobs' tobs''. lappend (llist_of tobs'''''') tobs'''' = lappend (llist_of tobs') tobs'' \<and>
                                  ta_hb_consistent P (E @ [(t, ob)]) (llist_of tobs') \<and> X (E @ (t, ob) # tobs') tobs'') \<or>
                 ta_hb_consistent P (E @ [(t, ob)]) (lappend (llist_of tobs'''''') tobs''''))"
            by auto
          thus "?LCons" using concl1 tobs''''' apply(simp)
            using sc_obs'''[unfolded tobs'''] by cases simp
        qed
        thus ?thesis ..
      qed
    next
      case (Cons tob tobs''')
      with X tobs hb_tobs' show ?thesis by(auto simp add: ta_hb_consistent_LCons)
    qed
  qed
qed

lemma ta_hb_consistent_coinduct_append_wf
  [consumes 2, case_names ta_hb_consistent, case_conclusion ta_hb_consistent LNil lappend]:
  assumes major: "X E obs a"
  and wf: "wf R"
  and step: "\<And>E obs a. X E obs a
    \<Longrightarrow> obs = LNil \<or>
       (\<exists>obs' obs'' a'. obs = lappend obs' obs'' \<and> ta_hb_consistent P E obs' \<and> (obs' = LNil \<longrightarrow> (a', a) \<in> R) \<and>
                        (lfinite obs' \<longrightarrow> X (E @ list_of obs') obs'' a' \<or>
                                          ta_hb_consistent P (E @ list_of obs') obs''))"
    (is "\<And>E obs a. _ \<Longrightarrow> _ \<or> ?step E obs a")
  shows "ta_hb_consistent P E obs"
proof -
  { fix E obs a
    assume "X E obs a"
    with wf
    have "obs = LNil \<or> (\<exists>obs' obs''. obs = lappend obs' obs'' \<and> obs' \<noteq> LNil \<and> ta_hb_consistent P E obs' \<and>
          (lfinite obs' \<longrightarrow> (\<exists>a. X (E @ list_of obs') obs'' a) \<or>
                            ta_hb_consistent P (E @ list_of obs') obs''))"
      (is "_ \<or> ?step_concl E obs")
    proof(induction a arbitrary: E obs rule: wf_induct[consumes 1, case_names wf])
      case (wf a)
      note IH = wf.IH[rule_format]
      from step[OF `X E obs a`]
      show ?case
      proof
        assume "obs = LNil" thus ?thesis ..
      next
        assume "?step E obs a"
        then obtain obs' obs'' a'
          where obs: "obs = lappend obs' obs''"
          and sc_obs': "ta_hb_consistent P E obs'"
          and decr: "obs' = LNil \<Longrightarrow> (a', a) \<in> R"
          and fin: "lfinite obs' \<Longrightarrow>
                    X (E @ list_of obs') obs'' a' \<or>
                    ta_hb_consistent P (E @ list_of obs') obs''"
          by blast
        show ?case
        proof(cases "obs' = LNil")
          case True
          hence "lfinite obs'" by simp
          from fin[OF this] show ?thesis
          proof
            assume X: "X (E @ list_of obs') obs'' a'"
            from True have "(a', a) \<in> R" by(rule decr)
            from IH[OF this X] show ?thesis
            proof
              assume "obs'' = LNil"
              with True obs have "obs = LNil" by simp
              thus ?thesis ..
            next
              assume "?step_concl (E @ list_of obs') obs''"
              hence "?step_concl E obs" using True obs by simp
              thus ?thesis ..
            qed
          next
            assume "ta_hb_consistent P (E @ list_of obs') obs''"
            thus ?thesis using obs True
              by cases (auto 4 3 cong: action.case_cong obs_event.case_cong intro: exI[where x="LCons x LNil" for x] simp add: ta_hb_consistent_LCons)
          qed
        next
          case False
          with obs sc_obs' fin show ?thesis by auto
        qed
      qed
    qed }
  note step' = this

  from major show ?thesis
  proof(coinduction arbitrary: E obs a rule: ta_hb_consistent_coinduct_append)
    case (ta_hb_consistent E obs)
    thus ?case by simp(rule step')
  qed
qed

lemma ta_hb_consistent_lappendD2:
  assumes hb: "ta_hb_consistent P E (lappend E' E'')"
  and fin: "lfinite E'"
  shows "ta_hb_consistent P (E @ list_of E') E''"
using fin hb
by(induct arbitrary: E)(fastforce simp add: ta_hb_consistent_LCons)+

lemma ta_hb_consistent_Read_hb:
  fixes E E' defines "E'' \<equiv> lappend (llist_of E') E"
  assumes hb: "ta_hb_consistent P E' E"
  and tsa: "thread_start_actions_ok E''"
  and E'': "is_write_seen P (llist_of E') ws'"
  and new_actions_for_fun:
  "\<And>w w' adal. \<lbrakk> w \<in> new_actions_for P E'' adal;
                 w' \<in> new_actions_for P E'' adal \<rbrakk> \<Longrightarrow> w = w'"
  shows "\<exists>ws. P \<turnstile> (E'', ws) \<surd> \<and> (\<forall>n. n \<in> read_actions E'' \<longrightarrow> length E' \<le> n \<longrightarrow> P,E'' \<turnstile> ws n \<le>hb n) \<and>
              (\<forall>n. n < length E' \<longrightarrow> ws n = ws' n)"
proof(intro exI conjI strip)
  let ?P =
    "\<lambda>n w. case lnth E'' n of
        (t, NormalAction (ReadMem ad al v)) \<Rightarrow>
          (w \<in> write_actions E'' \<and> (ad, al) \<in> action_loc P E'' w \<and> value_written P E'' w (ad, al) = v \<and>
          P,E'' \<turnstile> w \<le>hb n \<and>
          (\<forall>w'\<in>write_actions E''. (ad, al) \<in> action_loc P E'' w' \<longrightarrow>
              (P,E'' \<turnstile> w \<le>hb w' \<and> P,E'' \<turnstile> w' \<le>hb n \<or>
               is_volatile P al \<and> P,E'' \<turnstile> w \<le>so w' \<and> P,E'' \<turnstile> w' \<le>so n) \<longrightarrow>
              w' = w))"
  let ?ws = "\<lambda>n. if n < length E' then ws' n else Eps (?P n)"

  have "\<And>n. n < length E' \<Longrightarrow> ?ws n = ws' n" by simp
  moreover
  have "P \<turnstile> (E'', ?ws) \<surd> \<and>
        (\<forall>n ad al v. n \<in> read_actions E'' \<longrightarrow> length E' \<le> n \<longrightarrow> action_obs E'' n = NormalAction (ReadMem ad al v) \<longrightarrow> P,E'' \<turnstile> ?ws n \<le>hb n)"
  proof(intro conjI wf_execI strip is_write_seenI)
    fix a' ad al v
    assume read: "a' \<in> read_actions E''"
      and aobs: "action_obs E'' a' = NormalAction (ReadMem ad al v)"
    then obtain t where a': "enat a' < llength E''"
      and lnth'': "lnth E'' a' = (t, NormalAction (ReadMem ad al v))"
      by(cases)(cases "lnth E'' a'", clarsimp simp add: actions_def action_obs_def)

    have "?ws a' \<in> write_actions E'' \<and>
      (ad, al) \<in> action_loc P E'' (?ws a') \<and>
      value_written P E'' (?ws a') (ad, al) = v \<and>
      (length E' \<le> a' \<longrightarrow> P,E'' \<turnstile> ?ws a' \<le>hb a') \<and>
      \<not> P,E'' \<turnstile> a' \<le>hb ?ws a' \<and>
      (is_volatile P al \<longrightarrow> \<not> P,E'' \<turnstile> a' \<le>so ?ws a') \<and>
      (\<forall>a''. a'' \<in> write_actions E'' \<longrightarrow> (ad, al) \<in> action_loc P E'' a'' \<longrightarrow>
             (P,E'' \<turnstile> ?ws a' \<le>hb a'' \<and> P,E'' \<turnstile> a'' \<le>hb a' \<or> is_volatile P al \<and> P,E'' \<turnstile> ?ws a' \<le>so a'' \<and> P,E'' \<turnstile> a'' \<le>so a')
             \<longrightarrow> a'' = ?ws a')"
    proof(cases "a' < length E'", safe del: notI disjE conjE)
      assume a'_E': "a' < length E'"
      with read aobs have a': "a' \<in> read_actions (llist_of E')"
        and aobs': "action_obs (llist_of E') a' = NormalAction (ReadMem ad al v)"
        by(auto simp add: E''_def action_obs_def lnth_lappend1 actions_def elim: read_actions.cases intro: read_actions.intros)
      have sim: "ltake (enat (length E')) (llist_of E') [\<approx>] ltake (enat (length E')) (lappend (llist_of E') E)"
        by(rule eq_into_sim_actions)(simp add: ltake_all ltake_lappend1)
      from tsa have tsa': "thread_start_actions_ok (llist_of E')"
        by(rule thread_start_actions_ok_prefix)(simp add: E''_def lprefix_lappend)

      from is_write_seenD[OF E'' a' aobs'] a'_E'
      show "?ws a' \<in> write_actions E''"
        and "(ad, al) \<in> action_loc P E'' (?ws a')"
        and "value_written P E'' (?ws a') (ad, al) = v"
        and "\<not> P,E'' \<turnstile> a' \<le>hb ?ws a'"
        and "is_volatile P al \<Longrightarrow> \<not> P,E'' \<turnstile> a' \<le>so ?ws a'"
        by(auto elim!: write_actions.cases intro!: write_actions.intros simp add: E''_def lnth_lappend1 actions_def action_obs_def value_written_def enat_less_enat_plusI dest: happens_before_change_prefix[OF _ tsa' sim[symmetric]] sync_order_change_prefix[OF _ sim[symmetric]])

      { assume "length E' \<le> a'"
        thus "P,E'' \<turnstile> ?ws a' \<le>hb a'" using a'_E' by simp }

      { fix w
        assume w: "w \<in> write_actions E''" "(ad, al) \<in> action_loc P E'' w"
          and hbso: "P,E'' \<turnstile> ?ws a' \<le>hb w \<and> P,E'' \<turnstile> w \<le>hb a' \<or> is_volatile P al \<and> P,E'' \<turnstile> ?ws a' \<le>so w \<and> P,E'' \<turnstile> w \<le>so a'"
        show "w = ?ws a'"
        proof(cases "w < length E'")
          case True
          with is_write_seenD[OF E'' a' aobs'] a'_E' w hbso show ?thesis
            by(auto 4 3 elim!: write_actions.cases intro!: write_actions.intros simp add: E''_def lnth_lappend1 actions_def action_obs_def value_written_def enat_less_enat_plusI dest: happens_before_change_prefix[OF _ tsa[unfolded E''_def] sim] happens_before_change_prefix[OF _ tsa' sim[symmetric]] sync_order_change_prefix[OF _ sim, simplified] sync_order_change_prefix[OF _ sim[symmetric], simplified] bspec[where x=w])
        next
          case False
          from hbso have "E'' \<turnstile> w \<le>a a'" by(auto intro: happens_before_into_action_order elim: sync_orderE)
          moreover from w(1) read have "w \<noteq> a'" by(auto dest: read_actions_not_write_actions)
          ultimately have new_w: "is_new_action (action_obs E'' w)" using False aobs a'_E'
            by(cases rule: action_orderE) auto
          moreover from hbso a'_E' have "E'' \<turnstile> ws' a' \<le>a w"
            by(auto intro: happens_before_into_action_order elim: sync_orderE)
          hence new_a': "is_new_action (action_obs E'' (?ws a'))" using new_w a'_E'
            by(cases rule: action_orderE) auto
          ultimately have "w \<in> new_actions_for P E'' (ad, al)" "?ws a' \<in> new_actions_for P E'' (ad, al)"
            using w is_write_seenD[OF E'' a' aobs'] a'_E'
            by(auto simp add: new_actions_for_def actions_def action_obs_def lnth_lappend1 E''_def enat_less_enat_plusI elim!: write_actions.cases)
          thus ?thesis by(rule new_actions_for_fun)
        qed }
    next
      assume "\<not> a' < length E'"
      hence a'_E': "length E' \<le> a'" by simp
      def a \<equiv> "a' - length E'"
      with a' a'_E' have a: "enat a < llength E"
        by(simp add: E''_def) (metis enat_add_mono le_add_diff_inverse plus_enat_simps(1))

      from a_def aobs lnth'' a'_E'
      have aobs: "action_obs E a = NormalAction (ReadMem ad al v)"
        and lnth: "lnth E a = (t, NormalAction (ReadMem ad al v))"
        by(simp_all add: E''_def lnth_lappend2 action_obs_def)

      def E''' \<equiv> "lappend (llist_of E') (ltake (enat a) E)"
      let ?E'' = "lappend E''' (LCons (t, NormalAction (ReadMem ad al v)) LNil)"

      note hb also
      have E_unfold1: "E = lappend (ltake (enat a) E) (ldropn a E)" by simp
      also have E_unfold2: "ldropn a E = LCons (t, NormalAction (ReadMem ad al v)) (ldropn (Suc a) E)"
        using a lnth by (metis ldropn_Suc_conv_ldropn)
      finally
      have "ta_hb_consistent P (E' @ list_of (ltake (enat a) E))
              (LCons (t, NormalAction (ReadMem ad al v)) (ldropn (Suc a) E))"
        by(rule ta_hb_consistent_lappendD2) simp
      with a a'_E' a_def obtain w where w: "w \<in> write_actions ?E''"
        and adal_w: "(ad, al) \<in> action_loc P ?E'' w"
        and written: "value_written P ?E'' w (ad, al) = v"
        and hb: "P,?E'' \<turnstile> w \<le>hb a'"
        and in_between_so:
        "\<And>w'. \<lbrakk> w' \<in> write_actions ?E''; (ad, al) \<in> action_loc P ?E'' w';
                is_volatile P al; P,?E'' \<turnstile> w \<le>so w'; P,?E'' \<turnstile> w' \<le>so a' \<rbrakk>
        \<Longrightarrow> w' = w"
        and in_between_hb:
        "\<And>w'. \<lbrakk> w' \<in> write_actions ?E''; (ad, al) \<in> action_loc P ?E'' w';
                P,?E'' \<turnstile> w \<le>hb w'; P,?E'' \<turnstile> w' \<le>hb a' \<rbrakk>
        \<Longrightarrow> w' = w"
        by(auto simp add: ta_hb_consistent_LCons length_list_of_conv_the_enat min_def lnth_ltake lappend_llist_of_llist_of[symmetric] E'''_def lappend_assoc simp del: lappend_llist_of_llist_of nth_list_of split: if_splits)

      from a' a'_E' a
      have eq: "ltake (enat (Suc a')) ?E'' = ltake (enat (Suc a')) E''" (is "?lhs = ?rhs")
        unfolding E''_def E'''_def lappend_assoc
        apply(subst (2) E_unfold1)
        apply(subst E_unfold2)
        apply(subst (1 2) ltake_lappend2)
         apply(simp)
        apply(rule arg_cong) back
        apply(subst (1 2) ltake_lappend2)
         apply(simp add: min_def)
         apply (metis Suc_diff_le a_def le_Suc_eq order_le_less)
        apply(rule arg_cong) back
        apply(auto simp add: min_def a_def)
        apply(auto simp add: eSuc_enat[symmetric] zero_enat_def[symmetric])
        done
      hence sim: "?lhs [\<approx>] ?rhs" by(rule eq_into_sim_actions)
      from tsa have tsa': "thread_start_actions_ok ?E''" unfolding E''_def E'''_def lappend_assoc
        by(rule thread_start_actions_ok_prefix)(subst (2) E_unfold1, simp add: E_unfold2)

      from w a a' a_def a'_E' have w_a': "w < Suc a'"
        by cases(simp add: actions_def E'''_def min_def zero_enat_def eSuc_enat split: split_if_asm)

      from w sim have "w \<in> write_actions E''" by(rule write_actions_change_prefix)(simp add: w_a')
      moreover
      from adal_w action_loc_change_prefix[OF sim, of w P] w_a'
      have "(ad, al) \<in> action_loc P E'' w" by simp
      moreover
      from written value_written_change_prefix[OF eq, of w P] w_a'
      have "value_written P E'' w (ad, al) = v" by simp
      moreover
      from hb tsa sim have "P,E'' \<turnstile> w \<le>hb a'" by(rule happens_before_change_prefix)(simp_all add: w_a')
      moreover {
        fix w'
        assume w': "w' \<in> write_actions E''"
          and adal: "(ad, al) \<in> action_loc P E'' w'"
          and hbso: "P,E'' \<turnstile> w \<le>hb w' \<and> P,E'' \<turnstile> w' \<le>hb a' \<or> is_volatile P al \<and> P,E'' \<turnstile> w \<le>so w' \<and> P,E'' \<turnstile> w' \<le>so a'"
          (is "?hbso E''")
        from hbso have ao: "E'' \<turnstile> w \<le>a w'" "E'' \<turnstile> w' \<le>a a'"
          by(auto dest: happens_before_into_action_order elim: sync_orderE)
        have "w' = w"
        proof(cases "is_new_action (action_obs E'' w')")
          case True
          hence "w' \<in> new_actions_for P E'' (ad, al)" using w' adal by(simp add: new_actions_for_def)
          moreover from ao True have "is_new_action (action_obs E'' w)" by(cases rule: action_orderE) simp_all
          with `w \<in> write_actions E''` `(ad, al) \<in> action_loc P E'' w`
          have "w \<in> new_actions_for P E'' (ad, al)" by(simp add: new_actions_for_def)
          ultimately show "w' = w" by(rule new_actions_for_fun)
        next
          case False
          with ao have "w' \<le> a'" by(auto elim: action_orderE)
          hence w'_a: "enat w' < enat (Suc a')" by simp
          with hbso w_a' have "?hbso ?E''"
            by(auto 4 3 elim: happens_before_change_prefix[OF _ tsa' sim[symmetric]] sync_order_change_prefix[OF _ sim[symmetric]] del: disjCI intro: disjI1 disjI2)
          moreover from w' `w' \<le> a'` a' a lnth a'_E' have "w' \<in> write_actions ?E''"
            by(cases)(cases "w' < a'", auto intro!: write_actions.intros simp add: E'''_def actions_def action_obs_def lnth_lappend min_def zero_enat_def eSuc_enat lnth_ltake a_def E''_def not_le not_less)
          moreover from adal `w' \<le> a'` a a' lnth w' a'_E' have "(ad, al) \<in> action_loc P ?E'' w'"
            by(cases "w' < a'")(cases "w' < length E'", auto simp add: E'''_def action_obs_def lnth_lappend lappend_assoc[symmetric] min_def lnth_ltake less_trans[where y="enat a"] a_def E''_def lnth_ltake elim: write_actions.cases)
          ultimately show "w' = w" by(blast dest: in_between_so in_between_hb)
        qed }
      ultimately have "?P a' w" using a'_E' lnth unfolding E''_def a_def by(simp add: lnth_lappend)
      hence P: "?P a' (Eps (?P a'))" by(rule someI[where P="?P a'"])

      from P lnth'' a'_E'
      show "?ws a' \<in> write_actions E''"
        and "(ad, al) \<in> action_loc P E'' (?ws a')"
        and "value_written P E'' (?ws a') (ad, al) = v"
        and "P,E'' \<turnstile> ?ws a' \<le>hb a'" by simp_all

      show "\<not> P,E'' \<turnstile> a' \<le>hb ?ws a'"
      proof
        assume "P,E'' \<turnstile> a' \<le>hb ?ws a'"
        with `P,E'' \<turnstile> ?ws a' \<le>hb a'` have "a' = ?ws a'"
          by(blast dest: antisymPD[OF antisym_action_order] happens_before_into_action_order)
        with read `?ws a' \<in> write_actions E''` show False
          by(auto dest: read_actions_not_write_actions)
      qed

      show "\<not> P,E'' \<turnstile> a' \<le>so ?ws a'"
      proof
        assume "P,E'' \<turnstile> a' \<le>so ?ws a'"
        hence "E'' \<turnstile> a' \<le>a ?ws a'" by(blast elim: sync_orderE)
        with `P,E'' \<turnstile> ?ws a' \<le>hb a'` have "a' = ?ws a'"
          by(blast dest: antisymPD[OF antisym_action_order] happens_before_into_action_order)
        with read `?ws a' \<in> write_actions E''` show False
          by(auto dest: read_actions_not_write_actions)
      qed

      fix a''
      assume "a'' \<in> write_actions E''" "(ad, al) \<in> action_loc P E'' a''"
        and "P,E'' \<turnstile> ?ws a' \<le>hb a'' \<and> P,E'' \<turnstile> a'' \<le>hb a' \<or>
             is_volatile P al \<and> P,E'' \<turnstile> ?ws a' \<le>so a'' \<and> P,E'' \<turnstile> a'' \<le>so a'"
      thus "a'' = ?ws a'" using lnth'' P a'_E' by -(erule disjE, clarsimp+)
    qed
    thus "?ws a' \<in> write_actions E''"
      and "(ad, al) \<in> action_loc P E'' (?ws a')"
      and "value_written P E'' (?ws a') (ad, al) = v"
      and "length E' \<le> a' \<Longrightarrow> P,E'' \<turnstile> ?ws a' \<le>hb a'"
      and "\<not> P,E'' \<turnstile> a' \<le>hb ?ws a'"
      and "is_volatile P al \<Longrightarrow> \<not> P,E'' \<turnstile> a' \<le>so ?ws a'"
      and "\<And>a''. \<lbrakk> a'' \<in> write_actions E''; (ad, al) \<in> action_loc P E'' a''; P,E'' \<turnstile> ?ws a' \<le>hb a''; P,E'' \<turnstile> a'' \<le>hb a' \<rbrakk> \<Longrightarrow> a'' = ?ws a'"
      and "\<And>a''. \<lbrakk> a'' \<in> write_actions E''; (ad, al) \<in> action_loc P E'' a''; is_volatile P al; P,E'' \<turnstile> ?ws a' \<le>so a''; P,E'' \<turnstile> a'' \<le>so a' \<rbrakk> \<Longrightarrow> a'' = ?ws a'"
      by blast+
  qed(assumption|rule tsa)+
  thus "P \<turnstile> (E'', ?ws) \<surd>"
    and "\<And>n. \<lbrakk> n \<in> read_actions E''; length E' \<le> n \<rbrakk> \<Longrightarrow> P,E'' \<turnstile> ?ws n \<le>hb n"
    by(blast elim: read_actions.cases intro: read_actions.intros)+

  fix n
  assume "n < length E'"
  thus "?ws n = ws' n" by simp
qed

lemma ta_hb_consistent_not_ReadI:
  "(\<And>t ad al v. (t, NormalAction (ReadMem ad al v)) \<notin> lset E) \<Longrightarrow> ta_hb_consistent P E' E"
proof(coinduction arbitrary: E' E)
  case (ta_hb_consistent E' E)
  thus ?case by(cases E)(auto split: action.split obs_event.split, blast)
qed

context jmm_multithreaded begin

definition complete_hb :: "('l,'thread_id,'x,'m,'w) state \<Rightarrow> ('thread_id \<times> ('addr, 'thread_id) obs_event action) list
  \<Rightarrow> ('thread_id \<times> ('l, 'thread_id, 'x, 'm, 'w, ('addr, 'thread_id) obs_event action) thread_action) llist"
where
  "complete_hb s E = unfold_llist
     (\<lambda>(s, E). \<forall>t ta s'. \<not> s -t\<triangleright>ta\<rightarrow> s')
     (\<lambda>(s, E). fst (SOME ((t, ta), s'). s -t\<triangleright>ta\<rightarrow> s' \<and> ta_hb_consistent P E (llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))))
     (\<lambda>(s, E). let ((t, ta), s') = SOME ((t, ta), s'). s -t\<triangleright>ta\<rightarrow> s' \<and> ta_hb_consistent P E (llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))
         in (s', E @ map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))
     (s, E)"

definition hb_completion ::
  "('l, 'thread_id, 'x, 'm, 'w) state \<Rightarrow> ('thread_id \<times> ('addr, 'thread_id) obs_event action) list \<Rightarrow> bool"
where
  "hb_completion s E \<longleftrightarrow>
   (\<forall>ttas s' t x ta x' m' i.
       s -\<triangleright>ttas\<rightarrow>* s' \<longrightarrow>
       non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas))) \<longrightarrow>
       thr s' t = \<lfloor>(x, no_wait_locks)\<rfloor> \<longrightarrow> t \<turnstile> (x, shr s') -ta\<rightarrow> (x', m') \<longrightarrow> actions_ok s' t ta \<longrightarrow>
       non_speculative P (w_values P (w_values P (\<lambda>_. {}) (map snd E)) (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas))) (llist_of (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) \<longrightarrow>
       (\<exists>ta' x'' m''. t \<turnstile> (x, shr s') -ta'\<rightarrow> (x'', m'') \<and> actions_ok s' t ta' \<and>
                      take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and>
                      ta_hb_consistent P
                        (E @ concat (map (\<lambda>(t, ta). map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas) @ map (Pair t) (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))
                        (llist_of (map (Pair t) (drop i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>))) \<and>
                      (i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<longrightarrow> i < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>) \<and>
                      (if \<exists>ad al v. \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v) then sim_action else op =) (\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i) (\<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! i)))"

lemma hb_completionD:
  "\<lbrakk> hb_completion s E; s -\<triangleright>ttas\<rightarrow>* s';
     non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas)));
     thr s' t = \<lfloor>(x, no_wait_locks)\<rfloor>; t \<turnstile> (x, shr s') -ta\<rightarrow> (x', m'); actions_ok s' t ta;
     non_speculative P (w_values P (w_values P (\<lambda>_. {}) (map snd E)) (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas))) (llist_of (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) \<rbrakk>
  \<Longrightarrow> \<exists>ta' x'' m''. t \<turnstile> (x, shr s') -ta'\<rightarrow> (x'', m'') \<and> actions_ok s' t ta' \<and>
                   take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and>
                   ta_hb_consistent P (E @ concat (map (\<lambda>(t, ta). map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas) @ map (Pair t) (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))
                                      (llist_of (map (Pair t) (drop i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>))) \<and>
                   (i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<longrightarrow> i < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>) \<and>
                   (if \<exists>ad al v. \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v) then sim_action else op =) (\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i) (\<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! i)"
unfolding hb_completion_def by blast

lemma hb_completionI [intro?]:
  "(\<And>ttas s' t x ta x' m' i.
     \<lbrakk> s -\<triangleright>ttas\<rightarrow>* s'; non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas)));
       thr s' t = \<lfloor>(x, no_wait_locks)\<rfloor>; t \<turnstile> (x, shr s') -ta\<rightarrow> (x', m'); actions_ok s' t ta;
       non_speculative P (w_values P (w_values P (\<lambda>_. {}) (map snd E)) (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas))) (llist_of (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) \<rbrakk>
     \<Longrightarrow> \<exists>ta' x'' m''. t \<turnstile> (x, shr s') -ta'\<rightarrow> (x'', m'') \<and> actions_ok s' t ta' \<and> take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and>
                   ta_hb_consistent P (E @ concat (map (\<lambda>(t, ta). map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas) @ map (Pair t) (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) (llist_of (map (Pair t) (drop i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>))) \<and>
                   (i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<longrightarrow> i < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>) \<and>
                   (if \<exists>ad al v. \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v) then sim_action else op =) (\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i) (\<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! i))
  \<Longrightarrow> hb_completion s E"
unfolding hb_completion_def by blast

lemma hb_completion_shift:
  assumes hb_c: "hb_completion s E"
  and \<tau>Red: "s -\<triangleright>ttas\<rightarrow>* s'"
  and sc: "non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas)))"
      (is "non_speculative _ ?vs _")
  shows "hb_completion s' (E @ (concat (map (\<lambda>(t, ta). map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas)))"
  (is "hb_completion _ ?E")
proof(rule hb_completionI)
  fix ttas' s'' t x ta x' m' i
  assume \<tau>Red': "s' -\<triangleright>ttas'\<rightarrow>* s''"
    and sc': "non_speculative P (w_values P (\<lambda>_. {}) (map snd ?E)) (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas')))"
    and red: "thr s'' t = \<lfloor>(x, no_wait_locks)\<rfloor>" "t \<turnstile> \<langle>x, shr s''\<rangle> -ta\<rightarrow> \<langle>x', m'\<rangle>" "actions_ok s'' t ta"
    and ns: "non_speculative P (w_values P (w_values P (\<lambda>_. {}) (map snd ?E)) (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas'))) (llist_of (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"
  from \<tau>Red \<tau>Red' have "s -\<triangleright>ttas @ ttas'\<rightarrow>* s''" unfolding RedT_def by(rule rtrancl3p_trans)
  moreover from sc sc' have "non_speculative P ?vs (llist_of (concat (map (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) (ttas @ ttas'))))"
    unfolding map_append concat_append lappend_llist_of_llist_of[symmetric] map_concat
    by(simp add: non_speculative_lappend o_def split_def del: lappend_llist_of_llist_of)
  ultimately
  show "\<exists>ta' x'' m''. t \<turnstile> \<langle>x, shr s''\<rangle> -ta'\<rightarrow> \<langle>x'', m''\<rangle> \<and> actions_ok s'' t ta' \<and> take i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> = take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<and>
         ta_hb_consistent P (?E @ concat (map (\<lambda>(t, ta). map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>) ttas') @ map (Pair t) (take i \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))
                            (llist_of (map (Pair t) (drop i \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>))) \<and>
         (i < length \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> \<longrightarrow> i < length \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>) \<and>
         (if \<exists>ad al v. \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i = NormalAction (ReadMem ad al v) then sim_action else op =) (\<lbrace>ta\<rbrace>\<^bsub>o\<^esub> ! i) (\<lbrace>ta'\<rbrace>\<^bsub>o\<^esub> ! i)"
    using red ns unfolding append_assoc
    apply(subst (2) append_assoc[symmetric])
    unfolding concat_append[symmetric] map_append[symmetric] foldr_append[symmetric]
    by(rule hb_completionD[OF hb_c])(simp_all add: map_concat o_def split_def)
qed

lemma hb_completion_shift1:
  assumes hb_c: "hb_completion s E"
  and Red: "s -t\<triangleright>ta\<rightarrow> s'"
  and sc: "non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
  shows "hb_completion s' (E @ map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)"
using hb_completion_shift[OF hb_c, of "[(t, ta)]" s'] Red sc
by(simp add: RedT_def rtrancl3p_Cons rtrancl3p_Nil del: split_paired_Ex)

lemma complete_hb_in_Runs:
  assumes hb_c: "hb_completion s E"
  and ta_hb_consistent_convert_RA: "\<And>t E ln. ta_hb_consistent P E (llist_of (map (Pair t) (convert_RA ln)))"
  shows "mthr.Runs s (complete_hb s E)"
using hb_c
proof(coinduction arbitrary: s E)
  case (Runs s E)
  let ?P = "\<lambda>((t, ta), s'). s -t\<triangleright>ta\<rightarrow> s' \<and> ta_hb_consistent P E (llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"
  show ?case
  proof(cases "\<exists>t ta s'. s -t\<triangleright>ta\<rightarrow> s'")
    case False
    then have ?Stuck by(simp add: complete_hb_def)
    thus ?thesis ..
  next
    case True
    let ?t = "fst (fst (Eps ?P))" and ?ta = "snd (fst (Eps ?P))" and ?s' = "snd (Eps ?P)"
    from True obtain t ta s' where red: "s -t\<triangleright>ta\<rightarrow> s'" by blast
    hence "\<exists>x. ?P x"
    proof(cases)
      case (redT_normal x x' m')
      from hb_completionD[OF Runs _ _ `thr s t = \<lfloor>(x, no_wait_locks)\<rfloor>` `t \<turnstile> \<langle>x, shr s\<rangle> -ta\<rightarrow> \<langle>x', m'\<rangle>` `actions_ok s t ta`, of "[]" 0]
      obtain ta' x'' m'' where "t \<turnstile> \<langle>x, shr s\<rangle> -ta'\<rightarrow> \<langle>x'', m''\<rangle>"
        and "actions_ok s t ta'" "ta_hb_consistent P E (llist_of (map (Pair t) \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>))"
        by fastforce
      moreover obtain ws' where "redT_updWs t (wset s) \<lbrace>ta'\<rbrace>\<^bsub>w\<^esub> ws'" by (metis redT_updWs_total)
      ultimately show ?thesis using `thr s t = \<lfloor>(x, no_wait_locks)\<rfloor>`
        by(cases ta')(auto intro!: exI redT.redT_normal)
    next
      case (redT_acquire x ln n)
      thus ?thesis using ta_hb_consistent_convert_RA[of E t ln]
        by(auto intro!: exI redT.redT_acquire)
    qed
    hence "?P (Eps ?P)" by(rule someI_ex)
    hence red: "s -?t\<triangleright>?ta\<rightarrow> ?s'"
      and hb: "ta_hb_consistent P E (llist_of (map (Pair ?t) \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>))"
      by(simp_all add: split_beta)
    moreover
    from ta_hb_consistent_into_non_speculative[OF hb]
    have "non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>)" by(simp add: o_def)
    with Runs red have "hb_completion ?s' (E @ map (Pair ?t) \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>)" by(rule hb_completion_shift1)
    ultimately have ?Step using True
      unfolding complete_hb_def by(fastforce simp del: split_paired_Ex simp add: split_def)
    thus ?thesis ..
  qed
qed

lemma complete_hb_ta_hb_consistent:
  assumes "hb_completion s E"
  and ta_hb_consistent_convert_RA: "\<And>E t ln. ta_hb_consistent P E (llist_of (map (Pair t) (convert_RA ln)))"
  shows "ta_hb_consistent P E (lconcat (lmap (\<lambda>(t, ta). llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) (complete_hb s E)))"
  (is "ta_hb_consistent _ _ (?obs (complete_hb s E))")
proof -
  def obs \<equiv> "?obs (complete_hb s E)" and a \<equiv> "complete_hb s E"
  with `hb_completion s E` have "\<exists>s. hb_completion s E \<and> obs = ?obs (complete_hb s E) \<and> a = complete_hb s E" by blast
  moreover have "wf (inv_image {(m, n). m < n} (llength \<circ> ltakeWhile (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> = [])))"
    (is "wf ?R") by(rule wf_inv_image)(rule wellorder_class.wf)
  ultimately show "ta_hb_consistent P E obs"
  proof(coinduct E obs a rule: ta_hb_consistent_coinduct_append_wf)
    case (ta_hb_consistent E obs a)
    then obtain s where hb_c: "hb_completion s E"
      and obs: "obs = lconcat (lmap (\<lambda>(t, ta). llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) (complete_hb s E))"
      and a: "a = complete_hb s E"
      by blast
    let ?P = "\<lambda>((t, ta), s'). s -t\<triangleright>ta\<rightarrow> s' \<and> ta_hb_consistent P E (llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>))"
    show ?case
    proof(cases "\<exists>t ta s'. s -t\<triangleright>ta\<rightarrow> s'")
      case False
      with obs have ?LNil by(simp add: complete_hb_def)
      thus ?thesis ..
    next
      case True
      let ?t = "fst (fst (Eps ?P))" and ?ta = "snd (fst (Eps ?P))" and ?s' = "snd (Eps ?P)"
      from True obtain t ta s' where red: "s -t\<triangleright>ta\<rightarrow> s'" by blast
      hence "\<exists>x. ?P x"
      proof(cases)
        case (redT_normal x x' m')
        from hb_completionD[OF hb_c _ _ `thr s t = \<lfloor>(x, no_wait_locks)\<rfloor>` `t \<turnstile> \<langle>x, shr s\<rangle> -ta\<rightarrow> \<langle>x', m'\<rangle>` `actions_ok s t ta`, of "[]" 0]
        obtain ta' x'' m'' where "t \<turnstile> \<langle>x, shr s\<rangle> -ta'\<rightarrow> \<langle>x'', m''\<rangle>"
          and "actions_ok s t ta'" "ta_hb_consistent P E (llist_of (map (Pair t) \<lbrace>ta'\<rbrace>\<^bsub>o\<^esub>))"
          by fastforce
        moreover obtain ws' where "redT_updWs t (wset s) \<lbrace>ta'\<rbrace>\<^bsub>w\<^esub> ws'" by (metis redT_updWs_total)
        ultimately show ?thesis using `thr s t = \<lfloor>(x, no_wait_locks)\<rfloor>`
          by(cases ta')(auto intro!: exI redT.redT_normal)
      next
        case (redT_acquire x ln n)
        thus ?thesis using ta_hb_consistent_convert_RA[of E t ln]
          by(auto intro!: exI redT.redT_acquire)
      qed
      hence "?P (Eps ?P)" by(rule someI_ex)
      hence red': "s -?t\<triangleright>?ta\<rightarrow> ?s'"
        and hb: "ta_hb_consistent P E (llist_of (map (Pair ?t) \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>))"
        by(simp_all add: split_beta)
      moreover
      from ta_hb_consistent_into_non_speculative[OF hb]
      have "non_speculative P (w_values P (\<lambda>_. {}) (map snd E)) (llist_of \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>)" by(simp add: o_def)
      with hb_c red' have hb_c': "hb_completion ?s' (E @ map (Pair ?t) \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>)"
        by(rule hb_completion_shift1)
      show ?thesis
      proof(cases "lnull obs")
        case True thus ?thesis unfolding lnull_def by simp
      next
        case False
        have eq: "(\<forall>t ta s'. \<not> s -t\<triangleright>ta\<rightarrow> s') = False" using True by auto
        { assume "\<lbrace>?ta\<rbrace>\<^bsub>o\<^esub> = []"
          moreover from obs False
          have "lfinite (ltakeWhile (\<lambda>(t, ta). \<lbrace>ta\<rbrace>\<^bsub>o\<^esub> = []) (complete_hb s E))"
            unfolding lfinite_ltakeWhile by(fastforce simp add: split_def lconcat_eq_LNil)
          ultimately have "(complete_hb ?s' (E @ map (Pair ?t) \<lbrace>?ta\<rbrace>\<^bsub>o\<^esub>), a) \<in> ?R"
            using red unfolding a complete_hb_def
            apply(subst (2) unfold_llist.code)
            apply(subst (asm) unfold_llist.code)
            apply(auto simp add: split_beta simp del: split_paired_Ex split_paired_All split: split_if_asm)
            apply(auto simp add: lfinite_eq_range_llist_of)
            done }
        hence ?lappend using red hb hb_c' unfolding obs complete_hb_def
          apply(subst unfold_llist.code)
          apply(simp add: split_beta eq del: split_paired_Ex split_paired_All split del: split_if)
          apply(intro exI conjI impI refl disjI1|rule refl|assumption|simp_all add: llist_of_eq_LNil_conv)+
          done
        thus ?thesis ..
      qed
    qed
  qed
qed

lemma hb_completion_Runs:
  assumes "hb_completion s E"
  and "\<And>E t ln. ta_hb_consistent P E (llist_of (map (Pair t) (convert_RA ln)))"
  shows "\<exists>ttas. mthr.Runs s ttas \<and> ta_hb_consistent P E (lconcat (lmap (\<lambda>(t, ta). llist_of (map (Pair t) \<lbrace>ta\<rbrace>\<^bsub>o\<^esub>)) ttas))"
using complete_hb_in_Runs[OF assms] complete_hb_ta_hb_consistent[OF assms]
by blast

end

end