theory Separation_Semiring
  imports Domain_Semiring Range_Semiring
begin

no_notation
  fdiamond ("\<bar> _ \<rangle> _" [50,90] 95) and
  fbox ("\<bar> _ ] _" [50,90] 95) and
  bdiamond ("\<langle> _ \<bar> _" [50,90] 95) and
  bbox ("[ _ \<bar> _" [50,90] 95) and
  times (infixl "*" 70)

context antidomain_semiring
begin

definition fdia :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<bar>_\<rangle>_" [99, 99] 100) where
  "\<bar>x\<rangle>y = d(x\<cdot>y)"

definition fbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<bar>_]_" [99, 99] 100) where
  "\<bar>x]y = a( \<bar>x\<rangle> a(y) )"

lemma fbox_def_var: "\<bar>x]y = a(x\<cdot>a(y))"
  by (metis fdia_def fbox_def local.a_5)

sublocale fmodal: fmodal_semiring where fdiamond = fdia and fbox = fbox
  apply default
  apply (simp_all add: fdia_def fbox_def_var)
done

lemma fswap: "p = d(p) \<Longrightarrow> q = d(q) \<Longrightarrow> \<bar>x\<rangle>p \<le> \<bar>y]q \<longleftrightarrow> \<bar>y\<rangle>a(q) \<le> \<bar>x]a(p)"
  by (metis local.a_antitone local.antidomain_semiring_domain_def local.fmodal.fbox_fdia_de_morgan_1 local.fmodal.fdia_fbox_de_morgan_2)

end

interpretation rel: antidomain_semiring "op \<union>" "op O" Id "{}" "\<lambda>x. -(Id \<inter> x O UNIV) \<inter> Id" "op \<subseteq>" "op \<subset>"
apply default
apply auto
by (metis ComplI IdI Int_iff UNIV_I compl_inf relcomp.simps)

interpretation rel: antirange_semiring "op \<union>" "op O" Id "{}" "\<lambda>x. -(Id \<inter> UNIV O x) \<inter> Id" "op \<subseteq>" "op \<subset>"
apply default
apply auto
by (metis ComplI IdI Int_iff UNIV_I compl_inf relcomp.simps)

class sepconj =
  fixes sepconj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*" 80)
  and sepunit :: "'a" ("e")

class ss_domain = antidomain_semiring + sepconj +
  assumes d6: "d(d(x) * d(y)) = d(x) * d(y)"
  and d7: "d(x * (y * z)) = d((x * y) * z)"
  and d8: "d(x * (y + z)) = d(x * y) + d(x * z)"
  and d9: "d(x * y) = d(y * x)"
  and d10: "d(x * e) = d(x)"
  and d_loc: "d(x \<cdot> (y * z)) \<le> d(x\<cdot>y) * d(z)"
begin

lemma d_loc': "d p = p \<Longrightarrow> d q = q \<Longrightarrow> d(x \<cdot> (p * q)) \<le> d(x\<cdot>p) * q"
  by (metis local.d_loc)

lemma fdia_local: "d(p) = p \<Longrightarrow> d(q) = q \<Longrightarrow> \<bar>x\<rangle>(p * q) \<le> \<bar>x\<rangle>p * q"
  by (metis local.d_loc' local.fmodal.fdiamond_def)

lemma fbox_local: "\<lbrakk>p = d(p); q = d(q)\<rbrakk> \<Longrightarrow> \<bar>x]p * q \<le> \<bar>x](p * q)"
  (* nitpick *) oops

end

context antirange_semiring
begin

definition bdia :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<langle>_\<bar>_" [99, 99] 100) where
  "\<langle>x\<bar>y = r(y\<cdot>x)"

definition bbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("[_\<bar>_" [99, 99] 100) where
  "[x\<bar>y = ar( \<langle>x\<bar> ar(y) )"

lemma bbox_def_var: "[x\<bar>y = ar(ar(y)\<cdot>x)"
  by (metis bdia_def local.antirange_semiring_range_def local.bbox_def local.dual.a_closure local.dual.antidomain_semiring_domain_def)

sublocale bmodal: bmodal_semiring where bdiamond = bdia and bbox = bbox
  apply default
  apply (simp_all add: bdia_def bbox_def_var)
done

lemma bswap: "p = r(p) \<Longrightarrow> q = r(q) \<Longrightarrow> \<langle>x\<bar>p \<le> [y\<bar>q \<longleftrightarrow> \<langle>y\<bar>ar(q) \<le> [x\<bar>ar(p)"
  by (metis local.bmodal.dual.fbox_fdia local.bmodal.dual.fdia_fbox_de_morgan_2 local.bmodal.dual.fdia_simp_2 local.dual.a_antitone local.dual.antidomain_semiring_domain_def)

end

class ss_range = antirange_semiring + sepconj +
  assumes r6: "r(r(x) * r(y)) = r(x) * r(y)"
  and r7: "r(x * (y * z)) = r((x * y) * z)"
  and r8: "r(x * (y + z)) = r(x * y) + r(x * z)"
  and r9: "r(x * y) = r(y * x)"
  and r10: "r(x * e) = r(x)"
  and r_loc: "r((x * y) \<cdot> z) \<le> r(x\<cdot>z) * r(y)"
begin

lemma bdia_local: "r(p) = p \<Longrightarrow> r(q) = q \<Longrightarrow> \<langle>x\<bar>(p * q) \<le> \<langle>x\<bar>p * q"
  by (metis local.r_loc bdiamond_def)

end

class modal_semiring = antidomain_semiring + antirange_semiring +
  assumes domrange: "d(r(x))=r(x)"
  and rangedom: "r(d(x))=d(x)"
begin

lemma domrangefix: "d(x)=x \<longleftrightarrow> r(x)=x"
  by (metis domrange rangedom)

lemma box_diamond_galois_1: "\<lbrakk>p=d(p); q=d(q)\<rbrakk> \<Longrightarrow> (\<langle>x\<bar>p \<le> q \<longleftrightarrow> p \<le> \<bar>x]q)"
  by (metis domrangefix fbox_demodalisation3 rdemodalisation3)

lemma box_diamond_galois_2: "\<lbrakk>p=d(p); q=d(q)\<rbrakk> \<Longrightarrow> ( \<bar>x\<rangle>p \<le> q \<longleftrightarrow> p \<le> [x\<bar>q)"
  by (metis domrangefix bbox_demodalisation3 fdemodalisation3)

lemma diamond_conjugation_var_1: "\<lbrakk>p=d(p); q=d(q)\<rbrakk> \<Longrightarrow>( \<bar>x\<rangle>q \<le> a(p) \<longleftrightarrow> \<langle>x\<bar>p \<le> a(q))"
  by (smt a_closure a_export antidomain_semiring_domain_def box_diamond_galois_1 domain_1 fbox_def fdia_fbox less_eq_def)

lemma diamond_conjugation: "\<lbrakk>p=d(p); q=d(q)\<rbrakk> \<Longrightarrow> (p\<cdot>( \<bar>x\<rangle>q) = 0 \<longleftrightarrow> q\<cdot>(\<langle>x\<bar>p) = 0)"
  by (metis diamond_conjugation_var_1 fdia_simp_2 bdia_simp_2 domrange d_d_zero dom_el_comm)

lemma box_conjugation:  "\<lbrakk>p=d(p); q=d(q)\<rbrakk> \<Longrightarrow> (p \<le> [x\<bar>a(q) \<longleftrightarrow> q \<le> \<bar>x]a(p))"
  by (metis box_diamond_galois_2 a_closure diamond_conjugation_var_1  box_diamond_galois_1 antidomain_semiring_domain_def)

lemma box_diamond_cancellation_1:  "p=d(p)  \<Longrightarrow>  p \<le> \<bar>x](\<langle>x\<bar>p)"
  by (metis bdiamond_def box_diamond_galois_1 domrange order_refl)

lemma box_diamond_cancellation_2:  "p=d(p)  \<Longrightarrow>  p \<le> [x\<bar>( \<bar>x\<rangle>p)"
  by (metis box_diamond_galois_2 domain_invol fdiamond_def order_refl)

lemma box_diamond_cancellation_3:  "q=d(q) \<Longrightarrow> \<bar>x\<rangle>([x\<bar>q) \<le> q"
  by (metis ar_closure box_diamond_galois_2 domrangefix dual.fbox_fdia order_refl)

lemma box_diamond_cancellation_4:  "q=d(q) \<Longrightarrow> \<langle>x\<bar>( \<bar>x]q) \<le> q"
  by (metis a_closure box_diamond_galois_1 fbox_def order_refl)

lemma antidomran: "d(x) = x \<Longrightarrow> a(x) = ar(x)"
  by (metis local.a_gla local.antidomain_semiring_domain_def local.antirange_semiring_range_def local.antisym_conv local.ar1 local.ar_gla local.domrange local.rangedom)

end

interpretation rel: modal_semiring "op \<union>" "op O" Id "{}" "\<lambda>x. -(Id \<inter> x O UNIV) \<inter> Id" "op \<subseteq>" "op \<subset>" "\<lambda>x. -(Id \<inter> UNIV O x) \<inter> Id"
  apply default
  apply (subst rel.antidomain_semiring_domain_def)
  apply (subst rel.antirange_semiring_range_def)+
  prefer 2
  apply (subst rel.antidomain_semiring_domain_def)+
  apply (subst rel.antirange_semiring_range_def)
  apply force
  apply fastforce
done

class modal_separation_semiring = modal_semiring + ss_domain + ss_range
begin

lemma dsep_isol: "d(y) \<le> d(z) \<Longrightarrow> d(x) * d(y) \<le> d(x) * d(z)"
proof (simp add: less_eq_def)
  assume assms: "d y + d z = d z"
  have "d x * d y + d x * d z = d (d x * d y) + d(d x * d z)"
    by (metis d6)
  also have "... = d (d x * (d y + d z))"
    by (metis d8)
  also have "... = d (d x * d z)"
    by (metis assms)
  finally show "d x * d y + d x * d z = d x * d z"
    by (metis d6)
qed

lemma dsep_isor: "d(x) \<le> d(y) \<Longrightarrow> d(x) * d(z) \<le> d(y) * d(z)"
  using dsep_isol local.d6 local.d9 by smt

lemma dsep_isol_var: "p=d(p) \<Longrightarrow> q=d(q) \<Longrightarrow> s=d(s) \<Longrightarrow> p \<le> q \<Longrightarrow> s * p \<le> s * q"
  by (metis dsep_isol)

lemma dsep_isor_var: "p=d(p) \<Longrightarrow> q=d(q) \<Longrightarrow> s=d(s) \<Longrightarrow> p \<le> q \<Longrightarrow> p * s \<le> q * s"
  by (metis dsep_isor)

lemma d_sepconj: "d(p) = p \<Longrightarrow> d(q) = q \<Longrightarrow> d(p * q) = p * q"
  by (metis local.d6)

lemma fbox_local: "\<lbrakk>p = d(p); q = d(q)\<rbrakk> \<Longrightarrow> \<bar>x]p * q \<le> \<bar>x](p * q)"
proof -
  assume tests:"p = d(p)" "q = d(q)"
  hence "\<langle>x\<bar>(\<bar>x]p * q) \<le> \<langle>x\<bar>(\<bar>x]p) * q"
    by (metis bdia_local local.fmodal.fbox_simp_2 domrangefix)
  moreover have "\<langle>x\<bar>(\<bar>x]p) \<le> p"
    by (metis local.box_diamond_cancellation_4 tests(1))
  ultimately have "\<langle>x\<bar>(\<bar>x]p * q) \<le> p * q"
    apply (subst tests(1))
    apply (rule dual_order.trans)
    using tests apply (auto intro!: dsep_isor_var)
    by (metis local.antirange_semiring_range_def local.bmodal.dual.fdia_simp_2 local.domrangefix local.dual.antidomain_semiring_domain_def)
  thus ?thesis
    by (metis local.box_diamond_galois_1 local.d6 local.fmodal.fbox_simp_2 tests(1) tests(2))
qed

lemma bbox_local: "\<lbrakk>p = d(p); q = d(q)\<rbrakk> \<Longrightarrow> [x\<bar>p * q \<le> [x\<bar>(p * q)"
proof -
  assume tests:"p = d(p)" "q = d(q)"
  hence "\<bar>x\<rangle>([x\<bar>p * q) \<le> \<bar>x\<rangle>([x\<bar>p) * q"
    by (metis local.d_loc local.fmodal.fdiamond_def)
  moreover have "\<bar>x\<rangle>([x\<bar>p) \<le> p"
    by (metis local.box_diamond_cancellation_3 tests(1))
  ultimately have "\<bar>x\<rangle>([x\<bar>p * q) \<le> p * q"
    apply (subst tests(1))
    apply (rule dual_order.trans)
    using tests apply (auto intro!: dsep_isor_var)
    by (metis local.fmodal.fdia_simp_2)
  thus ?thesis
    by (metis d_sepconj local.antirange_semiring_range_def local.bmodal.dual.fbox_fdia local.box_diamond_galois_2 local.domrangefix local.dual.a_closure local.dual.antidomain_semiring_domain_def tests(1) tests(2))
qed

end

end


(*  Title:      ZF/UNITY/Comp.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   1998  University of Cambridge

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Revised by Sidi Ehmety on January  2001

Added: a strong form of the order relation over component and localize

Theory ported from HOL.

*)

section\<open>Composition\<close>

theory Comp imports Union Increasing begin

definition
  component :: "[i,i]\<Rightarrow>o"  (infixl \<open>component\<close> 65)  where
  "F component H \<equiv> (\<exists>G. F \<squnion> G = H)"

definition
  strict_component :: "[i,i]\<Rightarrow>o" (infixl \<open>strict'_component\<close> 65)  where
  "F strict_component H \<equiv> F component H \<and> F\<noteq>H"

definition
  (* A stronger form of the component relation *)
  component_of :: "[i,i]\<Rightarrow>o"   (infixl \<open>component'_of\<close> 65)  where
  "F component_of H  \<equiv> (\<exists>G. F ok G \<and> F \<squnion> G = H)"

definition
  strict_component_of :: "[i,i]\<Rightarrow>o" (infixl \<open>strict'_component'_of\<close> 65)  where
  "F strict_component_of H  \<equiv> F component_of H  \<and> F\<noteq>H"

definition
  (* Preserves a state function f, in particular a variable *)
  preserves :: "(i\<Rightarrow>i)\<Rightarrow>i"  where
  "preserves(f) \<equiv> {F:program. \<forall>z. F: stable({s:state. f(s) = z})}"

definition
  fun_pair :: "[i\<Rightarrow>i, i \<Rightarrow>i] \<Rightarrow>(i\<Rightarrow>i)"  where
  "fun_pair(f, g) \<equiv> \<lambda>x. <f(x), g(x)>"

definition
  localize  :: "[i\<Rightarrow>i, i] \<Rightarrow> i"  where
  "localize(f,F) \<equiv> mk_program(Init(F), Acts(F),
                       AllowedActs(F) \<inter> (\<Union>G\<in>preserves(f). Acts(G)))"

(*** component and strict_component relations ***)

lemma componentI:
     "H component F | H component G \<Longrightarrow> H component (F \<squnion> G)"
apply (unfold component_def, auto)
apply (rule_tac x = "Ga \<squnion> G" in exI)
apply (rule_tac [2] x = "G \<squnion> F" in exI)
apply (auto simp add: Join_ac)
done

lemma component_eq_subset:
     "G \<in> program \<Longrightarrow> (F component G) \<longleftrightarrow>
   (Init(G) \<subseteq> Init(F) \<and> Acts(F) \<subseteq> Acts(G) \<and> AllowedActs(G) \<subseteq> AllowedActs(F))"
apply (unfold component_def, auto)
apply (rule exI)
apply (rule program_equalityI, auto)
done

lemma component_SKIP [simp]: "F \<in> program \<Longrightarrow> SKIP component F"
  unfolding component_def
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_left)
done

lemma component_refl [simp]: "F \<in> program \<Longrightarrow> F component F"
  unfolding component_def
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_right)
done

lemma SKIP_minimal: "F component SKIP \<Longrightarrow> programify(F) = SKIP"
apply (rule program_equalityI)
apply (simp_all add: component_eq_subset, blast)
done

lemma component_Join1: "F component (F \<squnion> G)"
by (unfold component_def, blast)

lemma component_Join2: "G component (F \<squnion> G)"
  unfolding component_def
apply (simp (no_asm) add: Join_commute)
apply blast
done

lemma Join_absorb1: "F component G \<Longrightarrow> F \<squnion> G = G"
by (auto simp add: component_def Join_left_absorb)

lemma Join_absorb2: "G component F \<Longrightarrow> F \<squnion> G = F"
by (auto simp add: Join_ac component_def)

lemma JOIN_component_iff:
     "H \<in> program\<Longrightarrow>(JOIN(I,F) component H) \<longleftrightarrow> (\<forall>i \<in> I. F(i) component H)"
apply (case_tac "I=0", force)
apply (simp (no_asm_simp) add: component_eq_subset)
apply auto
apply blast
apply (rename_tac "y")
apply (drule_tac c = y and A = "AllowedActs (H)" in subsetD)
apply (blast elim!: not_emptyE)+
done

lemma component_JOIN: "i \<in> I \<Longrightarrow> F(i) component (\<Squnion>i \<in> I. (F(i)))"
  unfolding component_def
apply (blast intro: JOIN_absorb)
done

lemma component_trans: "\<lbrakk>F component G; G component H\<rbrakk> \<Longrightarrow> F component H"
  unfolding component_def
apply (blast intro: Join_assoc [symmetric])
done

lemma component_antisym:
     "\<lbrakk>F \<in> program; G \<in> program\<rbrakk> \<Longrightarrow>(F component G \<and> G  component F) \<longrightarrow> F = G"
apply (simp (no_asm_simp) add: component_eq_subset)
apply clarify
apply (rule program_equalityI, auto)
done

lemma Join_component_iff:
     "H \<in> program \<Longrightarrow>
      ((F \<squnion> G) component H) \<longleftrightarrow> (F component H \<and> G component H)"
apply (simp (no_asm_simp) add: component_eq_subset)
apply blast
done

lemma component_constrains:
     "\<lbrakk>F component G; G \<in> A co B; F \<in> program\<rbrakk> \<Longrightarrow> F \<in> A co B"
apply (frule constrainsD2)
apply (auto simp add: constrains_def component_eq_subset)
done

(*** preserves ***)

lemma preserves_is_safety_prop [simp]: "safety_prop(preserves(f))"
  unfolding preserves_def safety_prop_def
apply (auto dest: ActsD simp add: stable_def constrains_def)
apply (drule_tac c = act in subsetD, auto)
done

lemma preservesI [rule_format]:
     "\<forall>z. F \<in> stable({s \<in> state. f(s) = z})  \<Longrightarrow> F \<in> preserves(f)"
apply (auto simp add: preserves_def)
apply (blast dest: stableD2)
done

lemma preserves_imp_eq:
     "\<lbrakk>F \<in> preserves(f);  act \<in> Acts(F);  \<langle>s,t\<rangle> \<in> act\<rbrakk> \<Longrightarrow> f(s) = f(t)"
  unfolding preserves_def stable_def constrains_def
apply (subgoal_tac "s \<in> state \<and> t \<in> state")
 prefer 2 apply (blast dest!: Acts_type [THEN subsetD], force)
done

lemma Join_preserves [iff]:
"(F \<squnion> G \<in> preserves(v)) \<longleftrightarrow>
      (programify(F) \<in> preserves(v) \<and> programify(G) \<in> preserves(v))"
by (auto simp add: preserves_def INT_iff)

lemma JOIN_preserves [iff]:
     "(JOIN(I,F): preserves(v)) \<longleftrightarrow> (\<forall>i \<in> I. programify(F(i)):preserves(v))"
by (auto simp add: JOIN_stable preserves_def INT_iff)

lemma SKIP_preserves [iff]: "SKIP \<in> preserves(v)"
by (auto simp add: preserves_def INT_iff)

lemma fun_pair_apply [simp]: "fun_pair(f,g,x) = <f(x), g(x)>"
  unfolding fun_pair_def
apply (simp (no_asm))
done

lemma preserves_fun_pair:
     "preserves(fun_pair(v,w)) = preserves(v) \<inter> preserves(w)"
apply (rule equalityI)
apply (auto simp add: preserves_def stable_def constrains_def, blast+)
done

lemma preserves_fun_pair_iff [iff]:
     "F \<in> preserves(fun_pair(v, w))  \<longleftrightarrow> F \<in> preserves(v) \<inter> preserves(w)"
by (simp add: preserves_fun_pair)

lemma fun_pair_comp_distrib:
     "(fun_pair(f, g) comp h)(x) = fun_pair(f comp h, g comp h, x)"
by (simp add: fun_pair_def metacomp_def)

lemma comp_apply [simp]: "(f comp g)(x) = f(g(x))"
by (simp add: metacomp_def)

lemma preserves_type: "preserves(v)<=program"
by (unfold preserves_def, auto)

lemma preserves_into_program [TC]: "F \<in> preserves(f) \<Longrightarrow> F \<in> program"
by (blast intro: preserves_type [THEN subsetD])

lemma subset_preserves_comp: "preserves(f) \<subseteq> preserves(g comp f)"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (drule_tac x = "f (xb)" in spec)
apply (drule_tac x = act in bspec, auto)
done

lemma imp_preserves_comp: "F \<in> preserves(f) \<Longrightarrow> F \<in> preserves(g comp f)"
by (blast intro: subset_preserves_comp [THEN subsetD])

lemma preserves_subset_stable: "preserves(f) \<subseteq> stable({s \<in> state. P(f(s))})"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (rename_tac s' s)
apply (subgoal_tac "f (s) = f (s') ")
apply (force+)
done

lemma preserves_imp_stable:
     "F \<in> preserves(f) \<Longrightarrow> F \<in> stable({s \<in> state. P(f(s))})"
by (blast intro: preserves_subset_stable [THEN subsetD])

lemma preserves_imp_increasing:
 "\<lbrakk>F \<in> preserves(f); \<forall>x \<in> state. f(x):A\<rbrakk> \<Longrightarrow> F \<in> Increasing.increasing(A, r, f)"
  unfolding Increasing.increasing_def
apply (auto intro: preserves_into_program)
apply (rule_tac P = "\<lambda>x. \<langle>k, x\<rangle>:r" in preserves_imp_stable, auto)
done

lemma preserves_id_subset_stable:
 "st_set(A) \<Longrightarrow> preserves(\<lambda>x. x) \<subseteq> stable(A)"
apply (unfold preserves_def stable_def constrains_def, auto)
apply (drule_tac x = xb in spec)
apply (drule_tac x = act in bspec)
apply (auto dest: ActsD)
done

lemma preserves_id_imp_stable:
     "\<lbrakk>F \<in> preserves(\<lambda>x. x); st_set(A)\<rbrakk> \<Longrightarrow> F \<in> stable(A)"
by (blast intro: preserves_id_subset_stable [THEN subsetD])

(** Added by Sidi **)
(** component_of **)

(*  component_of is stronger than component *)
lemma component_of_imp_component:
"F component_of H \<Longrightarrow> F component H"
apply (unfold component_def component_of_def, blast)
done

(* component_of satisfies many of component's properties *)
lemma component_of_refl [simp]: "F \<in> program \<Longrightarrow> F component_of F"
  unfolding component_of_def
apply (rule_tac x = SKIP in exI, auto)
done

lemma component_of_SKIP [simp]: "F \<in> program \<Longrightarrow>SKIP component_of F"
apply (unfold component_of_def, auto)
apply (rule_tac x = F in exI, auto)
done

lemma component_of_trans:
     "\<lbrakk>F component_of G; G component_of H\<rbrakk> \<Longrightarrow> F component_of H"
  unfolding component_of_def
apply (blast intro: Join_assoc [symmetric])
done

(** localize **)
lemma localize_Init_eq [simp]: "Init(localize(v,F)) = Init(F)"
by (unfold localize_def, simp)

lemma localize_Acts_eq [simp]: "Acts(localize(v,F)) = Acts(F)"
by (unfold localize_def, simp)

lemma localize_AllowedActs_eq [simp]:
 "AllowedActs(localize(v,F)) = AllowedActs(F) \<inter> (\<Union>G \<in> preserves(v). Acts(G))"
  unfolding localize_def
apply (rule equalityI)
apply (auto dest: Acts_type [THEN subsetD])
done

(** Theorems used in ClientImpl **)

lemma stable_localTo_stable2:
 "\<lbrakk>F \<in> stable({s \<in> state. P(f(s), g(s))});  G \<in> preserves(f);  G \<in> preserves(g)\<rbrakk>
      \<Longrightarrow> F \<squnion> G \<in> stable({s \<in> state. P(f(s), g(s))})"
apply (auto dest: ActsD preserves_into_program simp add: stable_def constrains_def)
apply (case_tac "act \<in> Acts (F) ")
apply auto
apply (drule preserves_imp_eq)
apply (drule_tac [3] preserves_imp_eq, auto)
done

lemma Increasing_preserves_Stable:
     "\<lbrakk>F \<in> stable({s \<in> state. <f(s), g(s)>:r});  G \<in> preserves(f);
         F \<squnion> G \<in> Increasing(A, r, g);
         \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk>
      \<Longrightarrow> F \<squnion> G \<in> Stable({s \<in> state. <f(s), g(s)>:r})"
apply (auto simp add: stable_def Stable_def Increasing_def Constrains_def all_conj_distrib)
apply (simp_all add: constrains_type [THEN subsetD] preserves_type [THEN subsetD])
apply (blast intro: constrains_weaken)
(*The G case remains*)
apply (auto dest: ActsD simp add: preserves_def stable_def constrains_def ball_conj_distrib all_conj_distrib)
(*We have a G-action, so delete assumptions about F-actions*)
apply (erule_tac V = "\<forall>act \<in> Acts (F). P (act)" for P in thin_rl)
apply (erule_tac V = "\<forall>k\<in>A. \<forall>act \<in> Acts (F) . P (k,act)" for P in thin_rl)
apply (subgoal_tac "f (x) = f (xa) ")
apply (auto dest!: bspec)
done

(** Lemma used in AllocImpl **)

lemma Constrains_UN_left:
     "\<lbrakk>\<forall>x \<in> I. F \<in> A(x) Co B; F \<in> program\<rbrakk> \<Longrightarrow> F:(\<Union>x \<in> I. A(x)) Co B"
by (unfold Constrains_def constrains_def, auto)

lemma stable_Join_Stable:
 "\<lbrakk>F \<in> stable({s \<in> state. P(f(s), g(s))});
     \<forall>k \<in> A. F \<squnion> G \<in> Stable({s \<in> state. P(k, g(s))});
     G \<in> preserves(f); \<forall>s \<in> state. f(s):A\<rbrakk>
  \<Longrightarrow> F \<squnion> G \<in> Stable({s \<in> state. P(f(s), g(s))})"
  unfolding stable_def Stable_def preserves_def
apply (rule_tac A = "(\<Union>k \<in> A. {s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))})" in Constrains_weaken_L)
prefer 2 apply blast
apply (rule Constrains_UN_left, auto)
apply (rule_tac A = "{s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))} \<inter> {s \<in> state. P (k, g (s))}" and A' = "({s \<in> state. f(s)=k} \<union> {s \<in> state. P (f (s), g (s))}) \<inter> {s \<in> state. P (k, g (s))}" in Constrains_weaken)
 prefer 2 apply blast
 prefer 2 apply blast
apply (rule Constrains_Int)
apply (rule constrains_imp_Constrains)
apply (auto simp add: constrains_type [THEN subsetD])
apply (blast intro: constrains_weaken)
apply (drule_tac x = k in spec)
apply (blast intro: constrains_weaken)
done

end


theory Mikes_attempt_2
imports Main HOL.List
begin

datatype PCW =
  A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8
| OK | idleW | OOM | FinishedW

datatype PCR =
  R1 | idleR

datatype F = W | R | Q | B
datatype Pointer = Head | Tail
consts n :: nat   (*size of buffer, input*)
consts N :: nat   (*number of Arr\<^sub>W entries*)

definition "F1_set={W,B,Q,R}"

(*Recorded variables*)
record rb_state =
  H :: nat
  T :: nat
  hW ::  nat               (*local copy of W*)
  tW ::  nat               (*local copy of W*)
  q :: "(nat \<times> nat) list"
  pcW :: PCW           (*records program counter of W*)
  pcR :: PCR           (*records program counter of W*)
  tempR :: "(nat \<times> nat)"          (*local copy of word by R*)
  arrayW:: "nat  \<Rightarrow> nat"     (*returns a word arrayW_i*)

  countW :: nat  (* the index of the next element of arrayW to be written  *)
  countR :: nat  (* how many words from arrayW the read has read or reading (i.e., retrieved)  *)
  ownAW :: "nat \<Rightarrow> F" (* ownership of arrayW indices *)
  ownB :: "nat \<Rightarrow> F" (* ownership of bytes in buffer *)

definition "con_assms s \<equiv>   0 < N \<and> 0<n \<and> countW s<n \<and> countR s\<le>countW s \<and> (\<forall>i.(i\<le>n)\<longrightarrow>arrayW s i<N \<and> arrayW s i>0)"

definition push_H :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`H := _" [200])
  where
  "push_H v \<equiv> \<lambda>s. s \<lparr>H := v\<rparr>"

definition push_T :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`T := _" [200])
  where
  "push_T v \<equiv> \<lambda>s. s \<lparr>T := v\<rparr>"

definition set_ownAW :: "nat \<Rightarrow> F \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`ownAW _ := _" [200])  where
  "set_ownAW ord v  \<equiv> \<lambda>s. s \<lparr> ownAW  := ((ownAW s) (ord := v))\<rparr>"

definition set_ownB :: "nat \<times> nat \<Rightarrow> F \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`ownB _ := _" [200])  where
  "set_ownB a v  \<equiv>
      if fst a < snd a then
          (\<lambda>s. s \<lparr> ownB  := \<lambda> i. if fst a \<le> i \<and> i < snd a then v else ownB s i \<rparr>)
      else
          (\<lambda>s. s \<lparr> ownB  := \<lambda> i. if (fst a < i \<and> i \<le> snd a)\<or>(i=N) then ownB s i else v \<rparr>)"

definition transfer_ownB :: "F \<Rightarrow> F \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`transownB _ := _" [200]) where
  "transfer_ownB a b \<equiv> \<lambda>s. s \<lparr> ownB := \<lambda> i. if ((ownB s) i = a) then b else (ownB s) i\<rparr>"

definition set_hW :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`hW := _" [200])  where
  "set_hW v  \<equiv> \<lambda>s. s \<lparr> hW  := v\<rparr>"

definition set_tW :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`tW := _" [200])  where
  "set_tW v  \<equiv> \<lambda>s. s \<lparr> tW  := v\<rparr>"

definition set_tempR :: "(nat \<times> nat) \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`tempR := _" [200]) where
  "set_tempR v \<equiv> \<lambda>s. s \<lparr> tempR := v\<rparr>"

definition update_countW :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`countW := _" [200]) where
  "update_countW v\<equiv> \<lambda>s. s \<lparr> countW := v\<rparr>"

definition update_countR :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`countR := _" [200]) where
  "update_countR v\<equiv> \<lambda>s. s \<lparr> countR := v\<rparr>"

definition update_pcW :: "PCW \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`pcW := _" [200]) where
  "update_pcW v \<equiv> \<lambda>s. s \<lparr> pcW := v\<rparr>"

definition update_pcR :: "PCR \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`pcR := _" [200]) where
  "update_pcR v \<equiv> \<lambda>s. s \<lparr> pcR := v\<rparr>"

abbreviation update_b_err :: "rb_state \<Rightarrow> rb_state" ("ERROOM") where
  "update_b_err \<equiv> \<lambda>s. s \<lparr> pcW := OOM \<rparr>"

definition update_q :: "(nat \<times> nat) list \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`q := _" [200])
  where
  "update_q v  \<equiv> \<lambda>s. s \<lparr>q := v\<rparr>"

lemmas functs [simp] = push_H_def push_T_def set_hW_def set_tW_def
                        update_countW_def update_countR_def
                        set_tempR_def
                        update_pcW_def update_pcR_def
                        set_ownAW_def set_ownB_def
                        update_q_def transfer_ownB_def

(*  Define the if statement "guards"  *)

definition "off bo \<equiv> fst bo"
definition "len bo \<equiv> snd bo"
definition "grd1 s \<equiv> (tW s = hW s) \<and> (arrayW s (countW s) \<le> N)"
definition "grd2 s \<equiv> (tW s > hW s) \<and> (arrayW s (countW s) < (tW s - hW s))"
definition "grd3 s \<equiv> tW s < hW s"
definition "grd4 s \<equiv> arrayW s (countW s) \<le> N - hW s"
definition "grd5 s \<equiv> arrayW s (countW s) < tW s"
definition "no_space_for_word s \<equiv> (grd1 s \<longrightarrow> \<not>(arrayW s (countW s) \<le> N))\<and>
                                  (grd2 s \<longrightarrow> \<not>(arrayW s (countW s) < (tW s - hW s)))\<and>
                                  (grd3 s \<longrightarrow> \<not>(arrayW s (countW s) \<le> N - hW s \<or> arrayW s (countW s) < tW s))"
lemmas grd_simps [simp] = off_def len_def grd1_def grd2_def grd3_def grd4_def grd5_def no_space_for_word_def
(***********************************************************************)

(*  Initial State  *)

definition "init s \<equiv> (H s = 0) \<and> (T s = 0) \<and> q s = [] \<and> (hW s = 0) \<and> (tW s = 0)
                        \<and> ( pcW s = idleW)
                        \<and> ( pcR s = idleR)
                        \<and> (\<forall>l. (l<n) \<longrightarrow>  ((arrayW s l > 0)\<and>(arrayW s l < N)))
                        \<and> (\<forall>i. (i<n) \<longrightarrow>  ownAW s i = W)
                        \<and> (\<forall>i. (i\<le>N) \<longrightarrow>  ownB s i = B)
                        \<and> (countW s = 0) \<and> (countR s = 0)
                        \<and> (tempR s = (0,0))"
(***********************************************************************)

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

(*Writer Thread Behaviour*)

fun rbW_step :: "PCW \<Rightarrow> rb_state \<Rightarrow> rb_state" where
  "rbW_step A1 s = ((`hW := (H s)) \<circ> (`tW := (T s)) \<circ> (`pcW := A2)) s "
| "rbW_step A2 s = (if grd1 s then (`pcW := A3)
                     else if grd2 s then (`pcW := A4)
                     else if grd3 s then (`pcW := A5)
                     else (`pcW :=A8)) s"
| "rbW_step A3 s = ((`T := 0) \<circ> (`H := (arrayW s (countW s))) \<circ> (`pcW := OK)
                        \<circ> (`ownB (0,arrayW s (countW s)):= W)) s"
| "rbW_step A4 s = ((`H := ((H s) + (arrayW s (countW s))))  \<circ> (`pcW := OK)
                        \<circ> (`ownB (H s,H s+arrayW s (countW s)) := W)) s"
| "rbW_step A5 s = (if grd4 s then (`pcW := A6)
                     else if grd5 s then (`pcW := A7)
                     else (`pcW := A8)) s"
| "rbW_step A6 s = (`H := ((H s) + (arrayW s (countW s))) \<circ> (`pcW := OK)
                        \<circ> (`ownB (H s,H s+arrayW s (countW s)) := W)) s"
| "rbW_step A7 s = ((`H := (arrayW s (countW s))) \<circ> (`pcW := OK)
                        \<circ> (`ownB (H s,arrayW s (countW s)) := W)) s"
| "rbW_step A8 s = (if ((arrayW s (countW s))>N) then (ERROOM)
                        else (`pcW := idleW)) s"

definition "acq s s' \<equiv> ((pcW s \<in> {idleW})
                            \<and> (arrayW s (countW s)) > 0
                            \<and> s' = (`pcW := A1) s)"

definition cW_step :: "PCW \<Rightarrow> rb_state \<Rightarrow> rb_state \<Rightarrow> bool" where
 "cW_step pcw s s' \<equiv>
    case pcw of
        OK \<Rightarrow>  s' = (`q:=(append (q s) [(H s-arrayW s (countW s),arrayW s (countW s))])
                     \<circ> `ownAW (countW s):=Q
                     \<circ> `transownB W := Q
                     \<circ> `pcW := idleW
                     \<circ> `countW := (countW s + 1)) s
      | idleW \<Rightarrow> if (countW s < n)
                      then acq s s'
                 else s' = (`pcW := FinishedW) s
      | OOM  \<Rightarrow> s = s'
      | FinishedW \<Rightarrow> s = s'
      | _  \<Rightarrow>  s' = rbW_step pcw s "
(***********************************************************************)

(*Reader Thread Behaviour*)
fun rbR_step :: "PCR \<Rightarrow> rb_state \<Rightarrow> rb_state" where
   "rbR_step R1 s = (`T := (off(tempR s) +len(tempR s)) \<circ> (`pcR := idleR) \<circ> (`tempR := (0,0))
                       \<circ> (`transownB R :=B)) s"

definition "read s s' \<equiv> (let q_hd = hd (q s) ;
                             q_tl = tl (q s)
                                 in s' = (`q:= q_tl
                                          \<circ> `pcR := R1
                                          \<circ> `tempR := q_hd
                                          \<circ> `countR := ((countR s) +1)
                                          \<circ> `ownAW (countR s):=R
                                          \<circ> `ownB (T s,off(q_hd)+len(q_hd)):=R) s)"

definition cR_step :: "PCR \<Rightarrow> rb_state \<Rightarrow> rb_state \<Rightarrow> bool" where
 "cR_step pcr s s' \<equiv>
    case pcr of
        idleR \<Rightarrow> if (q s=[]) then (s=s') else (read s s')
      | R1 \<Rightarrow>  s' = rbR_step R1 s"
(***********************************************************************)

(*all the read stuff at the end goes here *)

(*ownAW structure - dependancy on counters*)

(*
ArrayW  = [W W W W W W W]
          CountR = 0
          CountW = 0

ArrayW  = [Q W W W W W W]
          CountR = 0
          CountW = 1

ArrayW  = [R R .. R    Q Q Q     W W W W]
           0           CountR    CountW

Rely / Guarantee \<longrightarrow>
We may need this. Q' = Q . X \<longrightarrow> X = ArrayW[CountW] This is a guarantee of the writer and also a rely of the reader.
*)

definition "inRange v \<equiv> 0 \<le> v \<and> v \<le> N"
definition "inRangeHT s \<equiv> inRange (H s) \<and> inRange (T s)"
definition "H0_T0 s \<equiv> H s = 0 \<longrightarrow> T s = 0"
definition "inRangeht s \<equiv> inRange (hW s) \<and> inRange (tW s)"
definition "basic_pointer_movement s \<equiv> inRangeHT s \<and> inRangeht s \<and> H0_T0 s "

lemmas basic_pointer_movement_lemmas [simp] = basic_pointer_movement_def inRangeHT_def inRangeht_def H0_T0_def inRange_def

definition "arrayInv s \<equiv> \<forall> i. (i<countR s \<longrightarrow> ownAW s i=R) \<and> (countR s \<le> i \<and> i < countW s \<longrightarrow> ownAW s i = Q) \<and> (countW s \<le> i \<and> i < n \<longrightarrow> ownAW s i = W) "
definition "inv_step_by_step s \<equiv> fst (tempR s) + snd (tempR s) \<le> N"
definition "q_entries_bounded s \<equiv> q s\<noteq>[]\<longrightarrow>(\<forall>i.(i<length(q s))\<longrightarrow>(fst(q s!i)+snd(q s!i)\<le>N))"
definition "counter_diff_imp s \<equiv> (countW s>countR s\<longrightarrow> H s>0)\<and> (((countW s=countR s)\<and>len(tempR s)>0)\<longrightarrow>H s>0)"
definition "T__overlap_def s \<equiv> (T s>off(hd(q s))+len(hd(q s)) \<and> snd(tempR s)\<noteq>0\<longrightarrow>(\<forall>i.(i<N \<and>i\<ge>T s\<or>i<off(hd(q s)))\<longrightarrow>ownB s i=R))\<or>(T s>off(hd(q s))+len(hd(q s)) \<and> snd(tempR s) =0\<longrightarrow>(\<forall>i.(i<N \<and>i\<ge>T s\<or>i<off(hd(q s)))\<longrightarrow>ownB s i=Q))"
definition "counter_q_rel s \<equiv> countW s-countR s=length(q s)"

definition inv :: "PCW\<Rightarrow>PCR\<Rightarrow>rb_state \<Rightarrow> bool " where
"inv pcw pcr s \<equiv> basic_pointer_movement s
               \<and> arrayInv s
               \<and> inv_step_by_step s
               \<and> q_entries_bounded s
               \<and> counter_diff_imp s
               \<and> T__overlap_def s
               \<and> counter_q_rel s
  \<and> (case pcw of
      A1 \<Rightarrow> countW s<n
    | A2 \<Rightarrow> countW s<n  \<and> hW s=H s
    | A3 \<Rightarrow> countW s<n \<and> grd1 s \<and> hW s=H s
    | A4 \<Rightarrow> countW s<n \<and> grd2 s \<and> hW s=H s
    | A5 \<Rightarrow> countW s<n \<and> grd3 s \<and> hW s=H s
    | A6 \<Rightarrow> countW s<n \<and> grd4 s \<and> grd3 s \<and> hW s=H s \<and> H s+arrayW s (countW s)\<le>N
    | A7 \<Rightarrow> countW s<n \<and> grd5 s \<and> grd3 s \<and> hW s=H s
    | A8 \<Rightarrow> countW s<n \<and> no_space_for_word s \<and> hW s=H s
    | OK \<Rightarrow> countW s<n \<and> H s>0
    | idleW \<Rightarrow> (countW s=0\<longrightarrow>q s=[])
    | OOM \<Rightarrow> True
    | FinishedW \<Rightarrow> countW s=n)
  \<and> (case pcr of
      R1 \<Rightarrow> countR s>0 \<and> countR s\<le>n \<and> (H s\<noteq>0)
    | idleR \<Rightarrow> countR s\<le>n+1)
"

lemmas inv_simps =  inv_def cW_step_def cR_step_def init_def

lemmas invariant_lemmas [simp] = con_assms_def arrayInv_def inv_step_by_step_def
                          q_entries_bounded_def counter_diff_imp_def
                          T__overlap_def_def counter_q_rel_def

lemma inv_init:
  assumes "init s"
  and "con_assms s"
  shows "inv idleW idleR s"
  using assms
  by (simp add: inv_simps)

lemma if_idleR_and_countR_eq_countW:
  assumes "con_assms s"
  and "inv (pcW s) (pcR s) s"
  and "cR_step (pcR s) s s'"
  and "countR s = countW s"
shows "(pcR s=idleR \<longrightarrow> pcR s'=idleR)\<and>(pcR s=R1\<longrightarrow>pcR s'=idleR)"
  using assms
  apply(simp_all add:inv_def cR_step_def)
  by(case_tac "pcR s", simp_all)

lemma inv_local_R_int:
  assumes "con_assms s"
  and "pcr = pcR s"
  and "pcw = pcW s"
  and "inv pcw pcr s"
  and "cR_step pcr s s'"
shows "inv pcw (pcR s') s'"
  using assms
  apply(simp add: inv_def)
  apply(intro conjI, elim conjE, simp_all)
  apply(case_tac[!] "pcR s", simp_all add: read_def cR_step_def)
  apply(case_tac[!] "q s = []", simp_all add:read_def Let_def)
  apply(case_tac[!] "T s < fst (hd (q s)) + snd (hd (q s))", simp_all add:hd_conv_nth nth_tl)
  apply auto[1]
  apply auto[1]
  apply auto[1]
  apply auto[1]
  by((case_tac "pcW s", simp_all, linarith, linarith, force)|auto)+

lemma writer_OK_to_idleW_count_equal:
  assumes "con_assms s"
  and "inv OK idleR s"
  and "cW_step OK s s'"
  and "countW s=countR s"
shows "countW s'>countW s \<and> pcW s'=idleW \<and> length(q s') =1 \<and> H s>0"
  using assms
  by(simp_all add:inv_def cW_step_def)

lemma inv_local_W_int:
  assumes "con_assms s"
  and "pcr = pcR s"
  and "pcw = pcW s"
  and "inv pcw pcr s"
  and "cW_step pcw s s'"
shows "inv (pcW s') pcr s'"
  using assms
  apply(simp_all add: inv_def cW_step_def, intro conjI impI)
  apply(case_tac[!] "pcW s", simp_all, linarith)
  apply(case_tac[!] "pcR s", simp_all add:less_imp_le_nat acq_def)
  apply(case_tac "tW s=H s", simp_all ;case_tac "H s < tW s \<and> arrayW s (countW s) < tW s - H s", simp_all ;case_tac "tW s < H s", simp_all)
  apply(case_tac "tW s=H s", simp_all ;case_tac "H s < tW s", simp_all; case_tac "arrayW s (countW s) < tW s - H s", simp_all)
  apply(case_tac[1-2] "arrayW s (countW s) \<le> N - H s", simp_all,case_tac[1-2] "arrayW s (countW s) < tW s", simp_all)
  apply(metis less_imp_le less_numeral_extra(3),metis less_imp_le less_numeral_extra(3))
  apply(case_tac[1-2] "N < arrayW s (countW s)", simp_all)
  apply(case_tac "tW s=H s", simp_all; case_tac "H s < tW s \<and> arrayW s (countW s) < tW s - H s", simp_all; case_tac "tW s < H s", simp_all)
  apply(case_tac "tW s=H s", simp_all; case_tac "H s < tW s", simp_all; case_tac "arrayW s (countW s) < tW s - H s", simp_all)
  apply(case_tac[1-2] "arrayW s (countW s) \<le> N - H s", simp_all,case_tac[1-2] "arrayW s (countW s) < tW s", simp_all)
  apply(case_tac[1-2] "N < arrayW s (countW s)", simp_all)
  apply(smt add.commute add_cancel_right_left diff_is_0_eq' fst_conv le_less_linear less_Suc0 less_SucE less_imp_le list.size(3) nth_append nth_append_length ordered_cancel_comm_monoid_diff_class.add_diff_inverse snd_conv)
  apply(smt add.commute add_cancel_right_left diff_is_0_eq' fst_conv le_less_linear less_Suc0 less_SucE less_imp_le list.size(3) nth_append nth_append_length ordered_cancel_comm_monoid_diff_class.add_diff_inverse snd_conv)
  apply(case_tac "tW s = H s", simp_all;case_tac " H s < tW s \<and> arrayW s (countW s) < tW s - H s", simp_all; case_tac "tW s < H s", simp_all)
  apply(case_tac[1-2] "N < arrayW s (countW s)", simp_all add:cW_step_def, meson le_eq_less_or_eq not_le)
  apply(case_tac "tW s = H s \<and> arrayW s (countW s) \<le> N", simp_all; case_tac "H s < tW s \<and> arrayW s (countW s) < tW s - H s", simp_all; case_tac "tW s < H s", simp_all)
  apply(case_tac "N < arrayW s (countW s)", simp_all add: Suc_diff_le)
  apply(case_tac "arrayW s (countW s) \<le> N - H s", simp_all add:Nat.le_diff_conv2)
  by(case_tac "N < arrayW s (countW s)", simp_all, force)

lemma R_doesnt_move_H:
  assumes "con_assms s"
  and "cR_step (pcR s) s s'"
shows "H s' = H s"
  using assms
  apply (simp_all add: cR_step_def)
  apply (cases "pcR s", simp_all)
  apply (case_tac "q s = []", simp_all)
  by (simp add: read_def Let_def)

lemmas moves = R_doesnt_move_H

lemma inv_counter_relationship:
  assumes "con_assms s"
  and "inv A4 (pcR s) s"
  and "cW_step A4 s s'"
shows "hW s'= H s"
  using assms
  by (simp add: inv_def cW_step_def)

lemma inv_global_R_int:
  assumes "con_assms s"
  and "pcr = pcR s"
  and "pcw = pcW s"
  and "inv pcw pcr s"
  and "cR_step pcr s s'"
shows "inv (pcW s') (pcR s') s'"
  using assms
  apply(simp add: inv_def)
  apply(intro conjI, elim conjE)
  apply(simp add: cR_step_def)
  apply(case_tac[!] "pcR s", simp_all add: read_def)
  apply(case_tac[!] "q s = []", simp_all add: cR_step_def read_def Let_def)
  apply(case_tac[!] "T s < fst (hd (q s)) + snd (hd (q s))", simp_all add: hd_conv_nth nth_tl)
  apply force
  apply force
  apply force
  apply force
  apply(case_tac[1-8] "pcW s", simp_all, (linarith, linarith, force)+)
  by auto+

lemma inv_global_W_int:
  assumes "con_assms s"
  and "pcr = pcR s"
  and "pcw = pcW s"
  and "countR s<countW s"
  and "inv pcw pcr s"
  and "cW_step pcw s s'"
shows "inv (pcW s') (pcR s') s'"
  using assms
  apply(simp_all add: inv_def cW_step_def, intro conjI impI)
  apply(simp_all add: cW_step_def inv_def)
  apply(case_tac[!] "pcW s", simp_all, linarith)
  apply(case_tac[!] "pcR s", simp_all add:less_imp_le_nat acq_def)
  apply(case_tac "tW s=H s", simp_all ;case_tac "H s < tW s \<and> arrayW s (countW s) < tW s - H s", simp_all ;case_tac "tW s < H s", simp_all)
  apply(case_tac "tW s=H s", simp_all ;case_tac "H s < tW s", simp_all; case_tac "arrayW s (countW s) < tW s - H s", simp_all)
  apply(case_tac[1-2] "arrayW s (countW s) \<le> N - H s", simp_all, case_tac[1-2] "arrayW s (countW s) < tW s", simp_all)
  apply(metis less_imp_le less_numeral_extra(3),metis less_imp_le less_numeral_extra(3))
  apply(case_tac[1-2] "N < arrayW s (countW s)", simp_all)
  apply(case_tac[1-2] "tW s = H s", simp_all, case_tac[1-2] "H s < tW s \<and> arrayW s (countW s) < tW s - H s", simp_all, case_tac[1-2] "tW s < H s", simp_all)
  apply(case_tac[1-2] "arrayW s (countW s) \<le> N - H s", simp_all, case_tac[1-2] "arrayW s (countW s) < tW s", simp_all)
  apply(case_tac[1-2] "N < arrayW s (countW s)", simp_all)
  apply(smt add.commute add_cancel_right_left diff_is_0_eq' fst_conv le_less_linear less_Suc0 less_SucE less_imp_le list.size(3) nth_append nth_append_length ordered_cancel_comm_monoid_diff_class.add_diff_inverse snd_conv)
  apply(smt add.commute add_cancel_right_left diff_is_0_eq' fst_conv le_less_linear less_Suc0 less_SucE less_imp_le list.size(3) nth_append nth_append_length ordered_cancel_comm_monoid_diff_class.add_diff_inverse snd_conv)
  by linarith+

lemma pcR_stable_ext:
  "con_assms s \<Longrightarrow> cW_step (pcW s) s s' \<Longrightarrow> pcR s= pcR s'"
  apply (simp_all add:cW_step_def )
  by(case_tac "pcW s", simp_all add:acq_def)

lemma pcW_stable_ext:
  "con_assms s \<Longrightarrow> cR_step (pcR s) s s' \<Longrightarrow> pcW s= pcW s'"
  apply(simp_all add:cR_step_def)
  by(cases "pcR s", simp_all, cases"q s=[]", simp_all add:read_def Let_def)

lemma W_doesnt_move_T:
  assumes "H s\<noteq> T s"
  and "H s\<noteq>0"
  and "cW_step (pcW s) s s'"
  and "pcW s\<noteq> A3"
shows "T s = T s'"
  using assms
  apply(simp_all add:cW_step_def)
  by(cases "pcW s", simp_all, case_tac "countW s < n", simp_all add:acq_def)

(**********************************************************************
(* Define the states threads can find themselves in *)

definition "ACQ_PCW \<equiv> {A2, A3, A4, A5, A6, A7, A8, A1, OK}"
definition "EXT_PCW \<equiv> {OOM, idleW, FinishedW} \<union> {OK}"
definition "ACQ_PCR \<equiv> {R1}"
definition "EXT_PCR \<equiv> {idleR}"
**********************************************************************)

(*
definition "ownAW_and_countR s \<equiv> (\<forall>i.(i<countR s)\<longrightarrow>ownAW s i=R)\<and>
                                (\<forall>j.(j>countR s \<and> j<n)\<longrightarrow>(ownAW s j=Q \<or> ownAW s j=W))"

definition "ownAW_and_countW s \<equiv> (\<forall>i.((i>countW s)\<and>(i<n))\<longrightarrow>ownAW s i=W)\<and>
                                (\<forall>j.(j<countW s)\<longrightarrow>(ownAW s j=Q \<or> ownAW s j=R))"

definition "Q_has_ownAW s \<equiv> q s\<noteq>[] \<longrightarrow> (\<exists>i.(i<n \<and> ownAW s i=Q))" (* Mike says we might need this *)

definition "ownership_0 s \<equiv> ownAW_and_countR s \<and> ownAW_and_countW s \<and> Q_has_ownAW s"

lemmas ownership_0_lemmas [simp] = ownership_0_def ownAW_and_countR_def ownAW_and_countW_def Q_has_ownAW_def
*)

(*

(*Defining position of H w.r.t. ownB*)
definition "Has_this_ownB v s \<equiv> \<exists>i.(i<N \<and> ownB s i=v)"
definition "This_ownB_no_wrap v s \<equiv> (ownB s 0=v \<and> ownB s (N-1)\<noteq>v) \<or>
                                    (ownB s 0\<noteq>v \<and> ownB s (N-1)=v) \<or>
                                    (ownB s 0\<noteq>v \<and> ownB s (N-1)\<noteq>v) \<or>
                                    (\<forall>i.(i<N)\<longrightarrow>ownB s i=v)"
definition "H_ownB_relationship s \<equiv>
                      if  Has_this_ownB W s then
                            if This_ownB_no_wrap W s then
                                   \<exists>i. (i<N \<and> ownB s i=W \<and> ownB s (i+1) =B  \<and> H s=i+1)
                            else (\<exists>i. (i<(N-1) \<and> (ownB s i=W)\<and>(ownB s (i+1) =B) \<and> H s=i+1))

                 else if  Has_this_ownB Q s then
                            if This_ownB_no_wrap Q s then
                                   \<exists>i. (i<N \<and> ownB s i=Q \<and> ownB s (i+1) =B  \<and> H s=i+1)
                            else (\<exists>i. (i<(N-1) \<and> (ownB s i=Q)\<and>(ownB s (i+1) =B) \<and> H s=i+1))

                 else if  Has_this_ownB R s then
                            if This_ownB_no_wrap R s then
                                   \<exists>i. (i<N \<and> ownB s i=R \<and> ownB s (i+1) =B  \<and> H s=i+1)
                            else (\<exists>i. (i<(N-1) \<and> (ownB s i=R)\<and>(ownB s (i+1) =B) \<and> H s=i+1))

                  else H s\<le>N \<and> H s=T s"

(*Defining position of T w.r.t. ownB*)

definition "This_ownB_all_bytes v s \<equiv> \<forall>i.(i<N)\<longrightarrow>ownB s i=v"

definition "T_ownB_relationship s \<equiv>
                      if  Has_this_ownB R s then
                            if This_ownB_all_bytes R s then
                                T s=0
                            else if ownB s 0=R \<and> ownB s (N-1)\<noteq>R then
                                T s=0 \<or> T s=N
                            else
                                \<exists>i.(i>0\<and>i<N\<and> ownB s i=R \<and> ownB s (i-1) =B \<and> T s=i)
                 else if  Has_this_ownB Q s then
                            if This_ownB_all_bytes Q s then
                                T s=0
                            else if ownB s 0=Q \<and> ownB s (N-1)\<noteq>Q then
                                T s=0 \<or> T s=N
                            else
                                \<exists>i.(i>0\<and>i<N\<and> ownB s i=Q \<and> ownB s (i-1) =B \<and> T s=i)
                 else if  Has_this_ownB W s then
                            if This_ownB_all_bytes W s then
                                T s=0
                            else if ownB s 0=W \<and> ownB s (N-1)\<noteq>W then
                                T s=0 \<or> T s=N
                            else
                                \<exists>i.(i>0\<and>i<N\<and> ownB s i=Q \<and> ownB s (i-1) =B \<and> T s=i)
                 else T s\<le>N \<and> T s=H s"

(*the following requires careful handling of the "extra" byte - aka byte gap between T and new H*)
(*ownB structure *)
definition "B_has_enough_ownB_for v s \<equiv> ownB s N=B \<and> (if v=grd1 s then (\<forall>i.(i<N)\<longrightarrow>ownB s i=B)
                                  else if v=grd2 s then (\<forall>i.(hW s\<le>i \<and> i\<le>tempW s)\<longrightarrow>ownB s i=B)
                                  else if v=grd3 s \<and> grd4 s then (\<forall>i.(hW s\<le>i\<and> i\<le>hW s+tempW s)\<longrightarrow>ownB s i=B)
                                  else if v=grd3 s \<and> grd5 s then (\<forall>i.(hW s\<le>i\<and> i<N)\<longrightarrow>ownB s i=B)\<and>(\<forall>j.(j\<le>tempW s)\<longrightarrow>ownB s j=B)
                                  else True)"

(*Defining position of hW w.r.t. H and pcW*)
definition "hW_defined_for_pcW s \<equiv> if pcW s\<in>ACQ_PCW \<and> pcW s\<noteq>OK \<and> pcW s\<noteq>A1 then hW s=H s else hW s\<le>N"

(*Defining position of tW w.r.t. H and pcW*)
(*this has to be defined wrt grd - different pcW*)

(*Defining tempW w.r.t. countW*)
definition "tempW_defined s \<equiv> tempW s = arrayW s (countW s)\<and> tempW s>0"

(*Defining tempR w.r.t. countR and pcR*)
definition "tempR_defined s \<equiv> if (countR s>0 \<and> pcR s=R1) then
                                        ((len(tempR s) =arrayW s (countR s -1))\<and>(if (ownB s 0=R) then
                                                                                off(tempR s) =0
                                                                                else (\<exists>i.(i<N \<and> i>0 \<and> ownB s i=R \<and> ownB s (i-1)\<noteq>R \<and> off(tempR s) = i))))
                            else tempR s=(0,0)\<and>(\<forall>i.(i<N)\<longrightarrow>ownB s i\<noteq>R) "

definition "tempR_ownB_exclusivity s \<equiv>(snd(tempR s)\<noteq>0)\<longrightarrow>(\<forall>i.(i<snd(tempR s))\<longrightarrow>ownB s (fst(tempR s)+i) =R)"

definition "tempR_pair_property s \<equiv> (len(tempR s) =0 \<longrightarrow>off(tempR s) =0)\<and>(len(tempR s)+off(tempR s)\<le>N)"

definition "tempR_T_ownB_relation s\<equiv> if T s\<noteq>off(tempR s)\<and> pcR s=R1 then (\<forall>i.(i<N \<and>i\<ge>T s)\<longrightarrow>ownB s i=R)
                                      else (\<forall>i.(i<T s)\<longrightarrow>ownB s i\<noteq>R)"

(*Defining arrayW*)
definition "setup_arrayW s \<equiv> \<forall>l. (l<n) \<longrightarrow>  (arrayW s l > 0 \<and> arrayW s l < N)"

definition "rb_structure s \<equiv> H_ownB_relationship s \<and> T_ownB_relationship s \<and> hW_defined_for_pcW s
                                        \<and> tempR_defined s \<and> tempW_defined s \<and> tempR_T_ownB_relation s \<and> setup_arrayW s"

lemmas rb_structure_lemmas = rb_structure_def Has_this_ownB_def This_ownB_no_wrap_def H_ownB_relationship_def  T_ownB_relationship_def
                              hW_defined_for_pcW_def tempR_defined_def tempW_defined_def tempR_pair_property_def tempR_T_ownB_relation_def setup_arrayW_def This_ownB_all_bytes_def

(*q structure*)
definition "q_contains_arrayW_things s \<equiv> (length(q s) = countW s-countR s)\<longrightarrow>(\<forall>i.(i<length(q s))\<longrightarrow>len(q s!i) =arrayW s (i+countR s))"

definition "at_most_one_zero_offset s \<equiv> ((len(tempR s)\<noteq>0) \<and> off(tempR s) =0 \<and> (\<not>(\<exists>i.(i<length(q s)\<and>off(q s !i) =0))))
                                       \<or>((\<exists>j.(j<length(q s)\<and>off(q s!j) =0 \<and> (\<not>(\<exists>k.(k<length(q s)\<and>k\<noteq>j\<and>off(q s!k) =0))))) \<and> (len(tempR s)\<noteq>0\<longrightarrow>off(tempR s)\<noteq>0))
                                       \<or>(\<not>(\<exists>z.(z<length(q s)\<and>off(q s!z) =0)) \<and> (len(tempR s)\<noteq>0\<longrightarrow>off(tempR s)\<noteq>0))"
definition "q_pair_property s \<equiv> \<forall>i.(i<length(q s))\<longrightarrow>len(q s!i)>0\<and>len(q s!i)\<le>N\<longrightarrow>off(q s!i)+len(q s!i)\<le>N"
definition "q_entries_dont_cross s\<equiv> (\<forall>i.(i<length(q s))\<longrightarrow>(\<forall>j.(j<length(q s)\<and>j\<noteq>i)\<longrightarrow>(off(q s!j)\<ge>off(q s!i)+len(q s!i)\<or>off(q s!i)\<ge>off(q s!j)+len(q s!j))))
                                  \<and>(\<forall>k.(k<length(q s)\<longrightarrow>(off(q s!k)\<ge>off(tempR s)+len(tempR s)\<or>off(tempR s)\<ge>off(q s!k)+len(q s!k))))"
definition "q_ownB_relationship s \<equiv> \<forall>i.((i< length (q s))\<longrightarrow>(\<forall>j.(off(q s ! i)\<le>j\<and>j<off(q s ! i)+len(q s ! i))\<longrightarrow>ownB s j=Q))"
definition "q_structure s \<equiv> q_contains_arrayW_things s \<and> at_most_one_zero_offset s \<and> tempR_pair_property s \<and> q_pair_property s
                           \<and> q_entries_dont_cross s \<and> q_ownB_relationship s"
lemmas q_structure_lemmas = q_structure_def q_contains_arrayW_things_def at_most_one_zero_offset_def
                            q_pair_property_def q_entries_dont_cross_def q_ownB_relationship_def

(*  Constant Assumptions  *)

[!]
*)
(*
definition inv :: "PCW\<Rightarrow>PCR\<Rightarrow>rb_state \<Rightarrow> bool " where
"inv pcw pcr s \<equiv> basic_pointer_movement s
               \<and> q_structure s
               \<and> ownership_0 s
               \<and> rb_structure s
  \<and> (case pcw of
      A1 \<Rightarrow> countW s<n \<and> \<not>Has_this_ownB W s
    | A2 \<Rightarrow> countW s<n \<and> \<not>Has_this_ownB W s \<and> hW s=H s
    | A3 \<Rightarrow> B_has_enough_ownB_for (grd1 s) s \<and> countW s<n \<and> grd1 s \<and> hW s=H s \<and> \<not>Has_this_ownB W s
    | A4 \<Rightarrow> B_has_enough_ownB_for (grd2 s) s \<and> countW s<n \<and> grd2 s \<and> hW s=H s \<and> \<not>Has_this_ownB W s
    | A5 \<Rightarrow> countW s<n \<and> grd3 s \<and> hW s=H s \<and> \<not>Has_this_ownB W s
    | A6 \<Rightarrow> B_has_enough_ownB_for (grd4 s\<and>grd3 s) s \<and> countW s<n \<and> hW s=H s \<and> \<not>Has_this_ownB W s
    | A7 \<Rightarrow> B_has_enough_ownB_for (grd5 s\<and>grd3 s) s \<and> countW s<n \<and> hW s=H s \<and> \<not>Has_this_ownB W s
    | A8 \<Rightarrow> countW s<n \<and> grd5 s \<and> hW s=H s \<and> \<not>Has_this_ownB W s

    | OK \<Rightarrow> countW s<n
    | idleW \<Rightarrow> (countW s=0\<longrightarrow>q s=[]) \<and> \<not>Has_this_ownB W s
    | OOM \<Rightarrow> True \<and> \<not>Has_this_ownB W s
    | FinishedW \<Rightarrow> countW s=n) \<and> \<not>Has_this_ownB W s
  \<and> (case pcr of
      R1 \<Rightarrow> countR s>0 \<and> countR s\<le>n \<and> (\<exists>i.(i<N\<and>ownB s i=R))
    | idleR \<Rightarrow> (q s\<noteq>[]\<longrightarrow>Has_this_ownB Q s) \<and> countR s\<le>n+1)
"*)


theory Chisholm_B imports SDL                             (* Christoph Benzmüller, 2018 *)

begin (* Chisholm Example *)
 consts go::\<sigma> tell::\<sigma> kill::\<sigma>
 axiomatization where
  D1: "\<lfloor>\<^bold>O\<^bold>\<langle>go\<^bold>\<rangle>\<rfloor>" (*It ought to be that Jones goes to assist his neighbors.*) and
  D2: "\<lfloor>go \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>tell\<^bold>\<rangle>\<rfloor>"  (*It ought to be that if Jones goes, then he tells them he is coming.*) and
  D3: "\<lfloor>\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" (*If Jones doesn't go, then he ought not tell them he is coming.*) and
  D4: "\<lfloor>\<^bold>\<not>go\<rfloor>\<^sub>c\<^sub>w" (*Jones doesn't go. (This is encoded as a locally valid statement.)*)

 (*Some Experiments*)
  sledgehammer_params [max_facts=20] (*Sets default parameters for the theorem provers*)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (*... and for the model finder.*)

 lemma True  nitpick [satisfy] oops  (*Consistency-check: Is there a model?*)
 lemma False sledgehammer      oops  (*Inconsistency-check: Can Falsum be derived?*)

 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" sledgehammer  nitpick oops   (*Should James not tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>kill\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James kill?*)
end

(*
  D2: "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>|go\<^bold>\<rangle>\<rfloor>" and
  D3: "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>|\<^bold>\<not>go\<^bold>\<rangle>\<rfloor>" and
*)


(*  Title:      Pure/ex/Def_Examples.thy
    Author:     Makarius

Some examples for primitive definitions.
*)

theory Def_Examples
  imports Def
begin

section \<open>Global definitions\<close>

def "I x \<equiv> x"
def "K x y \<equiv> x"
def "S x y z \<equiv> (x z) (y z)"

lemma "I (I x) \<equiv> x"
  by simp

lemma "K a x \<equiv> K a y"
  by simp

lemma "S K K \<equiv> I"
  by simp

section \<open>Locale definitions\<close>

locale const =
  fixes a :: 'a
begin

def "fun b \<equiv> a"

lemma "fun x \<equiv> fun y"
  by simp

end

lemma "const.fun a x \<equiv> const.fun a y"
  by simp

end


theory SASP_Semantics
imports Main
begin

section \<open>Semantics of Fast-Downward's Multi-Valued Planning Tasks Language\<close>

subsection \<open>Syntax\<close>
  type_synonym name = string
  type_synonym ast_variable = "name \<times> nat option \<times> name list" (* var name, axiom layer, atom names *)
  type_synonym ast_variable_section = "ast_variable list"
  type_synonym ast_initial_state = "nat list"
  type_synonym ast_goal = "(nat \<times> nat) list"
  type_synonym ast_precond = "(nat \<times> nat)"
  type_synonym ast_effect = "ast_precond list \<times> nat \<times> nat option \<times> nat"
  type_synonym ast_operator = "name \<times> ast_precond list \<times> ast_effect list \<times> nat"
  type_synonym ast_operator_section = "ast_operator list"

  type_synonym ast_problem =
    "ast_variable_section \<times> ast_initial_state \<times> ast_goal \<times> ast_operator_section"

  type_synonym plan = "name list"

  subsubsection \<open>Well-Formedness\<close>

  locale ast_problem =
    fixes problem :: ast_problem
  begin
    definition astDom :: ast_variable_section (* TODO: Dom \<rightarrow> Vars, D \<rightarrow> X*)
      where "astDom \<equiv> case problem of (D,I,G,\<delta>) \<Rightarrow> D"
    definition astI :: ast_initial_state
      where "astI \<equiv> case problem of (D,I,G,\<delta>) \<Rightarrow> I"
    definition astG :: ast_goal
      where "astG \<equiv> case problem of (D,I,G,\<delta>) \<Rightarrow> G"
    definition ast\<delta> :: ast_operator_section
      where "ast\<delta> \<equiv> case problem of (D,I,G,\<delta>) \<Rightarrow> \<delta>"

    definition "numVars \<equiv> length astDom"
    definition "numVals x \<equiv> length (snd (snd (astDom!x)))"

    definition "wf_partial_state ps \<equiv>
        distinct (map fst ps)
      \<and> (\<forall>(x,v) \<in> set ps. x < numVars \<and> v < numVals x)"

    definition wf_operator :: "ast_operator \<Rightarrow> bool"
      where "wf_operator \<equiv> \<lambda>(name, pres, effs, cost).
        wf_partial_state pres
      \<and> distinct (map (\<lambda>(_, v, _, _). v) effs) \<comment> \<open>This may be too restrictive\<close>
      \<and> (\<forall>(epres,x,vp,v)\<in>set effs.
          wf_partial_state epres
        \<and> x < numVars \<and> v < numVals x
        \<and> (case vp of None \<Rightarrow> True | Some v \<Rightarrow> v<numVals x)
        )
    "

    definition "well_formed \<equiv>
      \<comment> \<open>Initial state\<close>
      length astI = numVars
    \<and> (\<forall>x<numVars. astI!x < numVals x)

      \<comment> \<open>Goal\<close>
    \<and> wf_partial_state astG

    \<comment> \<open>Operators\<close>
    \<and> (distinct (map fst ast\<delta>))
    \<and> (\<forall>\<pi>\<in>set ast\<delta>. wf_operator \<pi>)
    "

  end

  locale wf_ast_problem = ast_problem +
    assumes wf: well_formed
  begin
    lemma wf_initial:
      "length astI = numVars"
      "\<forall>x<numVars. astI!x < numVals x"
      using wf unfolding well_formed_def by auto

    lemma wf_goal: "wf_partial_state astG"
      using wf unfolding well_formed_def by auto

    lemma wf_operators:
      "distinct (map fst ast\<delta>)"
      "\<forall>\<pi>\<in>set ast\<delta>. wf_operator \<pi>"
      using wf unfolding well_formed_def by auto
  end

  subsection \<open>Semantics as Transition System\<close>

  type_synonym state = "nat \<rightharpoonup> nat"
  type_synonym pstate = "nat \<rightharpoonup> nat"

  context ast_problem
  begin

    definition Dom :: "nat set" where "Dom = {0..<numVars}"

    definition range_of_var where "range_of_var x \<equiv> {0..<numVals x}"

    definition valid_states :: "state set" where "valid_states \<equiv> {
      s. dom s = Dom \<and> (\<forall>x\<in>Dom. the (s x) \<in> range_of_var x)
    }"

    definition I :: state
      where "I v \<equiv> if v<length astI then Some (astI!v) else None"

    definition subsuming_states :: "pstate \<Rightarrow> state set"
      where "subsuming_states partial \<equiv> { s\<in>valid_states. partial \<subseteq>\<^sub>m s }"

    definition G :: "state set"
      where "G \<equiv> subsuming_states (map_of astG)"
end

    definition implicit_pres :: "ast_effect list \<Rightarrow> ast_precond list" where
      "implicit_pres effs \<equiv>
      map (\<lambda>(_,v,vpre,_). (v,the vpre))
          (filter (\<lambda>(_,_,vpre,_). vpre\<noteq>None) effs)"

context ast_problem
begin

    definition lookup_operator :: "name \<Rightarrow> ast_operator option" where
      "lookup_operator name \<equiv> find (\<lambda>(n,_,_,_). n=name) ast\<delta>"

    definition enabled :: "name \<Rightarrow> state \<Rightarrow> bool"
      where "enabled name s \<equiv>
        case lookup_operator name of
          Some (_,pres,effs,_) \<Rightarrow>
              s\<in>subsuming_states (map_of pres)
            \<and> s\<in>subsuming_states (map_of (implicit_pres effs))
        | None \<Rightarrow> False"

    definition eff_enabled :: "state \<Rightarrow> ast_effect \<Rightarrow> bool" where
      "eff_enabled s \<equiv> \<lambda>(pres,_,_,_). s\<in>subsuming_states (map_of pres)"

    definition execute :: "name \<Rightarrow> state \<Rightarrow> state" where
      "execute name s \<equiv>
        case lookup_operator name of
          Some (_,_,effs,_) \<Rightarrow>
            s ++ map_of (map (\<lambda>(_,x,_,v). (x,v)) (filter (eff_enabled s) effs))
        | None \<Rightarrow> undefined
        "

    fun path_to where
      "path_to s [] s' \<longleftrightarrow> s'=s"
    | "path_to s (\<pi>#\<pi>s) s' \<longleftrightarrow> enabled \<pi> s \<and> path_to (execute \<pi> s) \<pi>s s'"

    definition valid_plan :: "plan \<Rightarrow> bool"
      where "valid_plan \<pi>s \<equiv> \<exists>s'\<in>G. path_to I \<pi>s s'"

  end

  (*
    Next steps:
      * well-formed stuff
      * Executable SAS+ validator (well_formed and execute function)

  *)

  subsubsection \<open>Preservation of well-formedness\<close>
  context wf_ast_problem
  begin
    lemma I_valid: "I \<in> valid_states"
      using wf_initial
      unfolding valid_states_def Dom_def I_def range_of_var_def
      by (auto split:if_splits)

    lemma lookup_operator_wf:
      assumes "lookup_operator name = Some \<pi>"
      shows "wf_operator \<pi>" "fst \<pi> = name"
    proof -
      obtain name' pres effs cost where [simp]: "\<pi>=(name',pres,effs,cost)" by (cases \<pi>)
      hence [simp]: "name'=name" and IN_AST: "(name,pres,effs,cost) \<in> set ast\<delta>"
        using assms
        unfolding lookup_operator_def
        apply -
        apply (metis (mono_tags, lifting) case_prodD find_Some_iff)
        by (metis (mono_tags, lifting) case_prodD find_Some_iff nth_mem)

      from IN_AST show WF: "wf_operator \<pi>" "fst \<pi> = name"
        unfolding enabled_def using wf_operators by auto
    qed

    lemma execute_preserves_valid:
      assumes "s\<in>valid_states"
      assumes "enabled name s"
      shows "execute name s \<in> valid_states"
    proof -
      from \<open>enabled name s\<close> obtain name' pres effs cost where
        [simp]: "lookup_operator name = Some (name',pres,effs,cost)"
        unfolding enabled_def by (auto split: option.splits)
      from lookup_operator_wf[OF this] have WF: "wf_operator (name,pres,effs,cost)" by simp

      have X1: "s ++ m \<in> valid_states" if "\<forall>x v. m x = Some v \<longrightarrow> x<numVars \<and> v<numVals x" for m
        using that \<open>s\<in>valid_states\<close>
        by (auto
            simp: valid_states_def Dom_def range_of_var_def map_add_def dom_def
            split: option.splits)

      have X2: "x<numVars" "v<numVals x"
        if "map_of (map (\<lambda>(_, x, _, y). (x, y)) (filter (eff_enabled s) effs)) x = Some v"
        for x v
      proof -
        from that obtain epres vp where "(epres,x,vp,v) \<in> set effs"
          by (auto dest!: map_of_SomeD)
        with WF show "x<numVars" "v<numVals x"
          unfolding wf_operator_def by auto
      qed

      show ?thesis
        using assms
        unfolding enabled_def execute_def
        by (auto intro!: X1 X2)
    qed

    lemma path_to_pres_valid:
      assumes "s\<in>valid_states"
      assumes "path_to s \<pi>s s'"
      shows "s'\<in>valid_states"
      using assms
      by (induction s \<pi>s s' rule: path_to.induct) (auto simp: execute_preserves_valid)

  end

end


(* Author: Dmitriy Traytel, ported by Tobias Nipkow *)

section \<open>Finiteness of Derivatives Modulo ACI\<close>

(*<*)
(* split into Norm and Fin theories *)
theory Derivatives_Finite
imports "Regular-Sets.Derivatives"
begin
(*>*)

text \<open>Lifting constructors to lists\<close>

fun rexp_of_list where
  "rexp_of_list OP N [] = N"
| "rexp_of_list OP N [r] = r"
| "rexp_of_list OP N (r # rs) = OP r (rexp_of_list OP N rs)"

abbreviation "PLUS \<equiv> rexp_of_list Plus Zero"
abbreviation "TIMES \<equiv> rexp_of_list Times One"

lemma list_singleton_induct [case_names nil single cons]:
assumes "P []" and "\<And>x. P [x]" and "\<And>x y xs. P (y # xs) \<Longrightarrow> P (x # (y # xs))"
shows "P xs"
using assms by induction_schema (pat_completeness, lexicographic_order)

subsection \<open>ACI normalization\<close>

fun toplevel_summands :: "'a rexp \<Rightarrow> 'a rexp set" where
  "toplevel_summands (Plus r s) = toplevel_summands r \<union> toplevel_summands s"
| "toplevel_summands r = {r}"

abbreviation "flatten LISTOP X \<equiv> LISTOP (sorted_list_of_set X)"

lemma toplevel_summands_nonempty[simp]:
  "toplevel_summands r \<noteq> {}"
  by (induct r) auto

lemma toplevel_summands_finite[simp]:
  "finite (toplevel_summands r)"
  by (induct r) auto

primrec ACI_norm :: "('a::linorder) rexp \<Rightarrow> 'a rexp"  ("\<guillemotleft>_\<guillemotright>") where
  "\<guillemotleft>Zero\<guillemotright> = Zero"
| "\<guillemotleft>One\<guillemotright> = One"
| "\<guillemotleft>Atom a\<guillemotright> = Atom a"
| "\<guillemotleft>Plus r s\<guillemotright> = flatten PLUS (toplevel_summands (Plus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>))"
| "\<guillemotleft>Times r s\<guillemotright> = Times \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
| "\<guillemotleft>Star r\<guillemotright> = Star \<guillemotleft>r\<guillemotright>"

lemma Plus_toplevel_summands: "Plus r s \<in> toplevel_summands t \<Longrightarrow> False"
by (induction t) auto

lemma toplevel_summands_not_Plus[simp]:
  "(\<forall>r s. x \<noteq> Plus r s) \<Longrightarrow> toplevel_summands x = {x}"
by (induction x) auto

lemma toplevel_summands_PLUS_strong:
  "\<lbrakk>xs \<noteq> []; list_all (\<lambda>x. \<not>(\<exists>r s. x = Plus r s)) xs\<rbrakk> \<Longrightarrow> toplevel_summands (PLUS xs) = set xs"
  by (induct xs rule: list_singleton_induct) auto

lemma toplevel_summands_flatten:
  "\<lbrakk>X \<noteq> {}; finite X; \<forall>x \<in> X. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow> toplevel_summands (flatten PLUS X) = X"
  using toplevel_summands_PLUS_strong[of "sorted_list_of_set X"]
  unfolding list_all_iff by fastforce

lemma ACI_norm_Plus: "\<guillemotleft>r\<guillemotright> = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
by (induction r) auto

lemma toplevel_summands_flatten_ACI_norm_image:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r)) = ACI_norm ` toplevel_summands r"
by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus intro: Plus_toplevel_summands)

lemma toplevel_summands_flatten_ACI_norm_image_Union:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s)) =
    ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s"
by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus[OF sym] intro: Plus_toplevel_summands)

lemma toplevel_summands_ACI_norm:
  "toplevel_summands \<guillemotleft>r\<guillemotright> = ACI_norm ` toplevel_summands r"
by (induction r) (auto simp: toplevel_summands_flatten_ACI_norm_image_Union)

lemma ACI_norm_flatten:
  "\<guillemotleft>r\<guillemotright> = flatten PLUS (ACI_norm ` toplevel_summands r)"
by (induction r) (auto simp: image_Un toplevel_summands_flatten_ACI_norm_image)

theorem ACI_norm_idem[simp]: "\<guillemotleft>\<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induct r)
  case (Plus r s)
  have "\<guillemotleft>\<guillemotleft>Plus r s\<guillemotright>\<guillemotright> = \<guillemotleft>flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)\<guillemotright>"
    (is "_ = \<guillemotleft>flatten PLUS ?U\<guillemotright>") by simp
  also have "\<dots> = flatten PLUS (ACI_norm ` toplevel_summands (flatten PLUS ?U))"
    by (simp only: ACI_norm_flatten)
  also have "toplevel_summands (flatten PLUS ?U) = ?U"
    by (intro toplevel_summands_flatten) (auto intro: Plus_toplevel_summands)
  also have "flatten PLUS (ACI_norm ` ?U) = flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)"
    by (simp only: image_Un toplevel_summands_ACI_norm[symmetric] Plus)
  finally show ?case by simp
qed auto

subsection "Atoms"

lemma atoms_toplevel_summands:
  "atoms s = (\<Union>r\<in>toplevel_summands s. atoms r)"
by (induct s) auto

lemma wf_PLUS: "atoms (PLUS xs) \<subseteq> \<Sigma> \<longleftrightarrow> (\<forall>r \<in> set xs. atoms r \<subseteq> \<Sigma>)"
by (induct xs rule: list_singleton_induct) auto

lemma atoms_PLUS: "atoms (PLUS xs) = (\<Union>r \<in> set xs. atoms r)"
by (induct xs rule: list_singleton_induct) auto

lemma atoms_flatten_PLUS:
  "finite X \<Longrightarrow> atoms (flatten PLUS X) = (\<Union>r \<in> X. atoms r)"
using wf_PLUS[of "sorted_list_of_set X"] by auto

theorem atoms_ACI_norm: "atoms \<guillemotleft>r\<guillemotright> = atoms r"
proof (induct r)
  case (Plus r1 r2) thus ?case
   using atoms_toplevel_summands[of "\<guillemotleft>r1\<guillemotright>"] atoms_toplevel_summands[of "\<guillemotleft>r2\<guillemotright>"]
   by(simp add: atoms_flatten_PLUS ball_Un Un_commute)
qed auto

subsection "Language"

lemma toplevel_summands_lang: "r \<in> toplevel_summands s \<Longrightarrow> lang r \<subseteq> lang s"
by (induct s) auto

lemma toplevel_summands_lang_UN:
  "lang s = (\<Union>r\<in>toplevel_summands s. lang r)"
by (induct s) auto

lemma toplevel_summands_in_lang:
  "w \<in> lang s = (\<exists>r\<in>toplevel_summands s. w \<in> lang r)"
by (induct s) auto

lemma lang_PLUS: "lang (PLUS xs) = (\<Union>r \<in> set xs. lang r)"
by (induct xs rule: list_singleton_induct) auto

lemma lang_PLUS_map[simp]:
  "lang (PLUS (map f xs)) = (\<Union>a\<in>set xs. lang (f a))"
by (induct xs rule: list_singleton_induct) auto

lemma lang_flatten_PLUS[simp]:
  "finite X \<Longrightarrow> lang (flatten PLUS X) = (\<Union>r \<in> X. lang r)"
using lang_PLUS[of "sorted_list_of_set X"] by fastforce

theorem lang_ACI_norm[simp]: "lang \<guillemotleft>r\<guillemotright> = lang r"
proof (induct r)
  case (Plus r1 r2)
  moreover
  from Plus[symmetric] have "lang (Plus r1 r2) \<subseteq> lang \<guillemotleft>Plus r1 r2\<guillemotright>"
    using toplevel_summands_in_lang[of _ "\<guillemotleft>r1\<guillemotright>"] toplevel_summands_in_lang[of _ "\<guillemotleft>r2\<guillemotright>"]
    by auto
  ultimately show ?case by (fastforce dest!: toplevel_summands_lang)
qed auto

subsection \<open>Finiteness of ACI-Equivalent Derivatives\<close>

lemma toplevel_summands_deriv:
  "toplevel_summands (deriv as r) = (\<Union>s\<in>toplevel_summands r. toplevel_summands (deriv as s))"
by (induction r) (auto simp: Let_def)

lemma derivs_Zero[simp]: "derivs xs Zero = Zero"
by (induction xs) auto

lemma derivs_One: "derivs xs One \<in> {Zero, One}"
by (induction xs) auto

lemma derivs_Atom: "derivs xs (Atom as) \<in> {Zero, One, Atom as}"
proof (induction xs)
  case Cons thus ?case by (auto intro: insertE[OF derivs_One])
qed simp

lemma derivs_Plus: "derivs xs (Plus r s) = Plus (derivs xs r) (derivs xs s)"
by (induction xs arbitrary: r s) auto

lemma derivs_PLUS: "derivs xs (PLUS ys) = PLUS (map (derivs xs) ys)"
by (induction ys rule: list_singleton_induct) (auto simp: derivs_Plus)

lemma toplevel_summands_derivs_Times: "toplevel_summands (derivs xs (Times r s)) \<subseteq>
  {Times (derivs xs r) s} \<union>
  {r'. \<exists>ys zs. r' \<in> toplevel_summands (derivs ys s) \<and> ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induction xs arbitrary: r s)
  case (Cons x xs)
  thus ?case by (auto simp: Let_def derivs_Plus) (fastforce intro: exI[of _ "x#xs"])+
qed simp

lemma toplevel_summands_derivs_Star_nonempty:
  "xs \<noteq> [] \<Longrightarrow> toplevel_summands (derivs xs (Star r)) \<subseteq>
    {Times (derivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induction xs rule: length_induct)
  case (1 xs)
  then obtain y ys where "xs = y # ys" by (cases xs) auto
  thus ?case using spec[OF 1(1)]
    by (auto dest!: subsetD[OF toplevel_summands_derivs_Times] intro: exI[of _ "y#ys"])
       (auto elim!: impE dest!: meta_spec subsetD)
qed

lemma toplevel_summands_derivs_Star:
  "toplevel_summands (derivs xs (Star r)) \<subseteq>
    {Star r} \<union> {Times (derivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
by (cases "xs = []") (auto dest!: toplevel_summands_derivs_Star_nonempty)

lemma toplevel_summands_PLUS:
 "xs \<noteq> [] \<Longrightarrow> toplevel_summands (PLUS (map f xs)) = (\<Union>r \<in> set xs. toplevel_summands (f r))"
by (induction xs rule: list_singleton_induct) simp_all

lemma ACI_norm_toplevel_summands_Zero: "toplevel_summands r \<subseteq> {Zero} \<Longrightarrow> \<guillemotleft>r\<guillemotright> = Zero"
by (subst ACI_norm_flatten) (auto dest: subset_singletonD)

lemma finite_ACI_norm_toplevel_summands:
  "finite {f \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> B}" if "finite B"
proof -
  have *: "{f \<guillemotleft>s\<guillemotright> | s.
    toplevel_summands s \<subseteq> B} \<subseteq> (f \<circ> flatten PLUS \<circ> (`) ACI_norm) ` Pow B"
    by (subst ACI_norm_flatten) auto
  with that show ?thesis
    by (rule finite_surj [OF iffD2 [OF finite_Pow_iff]])
qed

theorem finite_derivs: "finite {\<guillemotleft>derivs xs r\<guillemotright> | xs . True}"
proof (induct r)
  case Zero show ?case by simp
next
  case One show ?case
   by (rule finite_surj[of "{Zero, One}"]) (blast intro: insertE[OF derivs_One])+
next
  case (Atom as) show ?case
    by (rule finite_surj[of "{Zero, One, Atom as}"]) (blast intro: insertE[OF derivs_Atom])+
next
  case (Plus r s)
  show ?case by (auto simp: derivs_Plus intro!: finite_surj[OF finite_cartesian_product[OF Plus]])
next
  case (Times r s)
  hence "finite (\<Union> (toplevel_summands ` {\<guillemotleft>derivs xs s\<guillemotright> | xs . True}))" by auto
  moreover have "{\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (derivs ys s)} =
    {r'. \<exists>ys. r' \<in> toplevel_summands \<guillemotleft>derivs ys s\<guillemotright>}"
    by (auto simp: toplevel_summands_ACI_norm)
  ultimately have fin: "finite {\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (derivs ys s)}"
    by (fastforce intro: finite_subset[of _ "\<Union> (toplevel_summands ` {\<guillemotleft>derivs xs s\<guillemotright> | xs . True})"])
  let ?X = "\<lambda>xs. {Times (derivs ys r) s | ys. True} \<union> {r'. r' \<in> (\<Union>ys. toplevel_summands (derivs ys s))}"
  show ?case
  proof (simp only: ACI_norm_flatten,
      rule finite_surj[of "{X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}" _ "flatten PLUS"])
    show "finite {X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}"
      using fin by (fastforce simp: image_Un elim: finite_subset[rotated] intro: finite_surj[OF Times(1), of _ "\<lambda>r. Times r \<guillemotleft>s\<guillemotright>"])
  qed (fastforce dest!: subsetD[OF toplevel_summands_derivs_Times] intro!: imageI)
next
  case (Star r)
  let ?f = "\<lambda>f r'. Times r' (Star (f r))"
  let ?X = "{Star r} \<union> ?f id ` {r'. r' \<in> {derivs ys r|ys. True}}"
  show ?case
  proof (simp only: ACI_norm_flatten,
      rule finite_surj[of "{X. X \<subseteq> ACI_norm ` ?X}" _ "flatten PLUS"])
    have *: "\<And>X. ACI_norm ` ?f (\<lambda>x. x) ` X = ?f ACI_norm ` ACI_norm ` X" by (auto simp: image_def)
    show "finite {X. X \<subseteq> ACI_norm ` ?X}"
      by (rule finite_Collect_subsets)
         (auto simp: * intro!: finite_imageI[of _ "?f ACI_norm"] intro: finite_subset[OF _ Star])
  qed (fastforce dest!: subsetD[OF toplevel_summands_derivs_Star] intro!: imageI)
qed

subsection \<open>Deriving preserves ACI-equivalence\<close>

lemma ACI_norm_PLUS:
  "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>) xs ys \<Longrightarrow> \<guillemotleft>PLUS xs\<guillemotright> = \<guillemotleft>PLUS ys\<guillemotright>"
proof (induct rule: list_all2_induct)
  case (Cons x xs y ys)
  hence "length xs = length ys" by (elim list_all2_lengthD)
  thus ?case using Cons by (induct xs ys rule: list_induct2) auto
qed simp

lemma toplevel_summands_ACI_norm_deriv:
  "(\<Union>a\<in>toplevel_summands r. toplevel_summands \<guillemotleft>deriv as \<guillemotleft>a\<guillemotright>\<guillemotright>) = toplevel_summands \<guillemotleft>deriv as \<guillemotleft>r\<guillemotright>\<guillemotright>"
proof (induct r)
  case (Plus r1 r2) thus ?case
   unfolding toplevel_summands.simps toplevel_summands_ACI_norm
     toplevel_summands_deriv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un Union_Un_distrib
   by (simp add: image_UN)
qed (auto simp: Let_def)

lemma toplevel_summands_nullable:
  "nullable s = (\<exists>r\<in>toplevel_summands s. nullable r)"
by (induction s) auto

lemma nullable_PLUS:
  "nullable (PLUS xs) = (\<exists>r \<in> set xs. nullable r)"
by (induction xs rule: list_singleton_induct) auto

theorem ACI_norm_deriv: "\<guillemotleft>deriv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>deriv as r\<guillemotright>"
proof (induction r arbitrary: as)
  case (Plus r1 r2) thus ?case
   unfolding deriv.simps ACI_norm_flatten[of "deriv as \<guillemotleft>Plus r1 r2\<guillemotright>"]
     toplevel_summands_deriv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un image_UN
   by (auto simp: toplevel_summands_ACI_norm toplevel_summands_flatten_ACI_norm_image_Union)
     (auto simp: toplevel_summands_ACI_norm[symmetric] toplevel_summands_ACI_norm_deriv)
qed (simp_all add: ACI_norm_nullable)

corollary deriv_preserves: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> \<guillemotleft>deriv as r\<guillemotright> = \<guillemotleft>deriv as s\<guillemotright>"
  by (rule box_equals[OF _ ACI_norm_deriv ACI_norm_deriv]) (erule arg_cong)

lemma derivs_snoc[simp]: "derivs (xs @ [x]) r = (deriv x (derivs xs r))"
by (induction xs arbitrary: r) auto

theorem ACI_norm_derivs: "\<guillemotleft>derivs xs \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>derivs xs r\<guillemotright>"
proof (induction xs arbitrary: r rule: rev_induct)
  case (snoc x xs) thus ?case
    using ACI_norm_deriv[of x "derivs xs r"] ACI_norm_deriv[of x "derivs xs \<guillemotleft>r\<guillemotright>"] by auto
qed simp

subsection \<open>Alternative ACI defintions\<close>

text \<open>Not necessary but conceptually nicer (and seems also to be faster?!)\<close>

fun ACI_nPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "ACI_nPlus (Plus r1 r2) s = ACI_nPlus r1 (ACI_nPlus r2 s)"
| "ACI_nPlus r (Plus s1 s2) =
  (if r = s1 then Plus s1 s2
  else if r < s1 then Plus r (Plus s1 s2)
  else Plus s1 (ACI_nPlus r s2))"
| "ACI_nPlus r s =
  (if r = s then r
  else if r < s then Plus r s
  else Plus s r)"

primrec ACI_norm_alt where
  "ACI_norm_alt Zero = Zero"
| "ACI_norm_alt One = One"
| "ACI_norm_alt (Atom a) = Atom a"
| "ACI_norm_alt (Plus r s) = ACI_nPlus (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Times r s) = Times (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Star r) = Star (ACI_norm_alt r)"

lemma toplevel_summands_ACI_nPlus:
  "toplevel_summands (ACI_nPlus r s) = toplevel_summands (Plus r s)"
  by (induct r s rule: ACI_nPlus.induct) auto

lemma toplevel_summands_ACI_norm_alt:
  "toplevel_summands (ACI_norm_alt r) = ACI_norm_alt ` toplevel_summands r"
  by (induct r) (auto simp: toplevel_summands_ACI_nPlus)

lemma ACI_norm_alt_Plus:
  "ACI_norm_alt r = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
  by (induct r) auto

lemma toplevel_summands_flatten_ACI_norm_alt_image:
  "toplevel_summands (flatten PLUS (ACI_norm_alt ` toplevel_summands r)) = ACI_norm_alt ` toplevel_summands r"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_alt_Plus intro: Plus_toplevel_summands)

lemma ACI_norm_ACI_norm_alt: "\<guillemotleft>ACI_norm_alt r\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induction r)
  case (Plus r s) show ?case
    using ACI_norm_flatten [of r] ACI_norm_flatten [of s]
    by (auto simp add: toplevel_summands_ACI_nPlus)
      (metis ACI_norm_flatten Plus.IH(1) Plus.IH(2) image_Un toplevel_summands.simps(1) toplevel_summands_ACI_nPlus toplevel_summands_ACI_norm)
qed auto

lemma ACI_nPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow>
  ACI_nPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case
    by (cases x y rule: linorder_cases) (induct x y rule: ACI_nPlus.induct, auto)+
next
  case (cons y1 y2 ys) thus ?case by (cases x) (auto)
qed simp

lemma ACI_nPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>(\<exists>r s. x = Plus r s); sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  ACI_nPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1)
  thus ?case
    apply (auto intro!: trans[OF ACI_nPlus_singleton_PLUS] simp del: sorted_list_of_set_insert)
    apply (simp only: insert_absorb)
    apply (metis List.finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (rule arg_cong[of _ _ PLUS])
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1) thus ?case
  apply (simp del: sorted_list_of_set_insert)
  apply (rule trans[OF ACI_nPlus_singleton_PLUS])
  apply (auto simp del: sorted_list_of_set_insert simp add: insert_commute[of x11])
  apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
  apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
  apply (auto simp add: insert_commute[of x12])
  done
qed simp

lemma ACI_nPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2. \<not>(\<exists>r s. x = Plus r s)\<rbrakk>\<Longrightarrow>
  ACI_nPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF ACI_nPlus_PLUS]) auto

lemma ACI_nPlus_ACI_norm [simp]: "ACI_nPlus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright> = \<guillemotleft>Plus r s\<guillemotright>"
  by (auto simp: image_Un Un_assoc ACI_norm_flatten [of r] ACI_norm_flatten [of s] ACI_norm_flatten [of "Plus r s"]
    toplevel_summands_flatten_ACI_norm_image
    intro!: trans [OF ACI_nPlus_flatten_PLUS])
    (metis ACI_norm_Plus Plus_toplevel_summands)+

lemma ACI_norm_alt:
  "ACI_norm_alt r = \<guillemotleft>r\<guillemotright>"
  by (induct r) auto

declare ACI_norm_alt[symmetric, code]

inductive ACI where
  ACI_refl:       "ACI r r" |
  ACI_sym:        "ACI r s \<Longrightarrow> ACI s r" |
  ACI_trans:      "ACI r s \<Longrightarrow> ACI s t \<Longrightarrow> ACI r t" |
  ACI_Plus_cong:  "\<lbrakk>ACI r1 s1; ACI r2 s2\<rbrakk> \<Longrightarrow> ACI (Plus r1 r2) (Plus s1 s2)" |
  ACI_Times_cong: "\<lbrakk>ACI r1 s1; ACI r2 s2\<rbrakk> \<Longrightarrow> ACI (Times r1 r2) (Times s1 s2)" |
  ACI_Star_cong:  "ACI r s \<Longrightarrow> ACI (Star r) (Star s)" |
  ACI_assoc:      "ACI (Plus (Plus r s) t) (Plus r (Plus s t))" |
  ACI_comm:       "ACI (Plus r s) (Plus s r)" |
  ACI_idem:       "ACI (Plus r r) r"

lemma ACI_nullable: "ACI r s \<Longrightarrow> nullable r = nullable s"
  by (induct rule: ACI.induct) auto

lemma ACI_lang: "ACI r s \<Longrightarrow> lang r = lang s"
  by (induct rule: ACI.induct) auto

lemma ACI_deriv: "ACI r s \<Longrightarrow> ACI (deriv a r) (deriv a s)"
proof (induct arbitrary: a rule: ACI.induct)
  case (ACI_Times_cong r1 s1 r2 s2) thus ?case
    by (auto simp: Let_def intro: ACI.intros dest: ACI_nullable)
      (metis ACI.ACI_Times_cong ACI_Plus_cong)
qed (auto intro: ACI.intros)

lemma ACI_Plus_assocI[intro]:
  "ACI (Plus r1 r2) s2 \<Longrightarrow> ACI (Plus r1 (Plus s1 r2)) (Plus s1 s2)"
  "ACI (Plus r1 r2) s2 \<Longrightarrow> ACI (Plus r1 (Plus r2 s1)) (Plus s1 s2)"
  by (metis ACI_assoc ACI_comm ACI_Plus_cong ACI_refl ACI_trans)+

lemma ACI_Plus_idemI[intro]: "\<lbrakk>ACI r s1; ACI r s2\<rbrakk> \<Longrightarrow> ACI r (Plus s1 s2)"
  by (metis ACI_Plus_cong ACI_idem ACI_sym ACI_trans)

lemma ACI_Plus_idemI'[intro]:
  "\<lbrakk>ACI r1 s1; ACI (Plus r1 r2) s2\<rbrakk> \<Longrightarrow> ACI (Plus r1 r2) (Plus s1 s2)"
  by (rule ACI_trans[OF ACI_Plus_cong[OF ACI_sym[OF ACI_idem] ACI_refl]
             ACI_trans[OF ACI_assoc ACI_trans[OF ACI_Plus_cong ACI_refl]]])

lemma ACI_ACI_nPlus: "\<lbrakk>ACI r1 s1; ACI r2 s2\<rbrakk> \<Longrightarrow> ACI (ACI_nPlus r1 r2) (Plus s1 s2)"
proof (induct r1 r2 arbitrary: s1 s2 rule: ACI_nPlus.induct)
  case 1
  from 1(2)[OF ACI_refl 1(1)[OF ACI_refl 1(4)]] 1(3) show ?case by (auto intro: ACI_comm ACI_trans)
next
  case ("2_1" r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_1"(1)[OF _ _ "2_1"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_2" r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_2"(1)[OF _ _ "2_2"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_3" _ r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_3"(1)[OF _ _ "2_3"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_4" _ _ r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_4"(1)[OF _ _ "2_4"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_5" _ r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_5"(1)[OF _ _ "2_5"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
qed (auto intro: ACI.intros)

lemma ACI_ACI_norm: "ACI \<guillemotleft>r\<guillemotright> r"
  unfolding ACI_norm_alt[symmetric]
  by (induct r) (auto intro: ACI.intros simp: ACI_ACI_nPlus)

lemma ACI_norm_eqI: "ACI r s \<Longrightarrow> \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>"
  by (induct rule: ACI.induct) (auto simp: toplevel_summands_ACI_norm ACI_norm_flatten[symmetric]
    toplevel_summands_flatten_ACI_norm_image_Union ac_simps)

lemma ACI_I: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> ACI r s"
  by (metis ACI_ACI_norm ACI_sym ACI_trans)

lemma ACI_decidable: "ACI r s = (\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>)"
  by (metis ACI_I ACI_norm_eqI)

(*<*)
end
(*>*)