theory LaunchburyAddBH
imports LaunchburyCombinedTaggedMap
begin

nominal_primrec varOf :: "exp \<Rightarrow> var option" where
  "varOf (Var x) = Some x" |
  "varOf (Lam [_]. _) = None" |
  "varOf (App e x) = None" |
  "varOf (Let as body) = None"
  unfolding eqvt_def varOf_graph_aux_def
  apply (rule)
  apply simp_all
  apply (metis exp_assn.exhaust(1))
  done
termination (eqvt) by lexicographic_order

nominal_primrec dep :: "exp \<Rightarrow> var option" where
  "dep (Var x) = Some x" |
  "dep (App e y) = varOf e" |
  "dep (Lam [_]. _) = None" |
  "dep (Let as body) = None"
  unfolding eqvt_def dep_graph_aux_def
  apply (rule)
  apply simp_all
  apply (metis exp_assn.exhaust(1))
  done
termination (eqvt) by lexicographic_order

lemma isLam_dep[simp]: "isLam e \<Longrightarrow> dep e = None"
  by (cases e rule: exp_assn.exhaust(1)) auto

fun depRel :: "Heap \<Rightarrow> var \<Rightarrow> var \<Rightarrow> bool" where
  "depRel \<Gamma> x y \<longleftrightarrow> Option.bind (lookup \<Gamma> x) dep = Some y"

lemma depRel_cong':
  "lookup \<Delta> a = lookup \<Gamma> a \<Longrightarrow> depRel \<Gamma> a b \<Longrightarrow> depRel \<Delta> a b"
  by auto

lemma depRel_cong:
  "lookup \<Gamma> a = lookup \<Delta> a \<Longrightarrow> depRel \<Gamma> a b = depRel \<Delta> a b"
  by auto

lemma depRel_fmap_upd[simp]: "depRel (\<Gamma>(x f\<mapsto>  e)) x y \<longleftrightarrow> dep e = Some y"
  by auto

lemma depRel_fmap_upd_Not[simp]: "a \<noteq> x \<Longrightarrow> depRel (\<Gamma>(x f\<mapsto> e)) a b \<longleftrightarrow> depRel \<Gamma> a b"
  by simp

lemma depRel_dom: "depRel \<Gamma> y x \<Longrightarrow> y \<in> fdom \<Gamma>"
  by (metis depRel.simps bind_lzero fdomIff option.distinct(1))

lemma depRelTransDom:
  "(depRel \<Gamma>)\<^sup>+\<^sup>+ a b \<Longrightarrow> a \<in> fdom \<Gamma>"
  by (metis (full_types) depRel_dom tranclpD)

lemma depRel_fmap_upd_trans[simp]: "lookup \<Gamma> x = Some e \<Longrightarrow> dep e = None \<Longrightarrow> (depRel \<Gamma>)\<^sup>+\<^sup>+ x y \<longleftrightarrow> False"
  by (auto elim: tranclp_induct)

definition cycle where "cycle \<Gamma> x \<longleftrightarrow> (depRel \<Gamma>)\<^sup>+\<^sup>+ x x"

lemma lookup_eq_split: "lookup (f(a f\<mapsto> b)) x = Some r \<longleftrightarrow> ((x = a \<and> r = b) \<or> (x \<noteq> a \<and> lookup f x = Some r))"
  by transfer auto

lemma varOf_Some[dest!]: "varOf e = Some b \<Longrightarrow> e = Var b"
  by (cases e rule:exp_assn.exhaust(1)) auto

lemma depRelAppE:
  "depRel (\<Gamma>(x f\<mapsto> App e y)) a b \<Longrightarrow> x = a \<and> e = Var b \<or> x \<noteq> a \<and> depRel \<Gamma> a b"
  by (cases "x=a") auto

lemma depRelTransIndirect:
  assumes "(depRel (\<Gamma>(x f\<mapsto> App e y)))\<^sup>+\<^sup>+ a b"
  assumes "atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)"
  shows "(depRel (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)))\<^sup>+\<^sup>+  a b"
using assms
proof (induction rule:tranclp_trans_induct[consumes 1, case_names base step])
  case (base a b)
  note depRel_dom[OF `depRel (\<Gamma>(x f\<mapsto> App e y)) a b`]
  with `atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)`
  have "n \<noteq> a"  by (metis fresh_fdom)

  from depRelAppE[OF base(1)]
  show ?case
  proof(elim conjE disjE)
    assume "x = a" and "e = Var b"

    have "(depRel (\<Gamma>(a f\<mapsto> App (Var n) y)(n f\<mapsto> Var b)))\<^sup>+\<^sup>+ a n" using `n \<noteq> a` by auto
    also
    have "(depRel (\<Gamma>(a f\<mapsto> App (Var n) y)(n f\<mapsto> Var b)))\<^sup>+\<^sup>+ n b" by auto
    finally
    show ?thesis unfolding `x = a` `e = Var b`.
  next
    assume "x \<noteq> a " and "depRel \<Gamma> a b"  thus ?thesis using `n \<noteq> a` by auto
  qed
  next
  case (step a b c)
    thus ?case by auto
qed

lemma cycleIndirect:
  assumes "cycle (\<Gamma>(x f\<mapsto> App e y)) z"
  assumes "atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)"
  shows "cycle (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) z"
by (metis depRelTransIndirect cycle_def assms)

inductive validStack :: "Heap \<Rightarrow> var \<Rightarrow> var list \<Rightarrow> bool"
  for \<Gamma> where
    ValidStackNil: "validStack \<Gamma> x []"
  | ValidStackCons: "(depRel \<Gamma>)\<^sup>+\<^sup>+ y x \<Longrightarrow> validStack \<Gamma> y S \<Longrightarrow> validStack \<Gamma> x (y#S)"

lemma validStackIndirect:
  "validStack (\<Gamma>(x f\<mapsto> App e y)) z S \<Longrightarrow> atom n \<sharp> \<Gamma>(x f\<mapsto> App e y) \<Longrightarrow>
  validStack (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) z S"
by (induction z S rule:validStack.induct)
   (auto intro: ValidStackNil ValidStackCons depRelTransIndirect)

lemma depRel_unique:
  "depRel \<Gamma> a b \<Longrightarrow> depRel \<Gamma> a c \<Longrightarrow> b = c"
  by (auto elim!: depRel.cases)

lemma validStack_to_top:
  "validStack \<Gamma> x S \<Longrightarrow> y \<in> set S \<Longrightarrow> (depRel \<Gamma>)\<^sup>+\<^sup>+ y x"
by (induction x S rule:validStack.induct) auto

lemma validStack_cycle:
  "validStack \<Gamma> x S \<Longrightarrow> x \<in> set S \<Longrightarrow> cycle \<Gamma> x"
by (metis validStack_to_top cycle_def)

lemma depRel_via:
  assumes "(depRel \<Gamma>)\<^sup>+\<^sup>+ a z"
  assumes "depRel \<Gamma> a b"
  shows   "b = z \<or> (depRel \<Gamma>)\<^sup>+\<^sup>+ b z"
using assms
by (induction a z rule:tranclp_trans_induct[consumes 1, case_names base step])
   (auto dest: depRel_unique tranclp_trans)

lemma validStack_cong:
  assumes "validStack \<Gamma> z S"
  assumes cong: "\<And> x. (depRel \<Gamma>)\<^sup>+\<^sup>+ x z \<Longrightarrow> lookup \<Gamma> x = lookup \<Delta> x"
  shows  "validStack \<Delta> z S"
using assms
proof(induction z S rule:validStack.induct)
  case (ValidStackNil y) thus ?case by (intro validStack.intros)
next
  case (ValidStackCons y x S)
  from `(depRel \<Gamma>)\<^sup>+\<^sup>+ y x` ValidStackCons.prems
  have "(depRel \<Delta>)\<^sup>+\<^sup>+ y x"
  proof (induction y x rule:tranclp_trans_induct[consumes 1, case_names base step])
    case (base x' y)
    hence "lookup \<Gamma> x' = lookup \<Delta> x'" by auto
    with base(1)
    have "depRel \<Delta> x' y" by (simp cong: depRel_cong)
    thus ?case by auto
  next
    case step thus ?case by (metis tranclp_trans)
  qed
  moreover
  have "validStack \<Delta> y S"
  proof(rule ValidStackCons.IH)
    fix x'
    assume "(depRel \<Gamma>)\<^sup>+\<^sup>+ x' y" with `(depRel \<Gamma>)\<^sup>+\<^sup>+ y x`
    have "(depRel \<Gamma>)\<^sup>+\<^sup>+ x' x" by auto
    thus " lookup \<Gamma> x' = lookup \<Delta> x'"
      by (rule ValidStackCons)
  qed
  ultimately
  show "validStack \<Delta> x (y # S)"
    by (rule validStack.intros)
qed

lemma cycle_depRel:
  assumes "cycle \<Gamma> x"
  assumes "depRel \<Gamma> x n"
  shows "cycle \<Gamma> n"
by (metis assms depRel_via cycle_def tranclp.simps)

theorem
  assumes "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>x#S\<^esub> \<Delta>"
  assumes "validStack \<Gamma> x S"
  shows "\<not> cycle \<Gamma> x" and  "validStack \<Delta> x S"
   and add_blackholing: "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>\<surd>\<^bsub>x#S\<^esub> \<Delta>"
  (* The third conclusion does not need the others, but inductive proofs compose so badly. *)
using assms
proof(induction \<Gamma> i u b "x#S" \<Delta> arbitrary: x S rule:reds.induct )
case (Lambda \<Gamma> x y e i u b S)
  case 1 show ?case by (auto simp add: cycle_def)
  case 2 thus ?case .
  case 3 show ?case using Lambda by (rule reds.Lambda)
next
case (Application n \<Gamma> x e y S \<Theta> z \<Delta> e' u b)
  case 2
    from Application(1) have "n \<noteq> x"  "n \<notin> set S"
      by (simp_all add: fresh_Pair fresh_at_base fresh_at_base_list)
    hence "(depRel (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)))\<^sup>+\<^sup>+ x n" by auto
    moreover
    from Application(1) have "atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)"
      by (simp add: fresh_Pair fresh_fmap_upd_eq fresh_fmap_delete_subset)
    with `validStack (\<Gamma>(x f\<mapsto> App e y)) x S`
    have "validStack (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) x S" by (rule validStackIndirect)
    ultimately
    have IH1: "validStack (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) n (x # S)"  by (rule ValidStackCons)
    hence "validStack \<Delta> n (x # S)" by (rule Application.hyps)
    hence "validStack \<Delta> x S" by (cases)
    hence IH2: "validStack ((fmap_delete n \<Delta>)(x f\<mapsto> e'[z::=y])) x S"
    proof(rule validStack_cong)
      from stack_unchanged[OF Application.hyps(8)[OF IH1]] `n \<noteq> x`
      have "lookup \<Delta> x = Some (App (Var n) y)"  by auto
      hence "depRel \<Delta> x n" by auto

      fix x'
      assume "(depRel \<Delta>)\<^sup>+\<^sup>+ x' x"
      moreover
      from `lookup \<Delta> n = Some (Lam [z]. e')`
      have "\<not> (depRel \<Delta>)\<^sup>+\<^sup>+ n x" by auto
      moreover
      hence "\<not> (depRel \<Delta>)\<^sup>+\<^sup>+ x x" using `depRel \<Delta> x n`
        by (metis depRel_via)
      ultimately
      have "x' \<noteq> x" "x' \<noteq> n" by auto
      thus "lookup \<Delta> x' = lookup (fmap_delete n \<Delta>(x f\<mapsto> e'[z::=y])) x'" by simp
    qed
    thus "validStack \<Theta> x S"
      by (rule Application.hyps)
  case 1
    from Application.hyps(6)[OF IH1]
    show ?case
    proof(rule contrapos_nn)
      assume "cycle (\<Gamma>(x f\<mapsto> App e y)) x"
      hence "cycle (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) x"
        by (rule cycleIndirect[OF _ `atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)`])
      thus "cycle (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) n" using `n \<noteq> x`  by (auto elim!: cycle_depRel)
    qed
  case 3
    from Application.hyps(1,2,3,4)
         Application.hyps(8)[OF IH1]
         Application.hyps(12)[OF IH2]
    show ?case by (rule reds.Application)
next
case (ApplicationInd n \<Gamma> x e y S z \<Delta> e' u b \<Theta>)
case 2
    from ApplicationInd(1) have "n \<noteq> x" by (simp add: fresh_Pair fresh_at_base)
    hence "(depRel (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)))\<^sup>+\<^sup>+ x n" by auto
    moreover
    from ApplicationInd(1) have "atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)"
      by (simp add: fresh_Pair fresh_fmap_upd_eq fresh_fmap_delete_subset)
    with `validStack (\<Gamma>(x f\<mapsto> App e y)) x S`
    have "validStack (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) x S" by (rule validStackIndirect)
    ultimately
    have IH1: "validStack (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) n (x # S)"  by (rule ValidStackCons)
    hence "validStack \<Delta> n (x # S)" by (rule ApplicationInd.hyps)
    hence "validStack \<Delta> x S" by (cases)
    hence IH2: "validStack (\<Delta>(z f\<mapsto> Var y)(x f\<mapsto> e')) x S"
    proof(rule validStack_cong)
      from stack_unchanged[OF ApplicationInd.hyps(8)[OF IH1]] `n \<noteq> x`
      have "depRel \<Delta> x n" by auto

      fix x'
      assume as: "(depRel \<Delta>)\<^sup>+\<^sup>+ x' x"
      moreover
      from `lookup \<Delta> n = Some (Lam [z]. e')`
      have "\<not> (depRel \<Delta>)\<^sup>+\<^sup>+ n x" by auto
      moreover
      hence "\<not> (depRel \<Delta>)\<^sup>+\<^sup>+ x x" using `depRel \<Delta> x n`
        by (metis depRel_via)
      ultimately
      have "x' \<noteq> x" "x' \<noteq> n" by auto
      moreover
      from as `x' \<noteq> n`
      have "x' \<in> fdom \<Delta>" by (metis (hide_lams, no_types) converse_tranclpE depRel_dom)
      with ApplicationInd(2)
      have "x' \<noteq> z" by (auto simp add: fresh_Pair)
      ultimately
      show "lookup \<Delta> x' =  lookup (\<Delta>(z f\<mapsto> Var y)(x f\<mapsto> e')) x'" by simp
    qed
    thus "validStack \<Theta> x S"
      by (rule ApplicationInd.hyps)
  case 1
    from ApplicationInd.hyps(6)[OF IH1]
    show ?case
    proof(rule contrapos_nn)
      assume "cycle (\<Gamma>(x f\<mapsto> App e y)) x"
      hence "cycle (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) x"
        by (rule cycleIndirect[OF _ `atom n \<sharp> \<Gamma>(x f\<mapsto> App e y)`])
      thus "cycle (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e)) n" using `n \<noteq> x`
        by (auto elim!: cycle_depRel)
    qed
  case 3
    from ApplicationInd.hyps(1-4)
         ApplicationInd.hyps(8)[OF IH1]
         ApplicationInd.hyps(12)[OF IH2]
    show ?case by (rule reds.ApplicationInd)
next
case (Variable y x S \<Gamma> i \<Delta>)
  hence "y \<noteq> x" by simp

  have "(depRel (\<Gamma>(x f\<mapsto> Var y)))\<^sup>+\<^sup>+ x y" by auto
  moreover
  assume "validStack (\<Gamma>(x f\<mapsto> Var y)) x S"
  ultimately
  have "validStack (\<Gamma>(x f\<mapsto> Var y)) y (x # S)"
    by (rule ValidStackCons)
  note hyps = Variable(4-6)[OF this]

  from stack_unchanged[OF hyps(3)] `y \<noteq> x`
  have "lookup \<Delta> x = Some (Var y)" by simp
  hence "depRel \<Delta> x y" by auto

  from result_evaluated[OF hyps(3)]
  have "isLam (\<Delta> f! y)" by simp
  hence "\<not> Domainp (depRel \<Delta>) y" apply auto by (metis bind_lunit bind_lzero isLam_dep not_None_eq the.simps)

  from `validStack \<Delta> y (x # S)`
  have "validStack \<Delta> x S" by cases
  thus "validStack (fmap_copy \<Delta> y x) x S"
  proof (rule validStack_cong)
    fix x'
    assume "(depRel \<Delta>)\<^sup>+\<^sup>+ x' x"
    moreover
    from `\<not> Domainp (depRel \<Delta>) y`
    have " \<not>(depRel \<Delta>)\<^sup>+\<^sup>+ y x" by (metis Domainp.DomainI converse_tranclpE)
    hence " \<not>(depRel \<Delta>)\<^sup>+\<^sup>+ x x" using `depRel \<Delta> x y` by (metis depRel_via)
    ultimately
    have "x' \<noteq> x" by auto
    thus "lookup \<Delta> x' = lookup (fmap_copy \<Delta> y x) x'" by simp
  qed

  from hyps(1)
  show "\<not> cycle (\<Gamma>(x f\<mapsto> Var y)) x"
    by (auto elim!: contrapos_nn cycle_depRel)

  from Variable(1-3)
  show "\<Gamma>(x f\<mapsto> Var y) \<Down>\<^sup>i\<^sup>\<surd>\<^sup>\<surd>\<^bsub>x # S\<^esub> fmap_copy \<Delta> y x"
    by (rule reds.Variable)
next
case (VariableNoBH x \<Gamma> y i S \<Delta>)
  have "(depRel (\<Gamma>(x f\<mapsto> Var y)))\<^sup>+\<^sup>+ x y" by auto
  moreover
  assume "validStack (\<Gamma>(x f\<mapsto> Var y)) x S"
  ultimately
  have "validStack (\<Gamma>(x f\<mapsto> Var y)) y (x # S)"
    by (rule ValidStackCons)
  note hyps = VariableNoBH(3-5)[OF this]

  from hyps(1) `(depRel (\<Gamma>(x f\<mapsto> Var y)))\<^sup>+\<^sup>+ x y`
  have "y \<noteq> x" by (auto simp add: cycle_def)

  from stack_unchanged[OF hyps(3)] `y \<noteq> x`
  have "lookup \<Delta> x = Some (Var y)" by simp
  hence "depRel \<Delta> x y" by auto

  from result_evaluated[OF hyps(3)]
  have "isLam (\<Delta> f! y)" by simp
  hence "\<not> Domainp (depRel \<Delta>) y" apply auto by (metis bind_lunit bind_lzero isLam_dep not_None_eq the.simps)

  from `validStack \<Delta> y (x # S)`
  have "validStack \<Delta> x S" by cases
  thus "validStack (fmap_copy \<Delta> y x) x S"
  proof (rule validStack_cong)
    fix x'
    assume "(depRel \<Delta>)\<^sup>+\<^sup>+ x' x"
    moreover
    from `\<not> Domainp (depRel \<Delta>) y`
    have " \<not>(depRel \<Delta>)\<^sup>+\<^sup>+ y x" by (metis Domainp.DomainI converse_tranclpE)
    hence " \<not>(depRel \<Delta>)\<^sup>+\<^sup>+ x x" using `depRel \<Delta> x y` by (metis depRel_via)
    ultimately
    have "x' \<noteq> x" by auto
    thus "lookup \<Delta> x' = lookup (fmap_copy \<Delta> y x) x'" by simp
  qed

  from hyps(1)
  show "\<not> cycle (\<Gamma>(x f\<mapsto> Var y)) x"
    by (auto elim!: contrapos_nn cycle_depRel)

  from hyps(1) `validStack (\<Gamma>(x f\<mapsto> Var y)) y (x#S)`
  have "y \<notin> set (x # S)"
    by (metis validStack_cycle)

  from this VariableNoBH.hyps(1) hyps(3)
  show "\<Gamma>(x f\<mapsto> Var y) \<Down>\<^sup>i\<^sup>\<surd>\<^sup>\<surd>\<^bsub>x # S\<^esub> fmap_copy \<Delta> y x"
    by (rule reds.Variable)
next
case (Let as \<Gamma> x S body i u b \<Delta>)
  assume "validStack (\<Gamma>(x f\<mapsto> Terms.Let as body)) x S"

  hence "validStack (\<Gamma>(x f\<mapsto> body) f++ fmap_of (asToHeap as)) x S"
  proof (rule validStack_cong)
    fix x'
    assume as: "(depRel (\<Gamma>(x f\<mapsto> Terms.Let as body)))\<^sup>+\<^sup>+ x' x"
    hence "x' \<noteq> x" by auto
    with as have "x' \<in> fdom \<Gamma>"
      by (auto dest:depRelTransDom)
    with Let(1)
    have "atom x' \<notin> set (bn as)" by (auto simp add: fresh_star_def fresh_Pair)
    hence  "x' \<notin> fdom (fmap_of (asToHeap as))"
      by (metis (full_types) fdom_fmap_of_conv_heapVars imageI set_bn_to_atom_heapVars)
    with `x' \<noteq> x`
    show "lookup (\<Gamma>(x f\<mapsto> Terms.Let as body)) x' =
        lookup (\<Gamma>(x f\<mapsto> body) f++ fmap_of (asToHeap as)) x'"
        by simp
  qed
  note hyps = Let(4-6)[OF this]

  case 1
  show ?case by (auto simp add: cycle_def)

  case 2
  from hyps(2)
  show ?case.

  case 3
  note Let(1-2) hyps(3)
  thus ?case..
qed

lemma remove_blackholing:
  assumes "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>\<surd>\<^bsub>S\<^esub> \<Delta>"
  shows "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>S\<^esub> \<Delta>"
using assms
apply (cases b, simp)
apply (induction \<Gamma> i u "\<surd>" S \<Delta> rule:reds.induct )
apply (blast intro:reds.intros)+
done

lemma second_stack_element_unchanged:
  assumes "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>x#y#S\<^esub> \<Delta>"
  assumes "x \<noteq> y"
  assumes "depRel \<Gamma> y x"
  shows "lookup \<Delta> y = lookup \<Gamma> y"
proof-
  from shorten_stack[OF assms(1), where n = 1]
  have "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>[x,y]\<^esub> \<Delta>" by simp
  moreover
  from assms(3)
  have "validStack \<Gamma> x [y]" by (fastforce intro: validStack.intros)
  ultimately
  have "\<Gamma> \<Down>\<^sup>i\<^sup>u\<^sup>\<surd>\<^bsub>[x,y]\<^esub> \<Delta>" by (rule add_blackholing)
  from stack_unchanged[OF this, where x = y] assms(2)
  show ?thesis by auto
qed

lemma Application_x_unchanged:
  assumes "\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e) \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>n # x # S\<^esub> \<Delta>"
  and "n \<noteq> x"
  shows "lookup \<Delta> x = Some (App (Var n) y)"
  using second_stack_element_unchanged[OF assms] assms(2) by auto

lemma var_not_self:
  shows  "\<not> (\<Gamma>(x f\<mapsto> Var x) \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>x # S\<^esub> \<Delta>)"
proof
  assume "\<Gamma>(x f\<mapsto> Var x) \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>x # S\<^esub> \<Delta>"
  from shorten_stack[OF this, where n = 0]
  have "\<Gamma>(x f\<mapsto> Var x) \<Down>\<^sup>i\<^sup>u\<^sup>b\<^bsub>[x]\<^esub> \<Delta>" by simp
  hence "\<Gamma>(x f\<mapsto> Var x) \<Down>\<^sup>i\<^sup>u\<^sup>\<surd>\<^bsub>[x]\<^esub> \<Delta>" by (rule add_blackholing[OF _ ValidStackNil])
  thus False  by cases (auto dest: fmap_upd_eqD1)
qed

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoarePartial.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>Derived Hoare Rules for Partial Correctness\<close>

theory HoarePartial imports HoarePartialProps begin

lemma conseq_no_aux:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A';
    \<forall>s. s \<in> P \<longrightarrow> (s\<in>P' \<and> (Q' \<subseteq> Q) \<and> (A' \<subseteq> A))\<rbrakk>
  \<Longrightarrow>
  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where P'="\<lambda>Z. P'" and Q'="\<lambda>Z. Q'" and A'="\<lambda>Z. A'"]) auto

lemma conseq_exploit_pre:
             "\<lbrakk>\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s} \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (rule Conseq)
  apply clarify
  apply (rule_tac x="{s} \<inter> P" in exI)
  apply (rule_tac x="Q" in exI)
  apply (rule_tac x="A" in exI)
  by simp

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq') blast

lemma Lem: "\<lbrakk>\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
             P \<subseteq> {s. \<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)}\<rbrakk>
             \<Longrightarrow>
             \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (lem x c) Q,A"
  apply (unfold lem_def)
  apply (erule conseq)
  apply blast
  done

lemma LemAnno:
assumes conseq:  "P \<subseteq> {s. \<exists>Z. s\<in>P' Z \<and>
                     (\<forall>t. t \<in> Q' Z \<longrightarrow> t \<in> Q) \<and> (\<forall>t. t \<in> A' Z \<longrightarrow> t \<in> A)}"
assumes lem: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (lem x c) Q,A"
  apply (rule Lem [OF lem])
  using conseq
  by blast

lemma LemAnnoNoAbrupt:
assumes conseq:  "P \<subseteq>  {s. \<exists>Z. s\<in>P' Z \<and> (\<forall>t. t \<in> Q' Z \<longrightarrow> t \<in> Q)}"
assumes lem: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),{}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (lem x c) Q,{}"
  apply (rule Lem [OF lem])
  using conseq
  by blast

lemma TrivPost: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)
                 \<Longrightarrow>
                 \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c UNIV,UNIV"
apply (rule allI)
apply (erule conseq)
apply auto
done

lemma TrivPostNoAbr: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),{}
                 \<Longrightarrow>
                 \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c UNIV,{}"
apply (rule allI)
apply (erule conseq)
apply auto
done

lemma conseq_under_new_pre:"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P' c Q',A';
        \<forall>s \<in> P. s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A\<rbrakk>
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A"
apply (rule conseq)
apply (rule allI)
apply assumption
apply auto
done

lemma DynComConseq:
  assumes "P \<subseteq> {s. \<exists>P' Q' A'.  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P' (c s) Q',A' \<and> P \<subseteq> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P DynCom c Q,A"
  using assms
  apply -
  apply (rule DynCom)
  apply clarsimp
  apply (rule Conseq)
  apply clarsimp
  apply blast
  done

lemma SpecAnno:
 assumes consequence: "P \<subseteq> {s. (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))}"
 assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),(A' Z)"
 assumes bdy_constant:  "\<forall>Z. c Z = c undefined"
 shows   "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (specAnno P' c Q' A') Q,A"
proof -
  from spec bdy_constant
  have "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ((P' Z)) (c undefined) (Q' Z),(A' Z)"
    apply -
    apply (rule allI)
    apply (erule_tac x=Z in allE)
    apply (erule_tac x=Z in allE)
    apply simp
    done
  with consequence show ?thesis
    apply (simp add: specAnno_def)
    apply (erule conseq)
    apply blast
    done
qed

lemma SpecAnno':
 "\<lbrakk>P \<subseteq> {s.  \<exists> Z. s\<in>P' Z \<and>
            (\<forall>t. t \<in> Q' Z \<longrightarrow>  t \<in> Q) \<and> (\<forall>t. t \<in> A' Z \<longrightarrow> t \<in>  A)};
   \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),(A' Z);
   \<forall>Z. c Z = c undefined
  \<rbrakk> \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (specAnno P' c Q' A') Q,A"
apply (simp only: subset_iff [THEN sym])
apply (erule (1) SpecAnno)
apply assumption
done

lemma SpecAnnoNoAbrupt:
 "\<lbrakk>P \<subseteq> {s.  \<exists> Z. s\<in>P' Z \<and>
            (\<forall>t. t \<in> Q' Z \<longrightarrow>  t \<in> Q)};
   \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),{};
   \<forall>Z. c Z = c undefined
  \<rbrakk> \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (specAnno P' c Q' (\<lambda>s. {})) Q,A"
apply (rule SpecAnno')
apply auto
done

lemma Skip: "P \<subseteq> Q \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Skip Q,A"
  by (rule hoarep.Skip [THEN conseqPre],simp)

lemma Basic: "P \<subseteq> {s. (f s) \<in> Q} \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Basic f) Q,A"
  by (rule hoarep.Basic [THEN conseqPre])

lemma BasicCond:
  "\<lbrakk>P \<subseteq> {s. (b s \<longrightarrow> f s\<in>Q) \<and> (\<not> b s \<longrightarrow> g s\<in>Q)}\<rbrakk> \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Basic (\<lambda>s. if b s then f s else g s) Q,A"
  apply (rule Basic)
  apply auto
  done

lemma Spec: "P \<subseteq> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)}
            \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Spec r) Q,A"
by (rule hoarep.Spec [THEN conseqPre])

lemma SpecIf:
  "\<lbrakk>P \<subseteq> {s. (b s \<longrightarrow> f s \<in> Q) \<and> (\<not> b s \<longrightarrow> g s \<in> Q \<and> h s \<in> Q)}\<rbrakk> \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Spec (if_rel b f g h) Q,A"
  apply (rule Spec)
  apply (auto simp add: if_rel_def)
  done

lemma Seq [trans, intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Seq c\<^sub>1 c\<^sub>2) Q,A"
  by (rule hoarep.Seq)

lemma SeqSwap:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c1 R,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Seq c1 c2) Q,A"
  by (rule Seq)

lemma BSeq:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (bseq c\<^sub>1 c\<^sub>2) Q,A"
  by (unfold bseq_def) (rule Seq)

lemma Cond:
  assumes wp: "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof (rule hoarep.Cond [THEN conseqPre])
  from deriv_c1
  show "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. (s \<in> b \<longrightarrow> s \<in> P\<^sub>1) \<and> (s \<notin> b \<longrightarrow> s \<in> P\<^sub>2)} \<inter> b) c\<^sub>1 Q,A"
    by (rule conseqPre) blast
next
  from deriv_c2
  show "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. (s \<in> b \<longrightarrow> s \<in> P\<^sub>1) \<and> (s \<notin> b \<longrightarrow> s \<in> P\<^sub>2)} \<inter> - b) c\<^sub>2 Q,A"
    by (rule conseqPre) blast
next
  show "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}" by (rule wp)
qed

lemma CondSwap:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P1 c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P2 c2 Q,A; P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P1) \<and> (s\<notin>b \<longrightarrow> s\<in>P2)}\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule Cond)

lemma Cond':
  "\<lbrakk>P \<subseteq> {s. (b \<subseteq> P1) \<and> (- b \<subseteq> P2)};\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P1 c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P2 c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule CondSwap) blast+

lemma CondInv:
  assumes wp: "P \<subseteq> Q"
  assumes inv: "Q \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof -
  from wp inv
  have "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
    by blast
  from Cond [OF this deriv_c1 deriv_c2]
  show ?thesis .
qed

lemma CondInv':
  assumes wp: "P \<subseteq> I"
  assumes inv: "I \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes wp': "I \<subseteq> Q"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 I,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 I,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof -
  from CondInv [OF wp inv deriv_c1 deriv_c2]
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) I,A".
  from conseqPost [OF this wp' subset_refl]
  show ?thesis .
qed

lemma switchNil:
  "P \<subseteq> Q \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (switch v []) Q,A"
  by (simp add: Skip)

lemma switchCons:
  "\<lbrakk>P \<subseteq> {s. (v s \<in> V \<longrightarrow> s \<in> P\<^sub>1) \<and> (v s \<notin> V \<longrightarrow> s \<in> P\<^sub>2)};
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P\<^sub>1 c Q,A;
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P\<^sub>2 (switch v vs) Q,A\<rbrakk>
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (switch v ((V,c)#vs)) Q,A"
  by (simp add: Cond)

lemma Guard:
 "\<lbrakk>P \<subseteq> g \<inter> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guard [THEN conseqPre, of _ _ _ _ R])
apply (erule conseqPre)
apply auto
done

lemma GuardSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> g \<inter> R\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule Guard)

lemma Guarantee:
 "\<lbrakk>P \<subseteq> {s. s \<in> g \<longrightarrow> s \<in> R}; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guarantee [THEN conseqPre, of _ _ _ _ _ "{s. s \<in> g \<longrightarrow> s \<in> R}"])
apply   assumption
apply  (erule conseqPre)
apply auto
done

lemma GuaranteeSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> {s. s \<in> g \<longrightarrow> s \<in> R}; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule Guarantee)

lemma GuardStrip:
 "\<lbrakk>P \<subseteq> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guarantee [THEN conseqPre])
apply auto
done

lemma GuardStripSwap:
 "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> R; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule GuardStrip)

lemma GuaranteeStrip:
 "\<lbrakk>P \<subseteq> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule GuardStrip)

lemma GuaranteeStripSwap:
 "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> R; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule GuardStrip)

lemma GuaranteeAsGuard:
 "\<lbrakk>P \<subseteq> g \<inter> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule Guard)

lemma GuaranteeAsGuardSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> g \<inter> R\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (rule GuaranteeAsGuard)

lemma GuardsNil:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards [] c) Q,A"
  by simp

lemma GuardsConsGuaranteeStrip:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P guaranteeStrip f g (guards gs c) Q,A \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards (guaranteeStripPair f g#gs) c) Q,A"
  by (simp add: guaranteeStripPair_def guaranteeStrip_def)

lemma While:
  assumes P_I: "P \<subseteq> I"
  assumes deriv_body: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (I \<inter> b) c I,A"
  assumes I_Q: "I \<inter> -b \<subseteq> Q"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b I V c) Q,A"
proof -
  from deriv_body P_I I_Q
  show ?thesis
    apply (simp add: whileAnno_def)
    apply (erule conseqPrePost [OF HoarePartialDef.While])
    apply simp_all
    done
qed

text \<open>@{term "J"} will be instantiated by tactic with @{term "gs' \<inter> I"} for
  those guards that are not stripped.\<close>
lemma  WhileAnnoG:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards gs
                    (whileAnno  b J V (Seq c (guards gs Skip)))) Q,A
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A"
  by (simp add: whileAnnoG_def whileAnno_def while_def)

text \<open>This form stems from @{term "strip_guards F (whileAnnoG gs b I V c)"}\<close>

lemma WhileAnnoGFix:
assumes whileAnnoFix:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards gs
                (whileAnnoFix  b J V (\<lambda>Z. (Seq (c Z) (guards gs Skip))))) Q,A"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoGFix gs b I V c) Q,A"
  using whileAnnoFix
  by (simp add: whileAnnoGFix_def whileAnnoFix_def while_def)

lemma Bind:
  assumes adapt: "P \<subseteq> {s. s \<in> P' s}"
  assumes c: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) (c (e s)) Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (bind e c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> s \<in> P' Z}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
apply  (rule allI)
apply  (unfold bind_def)
apply  (rule DynCom)
apply  (rule ballI)
apply  simp
apply  (rule conseqPre)
apply   (rule c [rule_format])
apply  blast
using adapt
apply blast
done

lemma Block:
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> init s \<in> P' Z}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold block_def)
apply (rule DynCom)
apply (rule ballI)
apply clarsimp
apply (rule_tac R="{t. return Z t \<in> R Z t}" in SeqSwap )
apply  (rule_tac  P'="\<lambda>Z'. {t. t=Z' \<and> return Z t \<in> R Z t}" and
          Q'="\<lambda>Z'. Q" and A'="\<lambda>Z'. A" in conseq)
prefer 2 apply simp
apply  (rule allI)
apply  (rule DynCom)
apply  (clarsimp)
apply  (rule SeqSwap)
apply   (rule c [rule_format])
apply  (rule Basic)
apply  clarsimp
apply (rule_tac R="{t. return Z t \<in> A}" in Catch)
apply  (rule_tac R="{i. i \<in> P' Z}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule bdy [rule_format])
apply (rule SeqSwap)
apply  (rule Throw)
apply (rule Basic)
apply simp
done

lemma BlockSwap:
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
using adapt bdy c
  by (rule Block)

lemma BlockSpec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes bdy: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold block_def)
apply (rule DynCom)
apply (rule ballI)
apply clarsimp
apply (rule_tac R="{t. return s t \<in> R s t}" in SeqSwap )
apply  (rule_tac  P'="\<lambda>Z'. {t. t=Z' \<and> return s t \<in> R s t}" and
          Q'="\<lambda>Z'. Q" and A'="\<lambda>Z'. A" in conseq)
prefer 2 apply simp
apply  (rule allI)
apply  (rule DynCom)
apply  (clarsimp)
apply  (rule SeqSwap)
apply   (rule c [rule_format])
apply  (rule Basic)
apply  clarsimp
apply (rule_tac R="{t. return s t \<in> A}" in Catch)
apply  (rule_tac R="{i. i \<in> P' Z}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule conseq [OF bdy])
apply  clarsimp
apply  blast
apply (rule SeqSwap)
apply  (rule Throw)
apply (rule Basic)
apply simp
done

lemma Throw: "P \<subseteq> A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Throw Q,A"
  by (rule hoarep.Throw [THEN conseqPre])

lemmas Catch = hoarep.Catch
lemma CatchSwap: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,R\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"
  by (rule hoarep.Catch)

lemma raise: "P \<subseteq> {s. f s \<in> A} \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P raise f Q,A"
  apply (simp add: raise_def)
  apply (rule Seq)
  apply  (rule Basic)
  apply  (assumption)
  apply (rule Throw)
  apply (rule subset_refl)
  done

lemma condCatch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,((b \<inter> R) \<union> (-b \<inter> A));\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
                  \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P condCatch c\<^sub>1 b c\<^sub>2 Q,A"
  apply (simp add: condCatch_def)
  apply (rule Catch)
  apply  assumption
  apply (rule CondSwap)
  apply   (assumption)
  apply  (rule hoarep.Throw)
  apply blast
  done

lemma condCatchSwap: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A;\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,((b \<inter> R) \<union> (-b \<inter> A))\<rbrakk>
                  \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P condCatch c\<^sub>1 b c\<^sub>2 Q,A"
  by (rule condCatch)

lemma ProcSpec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
using adapt c p
apply (unfold call_def)
by (rule BlockSpec)

lemma ProcSpec':
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t \<in> Q' Z. return s t \<in> R s t) \<and>
                             (\<forall>t \<in> A' Z. return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (rule ProcSpec [OF _ c p])
apply (insert adapt)
apply clarsimp
apply (drule (1) subsetD)
apply (clarsimp)
apply (rule_tac x=Z in exI)
apply blast
done

lemma ProcSpecNoAbrupt:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (rule ProcSpec [OF _ c p])
using adapt
apply simp
done

lemma FCall:
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return (\<lambda>s t. c (result t))) Q,A
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (fcall init p return result c) Q,A"
  by (simp add: fcall_def)

lemma ProcRec:
  assumes deriv_bodies:
   "\<forall>p\<in>Procs.
    \<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>p\<in>Procs. \<Union>Z. {(P p Z,p,Q p Z,A p Z)})
        \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes Procs_defined: "Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>Procs. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  by (intro strip)
     (rule CallRec'
     [OF _   Procs_defined deriv_bodies],
     simp_all)

lemma ProcRec':
  assumes ctxt: "\<Theta>' = \<Theta>\<union>(\<Union>p\<in>Procs. \<Union>Z. {(P p Z,p,Q p Z,A p Z)})"
  assumes deriv_bodies:
   "\<forall>p\<in>Procs. \<forall>Z. \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes Procs_defined: "Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>Procs. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  using ctxt deriv_bodies
  apply simp
  apply (erule ProcRec [OF _ Procs_defined])
  done

lemma ProcRecList:
  assumes deriv_bodies:
   "\<forall>p\<in>set Procs.
    \<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>p\<in>set Procs. \<Union>Z. {(P p Z,p,Q p Z,A p Z)})
        \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes dist: "distinct Procs"
  assumes Procs_defined: "set Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>set Procs. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  using deriv_bodies Procs_defined
  by (rule ProcRec)

lemma  ProcRecSpecs:
  "\<lbrakk>\<forall>(P,p,Q,A) \<in> Specs. \<Gamma>,\<Theta>\<union>Specs\<turnstile>\<^bsub>/F\<^esub> P (the (\<Gamma> p)) Q,A;
    \<forall>(P,p,Q,A) \<in> Specs. p \<in> dom \<Gamma>\<rbrakk>
  \<Longrightarrow> \<forall>(P,p,Q,A) \<in> Specs. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"
apply (auto intro: CallRec)
done

lemma ProcRec1:
  assumes deriv_body:
   "\<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>Z. {(P Z,p,Q Z,A Z)})\<turnstile>\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
  assumes p_defined: "p \<in> dom \<Gamma>"
  shows "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
proof -
  from deriv_body p_defined
  have "\<forall>p\<in>{p}. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
    by - (rule ProcRec [where A="\<lambda>p. A" and P="\<lambda>p. P" and Q="\<lambda>p. Q"],
          simp_all)
  thus ?thesis
    by simp
qed

lemma ProcNoRec1:
  assumes deriv_body:
   "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
  assumes p_def: "p \<in> dom \<Gamma>"
  shows "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
proof -
from deriv_body
  have "\<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>Z. {(P Z,p,Q Z,A Z)})
             \<turnstile>\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
    by (blast intro: hoare_augment_context)
  from this p_def
  show ?thesis
    by (rule ProcRec1)
qed

lemma ProcBody:
 assumes WP: "P \<subseteq> P'"
 assumes deriv_body: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' body Q,A"
 assumes body: "\<Gamma> p = Some body"
 shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Call p Q,A"
apply (rule conseqPre [OF _ WP])
apply (rule ProcNoRec1 [rule_format, where P="\<lambda>Z. P'" and Q="\<lambda>Z. Q" and A="\<lambda>Z. A"])
apply  (insert body)
apply  simp
apply  (rule hoare_augment_context [OF deriv_body])
apply  blast
apply fastforce
done

lemma CallBody:
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) body {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes body: "\<Gamma> p = Some body"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (unfold call_def)
apply (rule Block [OF adapt _ c])
apply (rule allI)
apply (rule ProcBody [where \<Gamma>=\<Gamma>, OF _ bdy [rule_format] body])
apply simp
done

lemmas ProcModifyReturn = HoarePartialProps.ProcModifyReturn
lemmas ProcModifyReturnSameFaults = HoarePartialProps.ProcModifyReturnSameFaults

lemma ProcModifyReturnNoAbr:
  assumes spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return' c) Q,A"
  assumes result_conform:
      "\<forall>s t. t \<in> Modif (init s) \<longrightarrow> (return' s t) = (return s t)"
  assumes modifies_spec:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} Call p (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
by (rule ProcModifyReturn [OF spec result_conform _ modifies_spec]) simp

lemma ProcModifyReturnNoAbrSameFaults:
  assumes spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return' c) Q,A"
  assumes result_conform:
      "\<forall>s t. t \<in> Modif (init s) \<longrightarrow> (return' s t) = (return s t)"
  assumes modifies_spec:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} Call p (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
by (rule ProcModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp

lemma DynProc:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t. t \<in> Q' s Z \<longrightarrow>  return s t \<in> R s t) \<and>
                          (\<forall>t. t \<in> A' s Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>s\<in> P. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P dynCall init p return c Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> s \<in> P}"
  and Q'="\<lambda>Z. Q" and A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold dynCall_def call_def block_def)
apply (rule DynCom)
apply clarsimp
apply (rule DynCom)
apply clarsimp
apply (frule in_mono [rule_format, OF adapt])
apply clarsimp
apply (rename_tac Z')
apply (rule_tac R="Q' Z Z'" in Seq)
apply  (rule CatchSwap)
apply   (rule SeqSwap)
apply    (rule Throw)
apply    (rule subset_refl)
apply   (rule Basic)
apply   (rule subset_refl)
apply  (rule_tac R="{i. i \<in> P' Z Z'}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule_tac Q'="Q' Z Z'" and A'="A' Z Z'" in conseqPost)
using p
apply    clarsimp
apply   simp
apply  clarsimp
apply  (rule_tac  P'="\<lambda>Z''. {t. t=Z'' \<and> return Z t \<in> R Z t}" and
          Q'="\<lambda>Z''. Q" and A'="\<lambda>Z''. A" in conseq)
prefer 2 apply simp
apply (rule allI)
apply (rule DynCom)
apply clarsimp
apply (rule SeqSwap)
apply  (rule c [rule_format])
apply (rule Basic)
apply clarsimp
done

lemma DynProc':
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t \<in> Q' s Z. return s t \<in> R s t) \<and>
                          (\<forall>t \<in> A' s Z. return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>s\<in> P. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P dynCall init p return c Q,A"
proof -
  from adapt have "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t. t \<in> Q' s Z \<longrightarrow>  return s t \<in> R s t) \<and>
                          (\<forall>t. t \<in> A' s Z \<longrightarrow> return s t \<in> A)}"
    by blast
  from this c p show ?thesis
    by (rule DynProc)
qed

lemma DynProcStaticSpec:
assumes adapt: "P \<subseteq> {s. s \<in> S \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>) \<and>
                            (\<forall>\<tau>. \<tau> \<in> A' Z \<longrightarrow> return s \<tau> \<in> A))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>s\<in>S. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from adapt have P_S: "P \<subseteq> S"
    by blast
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> S) (dynCall init p return c) Q,A"
    apply (rule DynProc [where P'="\<lambda>s Z. P' Z" and Q'="\<lambda>s Z. Q' Z"
                         and A'="\<lambda>s Z. A' Z", OF _ c])
    apply  clarsimp
    apply  (frule in_mono [rule_format, OF adapt])
    apply  clarsimp
    using spec
    apply clarsimp
    done
  thus ?thesis
    by (rule conseqPre) (insert P_S,blast)
qed

lemma DynProcProcPar:
assumes adapt: "P \<subseteq> {s. p s = q \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>) \<and>
                            (\<forall>\<tau>. \<tau> \<in> A' Z \<longrightarrow> return s \<tau> \<in> A))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
  apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF adapt c])
  using spec
  apply simp
  done

lemma DynProcProcParNoAbrupt:
assumes adapt: "P \<subseteq> {s. p s = q \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  have "P \<subseteq> {s. p s = q \<and> (\<exists> Z. init s \<in> P' Z \<and>
                      (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                      (\<forall>t. t \<in> {} \<longrightarrow> return s t \<in> A))}"
    (is "P \<subseteq> ?P'")
  proof
    fix s
    assume P: "s\<in>P"
    with adapt obtain Z where
      Pre: "p s = q \<and> init s \<in> P' Z" and
      adapt_Norm: "\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>"
      by blast
    from  adapt_Norm
    have "\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t"
      by auto
    then
    show "s\<in>?P'"
      using Pre by blast
  qed
  note P = this
  show ?thesis
    apply -
    apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF P c])
    apply (insert spec)
    apply auto
    done
qed

lemma DynProcModifyReturnNoAbr:
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>s \<in> P. \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} Call (p s)  (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from ret_nrm_modif
  have "\<forall>s t. t  \<in> (Modif (init s))
        \<longrightarrow> return' s t = return s t"
    by iprover
  then
  have ret_nrm_modif': "\<forall>s t. t \<in> (Modif (init s))
                      \<longrightarrow> return' s t = return s t"
    by simp
  have ret_abr_modif': "\<forall>s t. t \<in> {}
                        \<longrightarrow> return' s t = return s t"
    by simp
  from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis
    by (rule dynProcModifyReturn)
qed

lemma ProcDynModifyReturnNoAbrSameFaults:
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>s \<in> P. \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (Call (p s)) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from ret_nrm_modif
  have "\<forall>s t. t  \<in> (Modif (init s))
        \<longrightarrow> return' s t = return s t"
    by iprover
  then
  have ret_nrm_modif': "\<forall>s t. t \<in> (Modif (init s))
                      \<longrightarrow> return' s t = return s t"
    by simp
  have ret_abr_modif': "\<forall>s t. t \<in> {}
                        \<longrightarrow> return' s t = return s t"
    by simp
  from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis
    by (rule dynProcModifyReturnSameFaults)
qed

lemma ProcProcParModifyReturn:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in
         @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes ret_abr_modif: "\<forall>s t. t \<in> (ModifAbr (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
          "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
       ret_abr_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule dynProcModifyReturn) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnSameFaults:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in
         @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes ret_abr_modif: "\<forall>s t. t \<in> (ModifAbr (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
          "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} Call q (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
       ret_abr_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule dynProcModifyReturnSameFaults) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnNoAbr:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as
      first conjunction in @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule DynProcModifyReturnNoAbr) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnNoAbrSameFaults:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   \<comment>\<open>@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as
      first conjunction in @{term P'}, so the vcg can simplify it.\<close>
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule ProcDynModifyReturnNoAbrSameFaults) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma MergeGuards_iff: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P merge_guards c Q,A = \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto intro: MergeGuardsI MergeGuardsD)

lemma CombineStrip':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c' Q,A"
  assumes deriv_strip_triv: "\<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards (-F) c')"
  assumes c: "merge_guards c = merge_guards (mark_guards False c')"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"
proof -
  from deriv_strip_triv have deriv_strip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
    by (auto intro: hoare_augment_context)
  from deriv_strip [simplified c'']
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P (strip_guards (- F) c') UNIV,UNIV"
    by (rule MarkGuardsD)
  with deriv
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c' Q,A"
    by (rule CombineStrip)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P mark_guards False c' Q,A"
    by (rule MarkGuardsI)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P merge_guards (mark_guards False c') Q,A"
    by (rule MergeGuardsI)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P merge_guards c Q,A"
    by (simp add: c)
  thus ?thesis
    by (rule MergeGuardsD)
qed

lemma CombineStrip'':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{True}\<^esub> P c' Q,A"
  assumes deriv_strip_triv: "\<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards ({False}) c')"
  assumes c: "merge_guards c = merge_guards (mark_guards False c')"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"
  apply (rule CombineStrip' [OF deriv deriv_strip_triv _ c])
  apply (insert c'')
  apply (subgoal_tac "- {True} = {False}")
  apply auto
  done

lemma AsmUN:
  "(\<Union>Z. {(P Z, p, Q Z,A Z)}) \<subseteq> \<Theta>
  \<Longrightarrow>
  \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) (Call p) (Q Z),(A Z)"
  by (blast intro: hoarep.Asm)

lemma augment_context':
  "\<lbrakk>\<Theta> \<subseteq> \<Theta>'; \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z)  p (Q Z),(A Z)\<rbrakk>
   \<Longrightarrow> \<forall>Z. \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (iprover intro: hoare_augment_context)

lemma hoarep_strip:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z); F' \<subseteq> -F\<rbrakk> \<Longrightarrow>
    \<forall>Z. strip F' \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (iprover intro: hoare_strip_\<Gamma>)

lemma augment_emptyFaults:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> (P Z) p (Q Z),(A Z)\<rbrakk> \<Longrightarrow>
    \<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (blast intro: augment_Faults)

lemma augment_FaultsUNIV:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)\<rbrakk> \<Longrightarrow>
    \<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/UNIV\<^esub> (P Z) p (Q Z),(A Z)"
  by (blast intro: augment_Faults)

lemma PostConjI [trans]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  by (rule PostConjI)

lemma PostConjI' :
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  by (rule PostConjI) iprover+

lemma PostConjE [consumes 1]:
  assumes conj: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  assumes E: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B\<rbrakk> \<Longrightarrow> S"
  shows "S"
proof -
  from conj have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A" by (rule conseqPost) blast+
  moreover
  from conj have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B" by (rule conseqPost) blast+
  ultimately show "S"
    by (rule E)
qed

subsection \<open>Rules for Single-Step Proof \label{sec:hoare-isar}\<close>

text \<open>
 We are now ready to introduce a set of Hoare rules to be used in
 single-step structured proofs in Isabelle/Isar.

 \medskip Assertions of Hoare Logic may be manipulated in
 calculational proofs, with the inclusion expressed in terms of sets
 or predicates.  Reversed order is supported as well.
\<close>

lemma annotateI [trans]:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P anno Q,A; c = anno\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c Q,A"
  by simp

lemma annotate_normI:
  assumes deriv_anno: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P anno Q,A"
  assumes norm_eq: "normalize c = normalize anno"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c Q,A"
proof -
  from NormalizeI [OF deriv_anno] norm_eq
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P normalize c Q,A"
    by simp
  from NormalizeD [OF this]
  show ?thesis .
qed

lemma annotateWhile:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (while gs b c) Q,A"
  by (simp add: whileAnnoG_def)

lemma reannotateWhile:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b J V c) Q,A"
  by (simp add: whileAnnoG_def)

lemma reannotateWhileNoGuard:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b J V c) Q,A"
  by (simp add: whileAnno_def)

lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q,A"
  by (rule conseqPre)

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q',A"
  by (rule conseqPost) blast+

lemma [trans]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} c Q,A \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P' s} c Q,A"
  by (rule conseqPre) auto

lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P' s} c Q,A"
  by (rule conseqPre) auto

lemma [trans]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q s},A \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q' s},A"
  by (rule conseqPost) auto

lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q s},A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q' s},A"
  by (rule conseqPost) auto

lemma [intro?]: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Skip P,A"
  by (rule Skip) auto

lemma CondInt [trans,intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> - b) c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule Cond) auto

lemma CondConj [trans, intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> b s} c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> \<not> b s} c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} (Cond {s. b s} c1 c2) Q,A"
  by (rule Cond) auto

lemma WhileInvInt [intro?]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b P V c) (P \<inter> -b),A"
  by (rule While) auto

lemma WhileInt [intro?]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A
    \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b {s. undefined} V c) (P \<inter> -b),A"
  by (unfold whileAnno_def)
     (rule HoarePartialDef.While [THEN conseqPrePost],auto)

lemma WhileInvConj [intro?]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> b s} c {s. P s},A
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} (whileAnno {s. b s} {s. P s} V c) {s. P s \<and> \<not> b s},A"
  by (simp add: While Collect_conj_eq Collect_neg_eq)

lemma WhileConj [intro?]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> b s} c {s. P s},A
    \<Longrightarrow>
\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} (whileAnno {s. b s} {s. undefined} V c) {s. P s \<and> \<not> b s},A"
  by (unfold whileAnno_def)
     (simp add: HoarePartialDef.While [THEN conseqPrePost]
      Collect_conj_eq Collect_neg_eq)

(* FIXME: Add rules for guarded while *)

end


section {*L\_ATS\_determHIST\_SDB*}
theory
  L_ATS_determHIST_SDB

imports
  L_ATS_determHIST_DB
  L_ATS_determHIST_SB

begin

locale ATS_determHIST_SDB =
  ATS_SchedF_SDB
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "fixed_schedulers :: 'TSstructure \<Rightarrow> 'fixed_scheduler set"
  "empty_fixed_scheduler :: 'TSstructure \<Rightarrow> 'fixed_scheduler"
  "fixed_scheduler_extendable :: 'TSstructure \<Rightarrow> 'fixed_scheduler \<Rightarrow> bool"
  "get_fixed_scheduler :: 'conf \<Rightarrow> 'fixed_scheduler"
  "get_fixed_scheduler_DB :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> nat \<Rightarrow> 'fixed_scheduler"
  +
  ATS_determHIST_SB
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "histories :: 'TSstructure \<Rightarrow> 'history set"
  "history_fragments :: 'TSstructure \<Rightarrow> 'history_fragment set"
  "empty_history :: 'TSstructure \<Rightarrow> 'history"
  "empty_history_fragment :: 'TSstructure \<Rightarrow> 'history_fragment"
  "set_history :: 'conf \<Rightarrow> 'history \<Rightarrow> 'conf"
  "extend_history :: 'history \<Rightarrow> 'history_fragment \<Rightarrow> 'history"
  "join_history_fragments :: 'history_fragment \<Rightarrow> 'history_fragment \<Rightarrow> 'history_fragment"
  "get_history :: 'conf \<Rightarrow> 'history"
  "fixed_schedulers :: 'TSstructure \<Rightarrow> 'fixed_scheduler set"
  "empty_fixed_scheduler :: 'TSstructure \<Rightarrow> 'fixed_scheduler"
  "fixed_scheduler_extendable :: 'TSstructure \<Rightarrow> 'fixed_scheduler \<Rightarrow> bool"
  "get_fixed_scheduler :: 'conf \<Rightarrow> 'fixed_scheduler"
  +
  ATS_determHIST_DB
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "histories :: 'TSstructure \<Rightarrow> 'history set"
  "history_fragments :: 'TSstructure \<Rightarrow> 'history_fragment set"
  "empty_history :: 'TSstructure \<Rightarrow> 'history"
  "empty_history_fragment :: 'TSstructure \<Rightarrow> 'history_fragment"
  "set_history :: 'conf \<Rightarrow> 'history \<Rightarrow> 'conf"
  "extend_history :: 'history \<Rightarrow> 'history_fragment \<Rightarrow> 'history"
  "join_history_fragments :: 'history_fragment \<Rightarrow> 'history_fragment \<Rightarrow> 'history_fragment"
  "get_history :: 'conf \<Rightarrow> 'history"
  "fixed_schedulers :: 'TSstructure \<Rightarrow> 'fixed_scheduler set"
  "empty_fixed_scheduler :: 'TSstructure \<Rightarrow> 'fixed_scheduler"
  "fixed_scheduler_extendable :: 'TSstructure \<Rightarrow> 'fixed_scheduler \<Rightarrow> bool"
  "get_fixed_scheduler_DB :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> nat \<Rightarrow> 'fixed_scheduler"
  for
    TSstructure configurations initial_configurations step_labels step_relation effects marking_condition marked_effect unmarked_effect fixed_schedulers empty_fixed_scheduler fixed_scheduler_extendable get_fixed_scheduler get_fixed_scheduler_DB histories history_fragments empty_history empty_history_fragment set_history extend_history join_history_fragments get_history

context ATS_determHIST_SDB begin

lemma AX_is_forward_edge_deterministic_correspond_DB_SB: "
  TSstructure G
  \<Longrightarrow> is_forward_edge_deterministicHist_SB_long G = is_forward_edge_deterministicHist_DB_long G"
  apply(rule order_antisym)
   apply(clarsimp)
   apply(simp add: is_forward_edge_deterministicHist_SB_long_def is_forward_edge_deterministicHist_DB_long_def)
   apply(clarsimp)
   apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
   apply(erule_tac
      x="c"
      in ballE)
    apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
    apply(erule_tac
      x="c1"
      in allE)
    apply(erule_tac
      x="c2"
      in allE)
    apply(erule_tac
      x="e1"
      in allE)
    apply(erule_tac
      x="e2"
      in allE)
    apply(clarsimp)
    apply(erule_tac
      x="w1"
      in allE)
    apply(clarsimp)
    apply(erule_tac
      x="w2"
      in allE)
    apply(clarsimp)
    apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e1 c1) n) (Suc n)) = ((get_fixed_scheduler c1))")
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
     apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e2 c2) n) (Suc n)) = ((get_fixed_scheduler c2))")
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(clarsimp)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(force)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
     apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
       apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(rule derivation_append_preserves_derivation_initial)
        apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
        apply(force)
       apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(rule derivation_append_preserves_derivation)
        apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
        apply(rule derivation_initial_is_derivation)
        apply(force)
       apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
       apply(rule der2_is_derivation)
       apply(force)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(clarsimp)
      apply(simp add: get_configuration_def)
      apply(case_tac "d n")
       apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2 a)(*strict*)
      apply(clarsimp)
      apply(case_tac a)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2 a option b)(*strict*)
      apply(clarsimp)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2 option)(*strict*)
      apply(simp add: der2_def)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
     apply(simp add: derivation_append_def der2_def)
    apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
    apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(force)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
     apply(rule derivation_append_preserves_derivation_initial)
       apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(force)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
     apply(rule derivation_append_preserves_derivation)
       apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
       apply(rule derivation_initial_is_derivation)
       apply(force)
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(rule der2_is_derivation)
      apply(force)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
     apply(simp add: get_configuration_def)
     apply(case_tac "d n")
      apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
      apply(force)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2 a)(*strict*)
     apply(clarsimp)
     apply(case_tac a)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2 a option b)(*strict*)
     apply(clarsimp)
     apply(rename_tac c d n c1 c2 e1 e2 w1 w2 option)(*strict*)
     apply(simp add: der2_def)
    apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
    apply(simp add: derivation_append_def der2_def)
   apply(rename_tac c d n c1 c2 e1 e2 w1 w2)(*strict*)
   apply(simp add: get_accessible_configurations_def)
  apply(simp add: is_forward_edge_deterministicHist_SB_long_def is_forward_edge_deterministicHist_DB_long_def get_accessible_configurations_def)
  apply(clarsimp)
  apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
  apply(erule_tac
      x="c"
      in allE)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule_tac
      x="i"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="c1"
      in allE)
  apply(erule_tac
      x="c2"
      in allE)
  apply(erule_tac
      x="e1"
      in allE)
  apply(erule_tac
      x="e2"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="w1"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="w2"
      in allE)
  apply(clarsimp)
  apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e1 c1) i) (Suc i)) = ((get_fixed_scheduler c1))")
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
   apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e2 c2) i) (Suc i)) = ((get_fixed_scheduler c2))")
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
   apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
     apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(rule derivation_append_preserves_derivation_initial)
      apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
      apply(force)
     apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(rule derivation_append_preserves_derivation)
      apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
      apply(rule derivation_initial_is_derivation)
      apply(force)
     apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
     apply(rule der2_is_derivation)
     apply(force)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(clarsimp)
    apply(simp add: get_configuration_def)
    apply(case_tac "d i")
     apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2 a)(*strict*)
    apply(clarsimp)
    apply(case_tac a)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2 a option b)(*strict*)
    apply(clarsimp)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2 option)(*strict*)
    apply(simp add: der2_def)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
   apply(simp add: derivation_append_def der2_def)
  apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
  apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
   apply(rule derivation_append_preserves_derivation_initial)
     apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
   apply(rule derivation_append_preserves_derivation)
     apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
     apply(rule derivation_initial_is_derivation)
     apply(force)
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(rule der2_is_derivation)
    apply(force)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
   apply(simp add: get_configuration_def)
   apply(case_tac "d i")
    apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2 a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2 a option b)(*strict*)
   apply(clarsimp)
   apply(rename_tac c d c1 c2 e1 e2 i w1 w2 option)(*strict*)
   apply(simp add: der2_def)
  apply(rename_tac c d c1 c2 e1 e2 i w1 w2)(*strict*)
  apply(simp add: derivation_append_def der2_def)
  done

lemma AX_is_forward_target_deterministic_correspond_DB_SB: "
  TSstructure G
  \<Longrightarrow> is_forward_target_deterministicHist_SB_long G = is_forward_target_deterministicHist_DB_long G"
  apply(rule order_antisym)
   apply(clarsimp)
   apply(simp add: is_forward_target_deterministicHist_SB_long_def is_forward_target_deterministicHist_DB_long_def)
   apply(clarsimp)
   apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
   apply(erule_tac
      x="c"
      in ballE)
    apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
    apply(erule_tac
      x="c1"
      in allE)
    apply(erule_tac
      x="c2"
      in allE)
    apply(erule impE)
     apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
     apply(rule_tac
      x="e"
      in exI)
     apply(clarsimp)
     apply(rule_tac
      x="w1"
      in exI)
     apply(clarsimp)
     apply(rule_tac
      x="w2"
      in exI)
     apply(clarsimp)
     apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e c1) n) (Suc n)) = ((get_fixed_scheduler c1))")
      apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
      apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e c2) n) (Suc n)) = ((get_fixed_scheduler c2))")
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
      apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
        apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
        apply(force)
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(rule derivation_append_preserves_derivation_initial)
         apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
         apply(force)
        apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
        apply(force)
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(rule derivation_append_preserves_derivation)
         apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
         apply(rule derivation_initial_is_derivation)
         apply(force)
        apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
        apply(rule der2_is_derivation)
        apply(force)
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(clarsimp)
       apply(simp add: get_configuration_def)
       apply(case_tac "d n")
        apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
        apply(force)
       apply(rename_tac c d n c1 c2 e w1 w2 a)(*strict*)
       apply(clarsimp)
       apply(case_tac a)
       apply(rename_tac c d n c1 c2 e w1 w2 a option b)(*strict*)
       apply(clarsimp)
       apply(rename_tac c d n c1 c2 e w1 w2 option)(*strict*)
       apply(simp add: der2_def)
      apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
      apply(simp add: derivation_append_def der2_def)
     apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
     apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
      apply(rule derivation_append_preserves_derivation_initial)
        apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
        apply(force)
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
      apply(rule derivation_append_preserves_derivation)
        apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
        apply(rule derivation_initial_is_derivation)
        apply(force)
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(rule der2_is_derivation)
       apply(force)
      apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
      apply(simp add: get_configuration_def)
      apply(case_tac "d n")
       apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
       apply(force)
      apply(rename_tac c d n c1 c2 e w1 w2 a)(*strict*)
      apply(clarsimp)
      apply(case_tac a)
      apply(rename_tac c d n c1 c2 e w1 w2 a option b)(*strict*)
      apply(clarsimp)
      apply(rename_tac c d n c1 c2 e w1 w2 option)(*strict*)
      apply(simp add: der2_def)
     apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
     apply(simp add: derivation_append_def der2_def)
    apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d n c1 c2 e w1 w2)(*strict*)
   apply(simp add: get_accessible_configurations_def)
  apply(simp add: is_forward_target_deterministicHist_SB_long_def is_forward_target_deterministicHist_DB_long_def get_accessible_configurations_def)
  apply(clarsimp)
  apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
  apply(erule_tac
      x="c"
      in allE)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule_tac
      x="i"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="c1"
      in allE)
  apply(erule_tac
      x="c2"
      in allE)
  apply(erule impE)
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
  apply(rule_tac
      x="e"
      in exI)
  apply(clarsimp)
  apply(rule_tac
      x="w1"
      in exI)
  apply(clarsimp)
  apply(rule_tac
      x="w2"
      in exI)
  apply(clarsimp)
  apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e c1) i) (Suc i)) = ((get_fixed_scheduler c1))")
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   apply(subgoal_tac "(get_fixed_scheduler_DB G (derivation_append d (der2 c e c2) i) (Suc i)) = ((get_fixed_scheduler c2))")
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
     apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(rule derivation_append_preserves_derivation_initial)
      apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
      apply(force)
     apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(rule derivation_append_preserves_derivation)
      apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
      apply(rule derivation_initial_is_derivation)
      apply(force)
     apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
     apply(rule der2_is_derivation)
     apply(force)
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(simp add: get_configuration_def)
    apply(case_tac "d i")
     apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 i e w1 w2 a)(*strict*)
    apply(clarsimp)
    apply(case_tac a)
    apply(rename_tac c d c1 c2 i e w1 w2 a option b)(*strict*)
    apply(clarsimp)
    apply(rename_tac c d c1 c2 i e w1 w2 option)(*strict*)
    apply(simp add: der2_def)
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   apply(simp add: derivation_append_def der2_def)
  apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
  apply(rule AX_state_based_vs_derivation_based_get_fixed_scheduler)
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   apply(rule derivation_append_preserves_derivation_initial)
     apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
     apply(force)
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   apply(rule derivation_append_preserves_derivation)
     apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
     apply(rule derivation_initial_is_derivation)
     apply(force)
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(rule der2_is_derivation)
    apply(force)
   apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
   apply(simp add: get_configuration_def)
   apply(case_tac "d i")
    apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
    apply(force)
   apply(rename_tac c d c1 c2 i e w1 w2 a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac c d c1 c2 i e w1 w2 a option b)(*strict*)
   apply(clarsimp)
   apply(rename_tac c d c1 c2 i e w1 w2 option)(*strict*)
   apply(simp add: der2_def)
  apply(rename_tac c d c1 c2 i e w1 w2)(*strict*)
  apply(simp add: derivation_append_def der2_def)
  done

lemma is_forward_deterministic_correspond_DB_SB: "
  TSstructure G
  \<Longrightarrow> is_forward_deterministicHist_SB G = is_forward_deterministicHist_DB G"
  apply (metis AX_is_forward_edge_deterministic_correspond_DB_SB AX_is_forward_target_deterministic_correspond_DB_SB is_forward_deterministicHist_DB_def is_forward_deterministicHist_SB_def)
  done

end

end