(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
chapter \<open>Examples\<close>
theory OCL_Examples
  imports OCL_Normalization
begin

(*
instantiation expr :: (type) numeral
begin

definition "one_expr \<equiv> Literal (IntegerLiteral 1)"

fun plus_expr :: "'a expr \<Rightarrow> 'a expr \<Rightarrow> 'a expr" where
  "plus_expr (Literal (IntegerLiteral x)) (Literal (IntegerLiteral y)) =
      (Literal (IntegerLiteral (x + y)))"
| "plus_expr _ _ = Literal NullLiteral"

lemma literal_expr_add_assoc:
  "(Literal a + Literal b) + Literal c = Literal a + (Literal b + Literal c)"
  for a b c :: "'a literal_expr"
  by (cases a; simp; cases b; simp; cases c; simp)

lemma expr_add_assoc:
  "(a + b) + c = a + (b + c)"
  for a b c :: "'a expr"
  by (cases a; simp; cases b; simp; cases c; simp add: literal_expr_add_assoc)

instance
  apply standard
  by (simp add: expr_add_assoc)
end

term "Set{}"
term "Set{\<^bold>1..\<^bold>2, \<^bold>3, 3}"
term "Set{\<^bold>1, \<^bold>2}"

term "Set{\<^bold>1 .. \<^bold>2, \<^bold>3}"

term "Set Integer[\<^bold>1]"
*)

(*** Symbols ****************************************************************)

section \<open>Symbols\<close>

abbreviation "self \<equiv> STR ''self''"
abbreviation "it \<equiv> STR ''it''"

abbreviation "name \<equiv> STR ''name''"
abbreviation "position \<equiv> STR ''position''"
abbreviation "vip \<equiv> STR ''vip''"
abbreviation "cost \<equiv> STR ''cost''"
abbreviation "description \<equiv> STR ''description''"
abbreviation "priority \<equiv> STR ''priority''"

abbreviation "Priority \<equiv> STR ''Priority''"
abbreviation "Low \<equiv> STR ''Low''"
abbreviation "Medium \<equiv> STR ''Medium''"
abbreviation "High \<equiv> STR ''High''"

abbreviation "ProjectManager \<equiv> STR ''ProjectManager''"
abbreviation "projects \<equiv> STR ''projects''"
abbreviation "manager \<equiv>  STR ''manager''"
abbreviation "ProjectMember \<equiv>  STR ''ProjectMember''"
abbreviation "memberOf \<equiv>  STR ''memberOf''"
abbreviation "members \<equiv>  STR ''members''"
abbreviation "ManagerEmployee \<equiv>  STR ''ManagerEmployee''"
abbreviation "lineManager \<equiv>  STR ''lineManager''"
abbreviation "projectManager \<equiv>  STR ''projectManager''"
abbreviation "employees \<equiv>  STR ''employees''"
abbreviation "ProjectCustomer \<equiv>  STR ''ProjectCustomer''"
abbreviation "customer \<equiv>  STR ''customer''"
abbreviation "ProjectTask \<equiv>  STR ''ProjectTask''"
abbreviation "project \<equiv>  STR ''project''"
abbreviation "tasks \<equiv>  STR ''tasks''"
abbreviation "SprintTaskAssignee \<equiv>  STR ''SprintTaskAssignee''"
abbreviation "sprint \<equiv>  STR ''sprint''"
abbreviation "assignee \<equiv>  STR ''assignee''"

abbreviation "membersCount \<equiv>  STR ''membersCount''"
abbreviation "membersByName \<equiv>  STR ''membersByName''"
abbreviation "allProjects \<equiv>  STR ''allProjects''"

definition "symbol_kinds \<equiv> fmap_of_list [
  (name, Attribute),
  (position, Attribute),
  (vip, Attribute),
  (cost, Attribute),
  (description, Attribute),
  (priority, Attribute),
  (projects, AssociationEnd None),
  (members, AssociationEnd None),
  (memberOf, AssociationEnd None),
  (manager, AssociationEnd None),
  (lineManager, AssociationEnd None),
  (projectManager, AssociationEnd None),
  (employees, AssociationEnd None),
  (customer, AssociationEnd None),
  (project, AssociationEnd None),
  (tasks, AssociationEnd None),
  (sprint, AssociationEnd None),
  (assignee, AssociationEnd None)]"

definition "symbol_to_call_expr lit \<equiv> the (fmlookup symbol_kinds lit) lit"

(*** Model ******************************************************************)

section \<open>Model\<close>

datatype classes1 =
  Object | Person | Employee | Customer | Project | Task | Sprint

inductive subclass1 where
  "c \<noteq> Object \<Longrightarrow>
   subclass1 c Object"
| "subclass1 Employee Person"
| "subclass1 Customer Person"

abbreviation "\<Gamma>\<^sub>0 \<equiv> fmempty :: classes1 type\<^sub>N\<^sub>E env"

declare [[coercion "ObjectType :: classes1 \<Rightarrow> classes1 type"]]
declare [[coercion "phantom :: String.literal \<Rightarrow> classes1 enum_type"]]
declare [[coercion "Enum :: classes1 enum_type \<Rightarrow> classes1 type"]]
declare [[coercion "StringLiteral :: string \<Rightarrow> classes1 literal_expr"]]
declare [[coercion "symbol_to_call_expr :: String.literal \<Rightarrow> classes1 call_expr"]]

(* TODO: Заменить бесконечность на звездочку *)

definition "model_spec \<equiv>

  enum Priority { Low, Medium, High }

  class Person
    name : String[1]

  class Employee
    name : String[1]
    position : String[1]

  class Customer
    vip : Boolean[1]

  class Project
    name : String[1]
    cost : Real[?]

  class Task
    description : String[1]
    priority : Priority[1]

  association ProjectManager
    projects : Project[0..\<infinity>] {unique}
    manager : Employee[1..1]

  association ProjectMember
    memberOf : Project[0..\<infinity>]
    members : Employee[1..20] {ordered,unique}

  association ManagerEmployee
    lineManager : Employee[0..1]
    projectManager : Employee[0..\<infinity>]
    employees : Employee[3..7]

  association ProjectCustomer
    projects : Project[0..\<infinity>] {unique}
    customer : Customer[1..1]

  association ProjectTask
    project : Project[1..1]
    tasks : Task[0..\<infinity>] {ordered,unique}

  association SprintTaskAssignee
    sprint : Sprint[0..10] {unique}
    tasks : Task[0..5] {unique}
    assignee : Employee[0..1]

  context Project[1]
    def: membersCount() : Integer[1] = \<lparr>self\<rparr>\<^bold>.members->size()

    def: membersByName(name : String[1]) : (Set Employee[\<^bold>1])[1] =
         \<lparr>self\<rparr>\<^bold>.members->select(it | \<lparr>it\<rparr>\<^bold>.name \<^bold>= \<lparr>name\<rparr>)

    static def: allProjects() : (Set Project[\<^bold>1])[1] =
         (MetaOperationCall Project[1] AllInstancesOp)"

(*** Upper Semilattice of Classes *******************************************)

section \<open>Upper Semilattice of Classes\<close>

instantiation classes1 :: semilattice_sup
begin

definition "(<) \<equiv> subclass1"
definition "(\<le>) \<equiv> subclass1\<^sup>=\<^sup>="

primrec sup_classes1 where
  "Object \<squnion> _ = Object"
| "Person \<squnion> c = (if c = Person \<or> c = Employee \<or> c = Customer
    then Person else Object)"
| "Employee \<squnion> c = (if c = Employee then Employee else
    if c = Person \<or> c = Customer then Person else Object)"
| "Customer \<squnion> c = (if c = Customer then Customer else
    if c = Person \<or> c = Employee then Person else Object)"
| "Project \<squnion> c = (if c = Project then Project else Object)"
| "Task \<squnion> c = (if c = Task then Task else Object)"
| "Sprint \<squnion> c = (if c = Sprint then Sprint else Object)"

lemma less_le_not_le_classes1:
  "c < d \<longleftrightarrow> c \<le> d \<and> \<not> d \<le> c"
  for c d :: classes1
  unfolding less_classes1_def less_eq_classes1_def
  using subclass1.simps by auto

lemma order_refl_classes1:
  "c \<le> c"
  for c :: classes1
  unfolding less_eq_classes1_def by simp

lemma order_trans_classes1:
  "c \<le> d \<Longrightarrow> d \<le> e \<Longrightarrow> c \<le> e"
  for c d e :: classes1
  unfolding less_eq_classes1_def
  using subclass1.simps by auto

lemma antisym_classes1:
  "c \<le> d \<Longrightarrow> d \<le> c \<Longrightarrow> c = d"
  for c d :: classes1
  unfolding less_eq_classes1_def
  using subclass1.simps by auto

lemma sup_ge1_classes1:
  "c \<le> c \<squnion> d"
  for c d :: classes1
  by (induct c; auto simp add: less_eq_classes1_def less_classes1_def subclass1.simps)

lemma sup_ge2_classes1:
  "d \<le> c \<squnion> d"
  for c d :: classes1
  by (induct c; auto simp add: less_eq_classes1_def less_classes1_def subclass1.simps)

lemma sup_least_classes1:
  "c \<le> e \<Longrightarrow> d \<le> e \<Longrightarrow> c \<squnion> d \<le> e"
  for c d e :: classes1
  by (induct c; induct d;
      auto simp add: less_eq_classes1_def less_classes1_def subclass1.simps)

instance
  apply intro_classes
  apply (simp add: less_le_not_le_classes1)
  apply (simp add: order_refl_classes1)
  apply (rule order_trans_classes1; auto)
  apply (simp add: antisym_classes1)
  apply (simp add: sup_ge1_classes1)
  apply (simp add: sup_ge2_classes1)
  by (simp add: sup_least_classes1)

end

code_pred subclass1 .

primrec subclass1_fun where
  "subclass1_fun Object \<C> = False"
| "subclass1_fun Person \<C> = (\<C> = Object)"
| "subclass1_fun Employee \<C> = (\<C> = Object \<or> \<C> = Person)"
| "subclass1_fun Customer \<C> = (\<C> = Object \<or> \<C> = Person)"
| "subclass1_fun Project \<C> = (\<C> = Object)"
| "subclass1_fun Task \<C> = (\<C> = Object)"
| "subclass1_fun Sprint \<C> = (\<C> = Object)"

lemma less_classes1_code [code]:
  "(<) = subclass1_fun"
proof (intro ext iffI)
  fix \<C> \<D> :: "classes1"
  show "\<C> < \<D> \<Longrightarrow> subclass1_fun \<C> \<D>"
    unfolding less_classes1_def
    by (cases \<C>; erule subclass1.cases; simp)
  show "subclass1_fun \<C> \<D> \<Longrightarrow> \<C> < \<D>"
    by (cases \<C>; auto simp add: less_classes1_def subclass1.intros)
qed

lemma less_eq_classes1_code [code]:
  "(\<le>) = (\<lambda>x y. subclass1_fun x y \<or> x = y)"
  unfolding dual_order.order_iff_strict less_classes1_code
  by auto

(*** Object Model ***********************************************************)

section \<open>Object Model\<close>

instantiation classes1 :: ocl_object_model
begin

definition "classes_classes1 \<equiv>
  {|Object, Person, Employee, Customer, Project, Task, Sprint|}"

definition "attributes_classes1 \<equiv> model_spec_attributes model_spec"
definition "associations_classes1 \<equiv> model_spec_assoc_ens model_spec"
definition "association_classes_classes1 \<equiv> fmempty :: classes1 \<rightharpoonup>\<^sub>f assoc"
definition "operations_classes1 \<equiv> model_spec_operations model_spec"
definition "literals_classes1 \<equiv> model_spec_enum_literals model_spec"

abbreviation "assoc_ends \<equiv> model_spec_assoc_ens model_spec"

lemma assoc_end_min_less_eq_max:
  "assoc |\<in>| fmdom assoc_ends \<Longrightarrow>
   fmlookup assoc_ends assoc = Some ends \<Longrightarrow>
   role |\<in>| fmdom ends  \<Longrightarrow>
   fmlookup ends role = Some end \<Longrightarrow>
   assoc_end_min end \<le> assoc_end_max end"
  unfolding object_model_simps object_model_notation_simps model_spec_def
  using zero_enat_def one_enat_def numeral_eq_enat apply auto
  by (metis enat_ord_number(1) numeral_One one_le_numeral)

lemma association_ends_unique:
  assumes "association_ends' classes assoc_ends \<C> from role end\<^sub>1"
      and "association_ends' classes assoc_ends \<C> from role end\<^sub>2"
    shows "end\<^sub>1 = end\<^sub>2"
proof -
  have "\<not> association_ends_not_unique' classes assoc_ends" by eval
  with assms show ?thesis
    using association_ends_not_unique'.simps by blast
qed

instance
  apply standard
  unfolding associations_classes1_def
  using assoc_end_min_less_eq_max apply blast
  using association_ends_unique by blast

end

(*** Simplification Rules ***************************************************)

section \<open>Simplification Rules\<close>

lemma logic_alt_simps [simp]:
  "\<exists>x. x"
  "\<exists>x. \<not> x"
  "(\<exists>x. (x \<longrightarrow> P) \<and> x) = P"
  "(\<exists>x. \<not> x \<and> (\<not> x \<longrightarrow> P)) = P"
  "(\<exists>x. \<not> x \<and> P \<and> \<not> x) = P"
  "(\<exists>x. x \<and> P \<and> \<not> x) = False"
  "(\<exists>x. x \<and> Q x) = Q True"
  "(\<exists>x. \<not> x \<and> Q x) = Q False"
  "(\<forall>x. x) = False"
  "(\<forall>x y. R y \<longrightarrow> x \<or> S y) = (\<forall>y. R y \<longrightarrow> S y)"
  "(\<forall>x. R x \<longrightarrow> x \<noteq> T) = (\<not> (\<exists>x. R x \<and> x = T))"
  by auto

declare numeral_eq_enat [simp]
declare fmrel_on_fset_alt_def [simp]

declare ocl_syntax_simps [simp]
declare ocl_object_model_simps [simp]
declare ocl_type_helper_simps [simp]
declare ocl_typing_simps [simp]
declare ocl_normalization_simps [simp]

declare model_spec_def [simp]

declare subclass1.simps [simp]
declare less_classes1_def [simp]

declare symbol_to_call_expr_def [simp]
declare symbol_kinds_def [simp]
declare literals_classes1_def [simp]

lemma attribute_Employee_name [simp]:
  "attribute Employee STR ''name'' \<D> \<tau> =
   (\<D> = Employee \<and> \<tau> = String[1])"
proof -
  have "attribute Employee STR ''name'' Employee String[1]"
    by eval
  thus ?thesis
    using attribute_det by blast
qed

lemma association_end_Project_members [simp]:
  "association_end Project None STR ''members'' \<D> \<tau> =
   (\<D> = Project \<and> \<tau> = (Employee, 1, 20, True, True))"
proof -
  have "association_end Project None STR ''members''
          Project (Employee, 1, 20, True, True)"
    by eval
  thus ?thesis
    using association_end_det by blast
qed

lemma association_end_Employee_projects_simp [simp]:
  "association_end Employee None STR ''projects'' \<D> \<tau> =
   (\<D> = Employee \<and> \<tau> = (Project, 0, \<infinity>, False, True))"
proof -
  have "association_end Employee None STR ''projects''
          Employee (Project, 0, \<infinity>, False, True)"
    by eval
  thus ?thesis
    using association_end_det by blast
qed

lemma static_operation_Project_allProjects [simp]:
  "static_operation \<langle>Project\<rangle>\<^sub>\<T>[1] STR ''allProjects'' [] oper =
   (oper = (\<langle>Project\<rangle>\<^sub>\<T>[1], STR ''allProjects'', [], (Set \<langle>Project\<rangle>\<^sub>\<T>[\<^bold>1])[1], True,
     Some (MetaOperationCall \<langle>Project\<rangle>\<^sub>\<T>[1] AllInstancesOp)))"
proof -
  have "static_operation \<langle>Project\<rangle>\<^sub>\<T>[1] STR ''allProjects'' []
    (\<langle>Project\<rangle>\<^sub>\<T>[1], STR ''allProjects'', [], (Set \<langle>Project\<rangle>\<^sub>\<T>[\<^bold>1])[1], True,
     Some (MetaOperationCall \<langle>Project\<rangle>\<^sub>\<T>[1] AllInstancesOp))"
    by eval
  thus ?thesis
    using static_operation_det by blast
qed

(*** Basic Types ************************************************************)

section \<open>Basic Types\<close>

subsection \<open>Positive Cases\<close>

lemma "Integer < (Real :: classes1 type)" by simp
lemma "\<langle>Employee\<rangle>\<^sub>\<T> < \<langle>Person\<rangle>\<^sub>\<T>" by auto
lemma "\<langle>Person\<rangle>\<^sub>\<T> \<le> OclAny" by simp

subsection \<open>Negative Cases\<close>

lemma "\<not> String \<le> (Boolean :: classes1 type)" by simp

(*** Types ******************************************************************)

section \<open>Types\<close>

subsection \<open>Positive Cases\<close>

lemma
  "Integer[?] < (OclAny[?] :: classes1 type\<^sub>N\<^sub>E)"
  by simp

lemma
  "(Collection Real[\<^bold>?])[1] < (OclAny[1] :: classes1 type\<^sub>N\<^sub>E)"
  by simp

lemma
  "(Set (Collection Boolean[\<^bold>1])[\<^bold>1])[1] < (OclAny[?] :: classes1 type\<^sub>N\<^sub>E)"
  by simp

lemma
  "(Set (Bag Boolean[\<^bold>1])[\<^bold>1])[1] <
   (Set (Collection (Boolean[\<^bold>?] :: classes1 type\<^sub>N))[\<^bold>1])[?]"
  by simp

lemma
  "Tuple(STR ''a'' : Boolean[\<^bold>1], STR ''b'' : Integer[\<^bold>1])[1] <
   Tuple(STR ''a'' : Boolean[\<^bold>?] :: classes1 type\<^sub>N)[1!]"
  by simp

lemma
  "Integer[1] \<squnion> (Real[?] :: classes1 type\<^sub>N\<^sub>E) = Real[?]"
  by simp

lemma
  "Set Integer[\<^bold>1] \<squnion> Set (Real[\<^bold>1] :: classes1 type\<^sub>N) = Set Real[\<^bold>1]"
  by simp

lemma
  "Set Integer[\<^bold>1] \<squnion> Bag (Boolean[\<^bold>?] :: classes1 type\<^sub>N) = Collection OclAny[\<^bold>?]"
  by simp

lemma
  "(Set Integer[\<^bold>1])[1] \<squnion> (Real[1!] :: classes1 type\<^sub>N\<^sub>E) = OclAny[1!]"
  by simp

subsection \<open>Negative Cases\<close>

lemma
  "\<not> (OrderedSet Boolean[\<^bold>1])[1] < (Set (Boolean[\<^bold>1] :: classes1 type\<^sub>N))[1]"
  by simp

(*** Typing *****************************************************************)

section \<open>Typing\<close>

subsection \<open>Positive Cases\<close>

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Priority\<^bold>:\<^bold>:High : Priority[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> true or false : Boolean[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> null and true : Boolean[?]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> let x : Real[1] = \<^bold>5 in \<lparr>x\<rparr> \<^bold>/ \<^bold>7 : Real[1!]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> null\<^bold>.oclIsUndefined() : Boolean[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5, null} : (Sequence Integer[\<^bold>?])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5, null}\<^bold>.oclIsUndefined() : (Sequence Boolean[\<^bold>1])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1\<^bold>/\<^bold>0} : (Sequence Real[\<^bold>1])[1!]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1\<^bold>/\<^bold>0, null}->selectByKind(Integer[1]) : (Sequence Integer[\<^bold>1])[1!]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1\<^bold>/\<^bold>0}->collect(it | \<lparr>it\<rparr>) : (Sequence Real[\<^bold>1])[1!]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1}->exists(it | \<lparr>it\<rparr> \<^bold>/ \<^bold>0 \<^bold>> \<^bold>1) : Boolean[1!]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5}->product(Set{''a'', ''b''}) :
    (Set (Tuple(STR ''first'' : Integer[\<^bold>1], STR ''second'' : String[\<^bold>1]))[\<^bold>1])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5, null}?->
            iterate(x; acc : Real[1] = \<^bold>0 | \<lparr>acc\<rparr> \<^bold>+ \<lparr>x\<rparr>) : Real[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5, null}?->max() : Integer[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> let x : (Sequence String[\<^bold>?])[1] = Sequence{''abc'', ''zxc''} in
   \<lparr>x\<rparr>->any(it | \<lparr>it\<rparr> \<^bold>= ''test'') : String[?!]"
  by simp

values "{x. \<Gamma>\<^sub>0 \<turnstile> let STR ''x'' : (Sequence String[\<^bold>1])[1] =
          Sequence{''abc'', ''zxc''} in
   \<lparr>STR ''x''\<rparr>?->closure(it | \<lparr>it\<rparr>) : x}"

values "{x. \<Gamma>\<^sub>0 \<turnstile> let STR ''x'' : (Sequence String[\<^bold>1])[1] =
          Sequence{''abc'', ''zxc''} in
   \<lparr>STR ''x''\<rparr>->closure(it | \<lparr>it\<rparr>) : x}"

values "{x. \<Gamma>\<^sub>0 \<turnstile> let STR ''x'' : (Sequence String[\<^bold>?])[1] =
          Sequence{''abc'', ''zxc''} in
   \<lparr>STR ''x''\<rparr>?->closure(it | \<lparr>it\<rparr>) : x}"

values "{x. \<Gamma>\<^sub>0 \<turnstile> Sequence{''abc'', ''zxc''}->closure(it | \<lparr>it\<rparr>) : x}"
values "{x. \<Gamma>\<^sub>0 \<turnstile> Sequence{''abc'', ''zxc''}->closure(it | \<lparr>it\<rparr>\<^bold>.oclAsSet()) : x}"
values "{x. \<Gamma>\<^sub>0 \<turnstile> Sequence{''abc'', ''zxc''}->closure(it | \<lparr>it\<rparr>) \<Rrightarrow> x}"
values "{x. \<Gamma>\<^sub>0 \<turnstile> Sequence{''abc'', ''zxc''}->collect(it | \<lparr>it\<rparr>) \<Rrightarrow> x}"

lemma
  "\<Gamma>\<^sub>0 \<turnstile> let x : (Sequence String[\<^bold>?])[1] =
          Sequence{''abc'', ''zxc''} in
   \<lparr>x\<rparr>?->closure(it | \<lparr>it\<rparr>) : (OrderedSet String[\<^bold>1])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0(self \<mapsto>\<^sub>f Employee[1]) \<turnstile> \<lparr>self\<rparr>\<^bold>.name : String[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0(self \<mapsto>\<^sub>f Employee[1]) \<turnstile> \<lparr>self\<rparr>\<^bold>.projects : (Set Project[\<^bold>1])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0(self \<mapsto>\<^sub>f Employee[1]) \<turnstile> \<lparr>self\<rparr>\<^bold>.projects\<^bold>.members : (Bag Employee[\<^bold>1])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Project[?]\<^bold>.allInstances() : (Set Project[\<^bold>?])[1]"
  by simp

lemma
  "\<Gamma>\<^sub>0 \<turnstile> Project[1]::allProjects() : (Set Project[\<^bold>1])[1]"
  by simp

subsection \<open>Negative Cases\<close>

lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> true \<^bold>= null : \<tau>"
  by simp

lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> let x : Boolean[1] = \<^bold>5 in \<lparr>x\<rparr> and true : \<tau>"
  by simp

lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1\<^bold>/\<^bold>0}->selectByKind(Integer[1!]) : \<tau>"
  by simp

lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> let x : (Sequence String[\<^bold>?])[1] = Sequence{''abc'', ''zxc''} in
   \<lparr>x\<rparr>->closure(it | \<^bold>1) : \<tau>"
  by simp

lemma
  "\<nexists>\<tau>. \<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5, null}->max() : \<tau>"
proof -
  have
    "\<not> operation_defined (Integer[?] :: classes1 type\<^sub>N\<^sub>E) STR ''max'' [Integer[?]]"
    by eval
  thus ?thesis by simp
qed

(*** Code *******************************************************************)

section \<open>Code\<close>

subsection \<open>Positive Cases\<close>

values "{(\<D>, \<tau>). attribute Employee name \<D> \<tau>}"
(* TODO: Тут ошибка. Потому, что если выражение имеет тип,
   то должно иметь и значение. А, нет норм для 1-го варианта
   будут все значения без фильтрации. Но это нужно явно отметить *)
values "{(\<D>, end). association_end Employee None employees \<D> end}"
values "{(\<D>, end).
  association_end Employee (Some projectManager) employees \<D> end}"
values "{op. operation Project[1] membersCount [] op}"
values "{op. operation Project[1] membersByName [String[1]] op}"
values "{\<tau>. \<Gamma>\<^sub>0(self \<mapsto>\<^sub>f Employee[1]) \<turnstile> \<lparr>self\<rparr>\<^bold>.projects\<^bold>.members : \<tau>}"

subsection \<open>Negative Cases\<close>

values "{(\<D>, \<tau>). attribute Employee STR ''name2'' \<D> \<tau>}"
values "{\<tau>. \<Gamma>\<^sub>0 \<turnstile> Sequence{\<^bold>1..\<^bold>5, null}->max() : \<tau>}"

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_on_inv__30 imports n_german_base
begin
section{*All lemmas on causal relation between inv__30 and some rule r*}
lemma n_SendInvEVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvE  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvSVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const GntS)) (eqn (IVar (Para (Ident ''ShrSet'') p__Inv4)) (Const false))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__30:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__30  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__30:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqESVsinv__30:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqES  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqVsinv__30:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReq N i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__30:
  assumes a1: "\<exists> j. j\<le>N\<and>r=n_SendReqS  j" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqEIVsinv__30:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqEI  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__30  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__44_on_rules imports n_german_lemma_on_inv__44
begin
section{*All lemmas on causal relation between inv__44*}
lemma lemma_inv__44_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__44  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__44) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

end


theory LLVM_Memory_RS
imports
  "../basic/LLVM_Basic_Main"
  Sep_Value_RS
  Sep_Array_Block_RS
begin

  definition "vpto_assn x p \<equiv> VAL.pto p (VAL.val x)"

  interpretation ab: array_block2 "STATIC_ERROR ''''" MEM_ERROR "vload MEM_ERROR::_ \<Rightarrow> (llvm_primval val,_,_,_) M" "vstore MEM_ERROR" "checked_gep MEM_ERROR" val_\<alpha> vpto_assn "\<lambda>v. v\<in>range val_\<alpha>"
    apply unfold_locales
    unfolding vpto_assn_def
    apply (rule vload_rule)
    apply (rule vstore_rule)
    subgoal by simp
    subgoal by auto
    subgoal by (auto simp: VAL.val_def)
    subgoal by auto []
    done

  datatype llvm_amemory = LLVM_AMEMORY (the_amemory: "(nat \<Rightarrow> (nat \<Rightarrow> llvm_primval aval) \<times> int tsa_opt)")

  instantiation llvm_amemory :: unique_zero_sep_algebra begin
    definition "sep_disj_llvm_amemory a b \<equiv> the_amemory a ## the_amemory b"
    definition "plus_llvm_amemory a b \<equiv> LLVM_AMEMORY (the_amemory a + the_amemory b)"
    definition "zero_llvm_amemory \<equiv> LLVM_AMEMORY 0"

    instance
      apply standard
      unfolding sep_disj_llvm_amemory_def plus_llvm_amemory_def zero_llvm_amemory_def
      apply (auto simp: sep_algebra_simps llvm_amemory.expand)
      done

  end

  type_synonym llvm_assn = "llvm_amemory \<Rightarrow> bool"

  definition "llvm_\<alpha> \<equiv> LLVM_AMEMORY o ab.ba.\<alpha> o llvm_memory.the_memory"
  definition "llvm_pto x p \<equiv> (ab.ba.pto (llvm_val.the_val x) (llvm_ptr.the_ptr p)) o llvm_amemory.the_amemory"
  (*definition "llvm_is_base_ptr p \<equiv> ab.is_base_ptr (llvm_ptr.the_ptr p)"*)

  definition "llvm_malloc_tag n p \<equiv> ab.ba.tag n (llvm_ptr.the_ptr p) o llvm_amemory.the_amemory"

  instantiation llvm_ptr :: addr_algebra begin
    definition "abase_llvm_ptr = abase o llvm_ptr.the_ptr"
    definition "acompat_llvm_ptr a b \<equiv> acompat (llvm_ptr.the_ptr a) (llvm_ptr.the_ptr b)"
    definition "adiff_llvm_ptr a b \<equiv> adiff (llvm_ptr.the_ptr a) (llvm_ptr.the_ptr b)"
    definition "aidx_llvm_ptr a i \<equiv> LLVM_PTR ((llvm_ptr.the_ptr a) +\<^sub>a i)"

    instance
      apply standard
      unfolding abase_llvm_ptr_def acompat_llvm_ptr_def adiff_llvm_ptr_def aidx_llvm_ptr_def
      apply (intro part_equivpI sympI transpI)
      apply (metis ab.block_ptr_imp_abase ab.is_block_ptr_simps(2) acompat_refl llvm_ptr.sel)
      apply (auto intro: acompat_trans simp: acompat_dom)
      done
  end

  (*
  definition "llvm_idx_ptr p i \<equiv> LLVM_PTR (ab.idx_ptr (llvm_ptr.the_ptr p) i)"
  definition "llvm_is_arr_ptr p \<equiv> ab.is_arr_ptr (llvm_ptr.the_ptr p)"

  lemma llvm_idx_ptr_add[simp]: "llvm_idx_ptr (llvm_idx_ptr p i) j = llvm_idx_ptr p (i+j)"
    by (cases p) (auto simp: llvm_idx_ptr_def)

  lemma llvm_is_arr_ptr_idx[simp]: "llvm_is_arr_ptr (llvm_idx_ptr p i) \<longleftrightarrow> llvm_is_arr_ptr p"
    by (cases p) (auto simp: llvm_idx_ptr_def llvm_is_arr_ptr_def)
  *)

  lemma llvm_pto_null_eq[simp]: "llvm_pto x llvm_null = sep_false"
    by (auto simp: llvm_pto_def llvm_null_def)

  lemma xfer_htriple:
    assumes "htriple ab.ba.\<alpha> P c Q"
    assumes "P' = P o llvm_amemory.the_amemory"
    assumes "c' = llvm_zoom_base \<alpha> c"
    assumes "\<And>r. Q' (\<alpha> r) = Q r o llvm_amemory.the_amemory"
    shows "htriple llvm_\<alpha> P' c' Q'"
    using assms unfolding htriple_alt llvm_zoom_base_def llvm_\<alpha>_def wp_def
    apply (clarsimp simp: run_simps)
  proof goal_cases
    case A: (1 p s f)

    find_theorems llvm_memory.the_memory\<^sub>L

    from \<open>p##f\<close> \<open>LLVM_AMEMORY (ab.ba.\<alpha> (get' llvm_memory.the_memory\<^sub>L s)) = p + f\<close>
    have "llvm_amemory.the_amemory p ## llvm_amemory.the_amemory f"
      and "ab.ba.\<alpha> (get' llvm_memory.the_memory\<^sub>L s) = llvm_amemory.the_amemory p + llvm_amemory.the_amemory f"
      by (auto simp: sep_disj_llvm_amemory_def plus_llvm_amemory_def)

    from A(1)[rule_format] show ?case
      apply (rule mwp_cons)
      apply (intro conjI; fact)
      apply (clarsimp_all simp: run_simps)
      by (metis (full_types) assms(4) comp_apply llvm_amemory.sel plus_llvm_amemory_def sep_disj_llvm_amemory_def)

  qed

  lemma llvm_load_rule[vcg_rules]: "htriple llvm_\<alpha> (llvm_pto x p) (llvm_load p) (\<lambda>r. \<up>(r=x) ** llvm_pto x p)"
    apply (rule xfer_htriple[OF ab.ba.load_rule])
    unfolding llvm_pto_def llvm_load_def
    apply simp
    apply simp
    apply (rule ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
    done

  lemma llvm_store_unchecked_rule[vcg_rules]: "htriple llvm_\<alpha> (llvm_pto xx p) (llvm_store_unchecked x p) (\<lambda>_. llvm_pto x p)"
    apply (rule xfer_htriple[OF ab.ba.store_rule])
    unfolding llvm_pto_def llvm_store_unchecked_def
    apply simp
    apply simp
    apply (rule ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
    done

  lemma llvm_store_rule[vcg_rules]: "llvm_vstruct x = llvm_vstruct xx
    \<Longrightarrow> htriple llvm_\<alpha> (llvm_pto xx p) (llvm_store x p) (\<lambda>_. llvm_pto x p)"
    unfolding llvm_store_def
    by vcg

  lemma the_amemoryZ[simp]: "the_amemory 0 = 0" by (auto simp: zero_llvm_amemory_def)

  lemma the_amemoryZ_iff[simp]: "the_amemory x = 0 \<longleftrightarrow> x=0"
    by (auto simp: zero_llvm_amemory_def llvm_amemory.expand)

  lemma xfer_sep_conj1: "((\<lambda>x. a (the_amemory x)) ** (\<lambda>x. b (the_amemory x))) = (a**b) o the_amemory"
    apply (rule ext)
    apply (auto 3 3 simp: sep_conj_def sep_disj_llvm_amemory_def plus_llvm_amemory_def)
    by (metis (full_types) llvm_amemory.exhaust_sel llvm_amemory.sel)

  lemma xfer_sep_conj2: "((a o the_amemory) ** (b o the_amemory)) = (a**b) o the_amemory"
    using xfer_sep_conj1 unfolding comp_def .

  lemmas xfer_sep_conj = xfer_sep_conj1 xfer_sep_conj2

  lemma xfer_sep_list_conj1: "(\<And>*map (\<lambda>x. f x o the_amemory) l) = (\<And>*map f l) o the_amemory"
    apply (induction l)
    apply auto
    by (auto simp: sep_algebra_simps xfer_sep_conj)

  lemma xfer_sep_list_conj2: "(\<And>*map (\<lambda>x s. f x (the_amemory s)) l) = (\<And>*map f l) o the_amemory"
    using xfer_sep_list_conj1 unfolding comp_def .

  lemmas xfer_sep_list_conj = xfer_sep_list_conj1 xfer_sep_list_conj2

  lemma xfer_sep_set_img1: "(\<Union>*x\<in>I. f x o the_amemory) = (\<Union>*x\<in>I. f x) o the_amemory"
  proof (cases "finite I")
    case True then show ?thesis
      by (induction) (auto del: ext intro!: ext simp: sep_algebra_simps xfer_sep_conj)
  qed auto

  lemma xfer_sep_set_img2: "(\<Union>*x\<in>I. (\<lambda>s. f x (the_amemory s))) = (\<Union>*x\<in>I. f x) o the_amemory"
    using xfer_sep_set_img1 unfolding comp_def .

  lemmas xfer_sep_set_img = xfer_sep_set_img1 xfer_sep_set_img2

  lemma llvm_allocn_rule[vcg_rules]:
    "htriple llvm_\<alpha>
      \<box>
      (llvm_allocn v n)
      (\<lambda>r. (\<Union>*i\<in>{0..<int n}. llvm_pto v (r +\<^sub>a i))
        ** llvm_malloc_tag (int n) r ** \<up>(abase r))"
    apply (rule xfer_htriple[OF ab.ba_allocn_rule])
    unfolding llvm_pto_def llvm_allocn_def llvm_malloc_tag_def abase_llvm_ptr_def aidx_llvm_ptr_def
    apply (rule ext) apply (auto simp: sep_algebra_simps) []
    apply simp
    apply (rule ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps xfer_sep_set_img xfer_sep_conj)
    done

  lemma llvm_free_rule[vcg_rules]:
    "htriple llvm_\<alpha>
      ((\<Union>*i\<in>{0..<n}. EXS v. llvm_pto v (p +\<^sub>a i))
        ** llvm_malloc_tag n p)
      (llvm_free p)
      (\<lambda>_. \<box>)"
    apply (rule xfer_htriple[OF ab.ba_freen_rule[where p="llvm_ptr.the_ptr p" and n=n], where \<alpha>=id])
    apply (cases p; simp add: )

    unfolding llvm_pto_def llvm_free_def llvm_malloc_tag_def aidx_llvm_ptr_def
    apply (auto simp: sep_algebra_simps)
    apply (subst xfer_sep_set_img xfer_sep_conj)+
    apply (cases p; simp)
    by (metis llvm_val.sel)

  lemma llvm_checked_idx_ptr_rule[vcg_rules]:
    "abase p \<Longrightarrow>
      htriple llvm_\<alpha>
        (llvm_pto v (p +\<^sub>a i))
        (llvm_checked_idx_ptr p i)
        (\<lambda>r. \<up>(r= p +\<^sub>a i) ** llvm_pto v (p +\<^sub>a i))
    "

    supply R=xfer_htriple[OF ab.checked_idx_ptr_rule[where p="llvm_ptr.the_ptr p" and i=i and xx="llvm_val.the_val v"], where \<alpha>=LLVM_PTR]
    apply (rule R)
    unfolding llvm_checked_idx_ptr_def llvm_pto_def abase_llvm_ptr_def aidx_llvm_ptr_def
    apply (auto simp: xfer_sep_conj sep_algebra_simps pred_lift_extract_simps)
    done

end


(*  Title:      SSA_CFG_code.thy
    Author:     Denis Lohner, Sebastian Ullrich
*)

theory SSA_CFG_code imports
  SSA_CFG
  Mapping_Exts
  "HOL-Library.Product_Lexorder"
begin

definition Union_of :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a set \<Rightarrow> 'b set"
  where "Union_of f A \<equiv> \<Union>(f ` A)"

lemma Union_of_alt_def: "Union_of f A = (\<Union>x \<in> A. f x)"
  unfolding Union_of_def by simp

type_synonym ('node, 'val) phis_code = "('node \<times> 'val, 'val list) mapping"

context CFG_base begin
  definition addN :: "'g \<Rightarrow> 'node \<Rightarrow> ('var, 'node set) mapping \<Rightarrow> ('var, 'node set) mapping"
    where "addN g n \<equiv> fold (\<lambda>v. Mapping.map_default v {} (insert n)) (sorted_list_of_set (uses g n))"
  definition "addN' g n = fold (\<lambda>v m. m(v \<mapsto> case_option {n} (insert n) (m v))) (sorted_list_of_set (uses g n))"

  lemma addN_transfer [transfer_rule]:
    "rel_fun (=) (rel_fun (=) (rel_fun (pcr_mapping (=) (=)) (pcr_mapping (=) (=)))) addN' addN"
    unfolding addN_def [abs_def] addN'_def [abs_def]
      Mapping.map_default_def [abs_def] Mapping.default_def
  apply (auto simp: mapping.pcr_cr_eq rel_fun_def cr_mapping_def)
  apply transfer
  apply (rule fold_cong)
    apply simp
   apply simp
  apply (intro ext)
  by auto

  definition "useNodes_of g = fold (addN g) (\<alpha>n g) Mapping.empty"
  lemmas useNodes_of_code = useNodes_of_def [unfolded addN_def [abs_def]]
  declare useNodes_of_code [code]

  lemma lookup_useNodes_of':
    assumes [simp]: "\<And>n. finite (uses g n)"
    shows "Mapping.lookup (useNodes_of g) v =
    (if (\<exists>n \<in> set (\<alpha>n g). v \<in> uses g n) then Some {n \<in> set (\<alpha>n g). v \<in> uses g n} else None)"
  proof -
    { fix m n xs v
      have "Mapping.lookup (fold (\<lambda>v. Mapping.map_default (v::'var) {} (insert (n::'node))) xs m) v=
        (case Mapping.lookup m v of None \<Rightarrow> (if v \<in> set xs then Some {n} else None)
          | Some N \<Rightarrow> (if v \<in> set xs then Some (insert n N) else Some N))"
      by (induction xs arbitrary: m) (auto simp: Mapping_lookup_map_default split: option.splits)
    }
    note addN_conv = this [of n "sorted_list_of_set (uses g n)" for g n, folded addN_def, simplified]
    { fix xs m v
      have "Mapping.lookup (fold (addN g) xs m) v = (case Mapping.lookup m v of None \<Rightarrow> if (\<exists>n\<in>set xs. v \<in> uses g n) then Some {n\<in>set xs. v \<in> uses g n} else None
        | Some N \<Rightarrow> Some ({n\<in>set xs. v \<in> uses g n} \<union> N))"
      by (induction xs arbitrary: m) (auto split: option.splits simp: addN_conv)
    }
    note this [of "\<alpha>n g" Mapping.empty, simp]
    show ?thesis unfolding useNodes_of_def
      by (auto split: option.splits simp: lookup_empty)
  qed
end

context CFG begin
  lift_definition useNodes_of' :: "'g \<Rightarrow> ('var, 'node set) mapping"
  is "\<lambda>g v. if (\<exists>n \<in> set (\<alpha>n g). v \<in> uses g n) then Some {n \<in> set (\<alpha>n g). v \<in> uses g n} else None" .

  lemma useNodes_of': "useNodes_of' = useNodes_of"
  proof
    fix g
    { fix m n xs
      have "fold (\<lambda>v m. m(v::'var \<mapsto> case m v of None \<Rightarrow> {n::'node} | Some x \<Rightarrow> insert n x)) xs m =
        (\<lambda>v. case m v of None \<Rightarrow> (if v \<in> set xs then Some {n} else None)
          | Some N \<Rightarrow> (if v \<in> set xs then Some (insert n N) else Some N))"
      by (induction xs arbitrary: m)(auto split: option.splits)
    }
    note addN'_conv = this [of n "sorted_list_of_set (uses g n)" for g n, folded addN'_def, simplified]
    { fix xs m
      have "fold (addN' g) xs m = (\<lambda>v. case m v of None \<Rightarrow> if (\<exists>n\<in>set xs. v \<in> uses g n) then Some {n\<in>set xs. v \<in> uses g n} else None
        | Some N \<Rightarrow> Some ({n\<in>set xs. v \<in> uses g n} \<union> N))"
      by (induction xs arbitrary: m) (auto 4 4 split: option.splits if_splits simp: addN'_conv intro!: ext)
    }
    note this [of "\<alpha>n g" Map.empty, simp]
    show "useNodes_of' g = useNodes_of g"
    unfolding mmap_def useNodes_of_def
    by (transfer fixing: g) auto
  qed

  declare useNodes_of'.transfer [unfolded useNodes_of', transfer_rule]

end

context CFG_SSA_base begin
  definition phis_addN
  where "phis_addN g n = fold (\<lambda>v. Mapping.map_default v {} (insert n)) (case_option [] id (phis g n))"

  definition phidefNodes where [code]:
    "phidefNodes g = fold (\<lambda>(n,v). Mapping.update v n) (sorted_list_of_set (dom (phis g))) Mapping.empty"

  lemma keys_phidefNodes:
    assumes "finite (dom (phis g))"
    shows "Mapping.keys (phidefNodes g) = snd ` dom (phis g)"
  proof -
    { fix xs m x
      have "fold (\<lambda>(a,b) m. m(b \<mapsto> a)) (xs::('node \<times> 'val) list) m x = (if x \<in> snd ` set xs then (Some \<circ> fst) (last [(b,a)\<leftarrow>xs. a = x]) else m x)"
      by (induction xs arbitrary: m) (auto split: if_splits simp: filter_empty_conv intro: rev_image_eqI)
    }
    from this [of "sorted_list_of_set (dom (phis g))" Map.empty] assms
    show ?thesis
    unfolding phidefNodes_def keys_dom_lookup
    by (transfer fixing: g phis) (auto simp: dom_def intro: rev_image_eqI)
  qed

  definition phiNodes_of :: "'g \<Rightarrow> ('val, ('node \<times> 'val) set) mapping"
  where "phiNodes_of g = fold (phis_addN g) (sorted_list_of_set (dom (phis g))) Mapping.empty"

  lemma lookup_phiNodes_of:
  assumes [simp]: "finite (dom (phis g))"
  shows "Mapping.lookup (phiNodes_of g) v =
    (if (\<exists>n \<in> dom (phis g). v \<in> set (the (phis g n))) then Some {n \<in> dom (phis g). v \<in> set (the (phis g n))} else None)"
  proof -
  {
    fix m n xs v
    have "Mapping.lookup (fold (\<lambda>v. Mapping.map_default v {} (insert (n::'node \<times> 'val))) xs (m::('val, ('node \<times> 'val) set) mapping)) v =
      (case Mapping.lookup m v of None \<Rightarrow> (if v \<in> set xs then Some {n} else None)
        | Some N \<Rightarrow> (if v \<in> set xs then Some (insert n N) else Some N))"
    by (induction xs arbitrary: m) (auto simp: Mapping_lookup_map_default split: option.splits)
  }
  note phis_addN_conv = this [of n "case_option [] id (phis g n)" for n, folded phis_addN_def]
  {
    fix xs m v
    have "Mapping.lookup (fold (phis_addN g) xs m) v =
      (case Mapping.lookup m v of None \<Rightarrow> if (\<exists>n \<in> set xs. v \<in> set (case_option [] id (phis g n))) then Some {n \<in> set xs. v \<in> set (case_option [] id (phis g n))} else None
        | Some N \<Rightarrow> Some ({n \<in> set xs. v \<in> set (case_option [] id (phis g n))} \<union> N))"
    by (induction xs arbitrary: m) (auto simp: phis_addN_conv split: option.splits if_splits)+
  }
  note this [of "sorted_list_of_set (dom (phis g))", simp]
  show ?thesis
    unfolding phiNodes_of_def
  by (force split: option.splits simp: lookup_empty)
  qed

  lemmas phiNodes_of_code = phiNodes_of_def [unfolded phis_addN_def [abs_def]]
  declare phiNodes_of_code [code]

lemma phis_transfer [transfer_rule]:
  includes lifting_syntax
  shows "((=) ===> pcr_mapping (=) (=)) phis (\<lambda>g. Mapping.Mapping (phis g))"
  by (auto simp: mapping.pcr_cr_eq rel_fun_def cr_mapping_def Mapping.Mapping_inverse)

end

context CFG_SSA begin
  declare lookup_phiNodes_of [OF phis_finite, simp]
  declare keys_phidefNodes [OF phis_finite, simp]
end

locale CFG_SSA_ext_base = CFG_SSA_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  for \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set"
    and \<alpha>n :: "'g \<Rightarrow> 'node list"
    and invar :: "'g \<Rightarrow> bool"
    and inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list"
    and Entry :: "'g \<Rightarrow> 'node"
    and "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set"
    and phis :: "'g \<Rightarrow> ('node, 'val) phis"
begin
  abbreviation "cache g f \<equiv> Mapping.tabulate (\<alpha>n g) f"

  lemma lookup_cache[simp]: "n \<in> set (\<alpha>n g) \<Longrightarrow> Mapping.lookup (cache g f) n = Some (f n)"
  by transfer (auto simp: Map.map_of_map_restrict)

  lemma lookup_cacheD [dest]: "Mapping.lookup (cache g f) x = Some y \<Longrightarrow> y = f x"
  by transfer (auto simp: Map.map_of_map_restrict restrict_map_def split: if_splits)

  lemma lookup_cache_usesD: "Mapping.lookup (cache g (uses g)) n = Some vs \<Longrightarrow> vs = uses g n"
  by blast
end

definition[simp]: "usesOf m n \<equiv> case_option {} id (Mapping.lookup m n)"

locale CFG_SSA_ext = CFG_SSA_ext_base  \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  + CFG_SSA \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  for \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set"
    and \<alpha>n :: "'g \<Rightarrow> 'node list"
    and invar :: "'g \<Rightarrow> bool"
    and inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list"
    and Entry :: "'g \<Rightarrow> 'node"
    and "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set"
    and phis :: "'g \<Rightarrow> ('node, 'val) phis"
begin
  lemma usesOf_cache[abs_def, simp]: "usesOf (cache g (uses g)) n = uses g n"
  by (auto simp: uses_in_\<alpha>n dest: lookup_cache_usesD split: option.split)
end

locale CFG_SSA_base_code = CFG_SSA_ext_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "usesOf \<circ> uses" "\<lambda>g. Mapping.lookup (phis g)"
  for \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set"
    and \<alpha>n :: "'g \<Rightarrow> 'node list"
    and invar :: "'g \<Rightarrow> bool"
    and inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list"
    and Entry :: "'g \<Rightarrow> 'node"
    and "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'g \<Rightarrow> ('node, 'val set) mapping"
    and phis :: "'g \<Rightarrow> ('node, 'val) phis_code"
begin
  declare phis_transfer [simplified, transfer_rule]

  lemma phiDefs_code [code]:
  "phiDefs g n = snd ` Set.filter (\<lambda>(n',v). n' = n) (Mapping.keys (phis g))"
    unfolding phiDefs_def
    by transfer (auto 4 3 intro: rev_image_eqI simp: Set.filter_def)

  lemmas phiUses_code [code] = phiUses_def [folded Union_of_alt_def]
  declare allUses_def [code]
  lemmas allVars_code [code] = allVars_def [folded Union_of_alt_def]
end

locale CFG_SSA_code = CFG_SSA_base_code  \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  + CFG_SSA_ext \<alpha>e \<alpha>n invar inEdges' Entry "defs" "usesOf \<circ> uses" "\<lambda>g. Mapping.lookup (phis g)"
  for \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set"
    and \<alpha>n :: "'g \<Rightarrow> 'node list"
    and invar :: "'g \<Rightarrow> bool"
    and inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list"
    and Entry :: "'g \<Rightarrow> 'node"
    and "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'g \<Rightarrow> ('node, 'val set) mapping"
    and phis :: "'g \<Rightarrow> ('node, 'val) phis_code"

definition "the_trivial v vs = (case (foldl (\<lambda>(good,v') w. if w = v then (good,v')
      else case v' of Some v' \<Rightarrow> (good \<and> w = v', Some v')
        | None \<Rightarrow> (good, Some w))
    (True, None) vs)
  of (False, _) \<Rightarrow> None | (True,v) \<Rightarrow> v)"

lemma the_trivial_Nil [simp]: "the_trivial x [] = None"
  unfolding the_trivial_def by simp

lemma the_trivialI:
  assumes "set vs \<subseteq> {v, v'}"
    and "v' \<noteq> v"
  shows "the_trivial v vs = (if set vs \<subseteq> {v} then None else Some v')"
proof -
  { fix vx
    have "\<lbrakk> set vs \<subseteq> {v, v'}; v' \<noteq> v; vx \<in> {None, Some v'} \<rbrakk>
    \<Longrightarrow> (case foldl (\<lambda>(good, v') w.
                    if w = v then (good, v')
                    else case v' of None \<Rightarrow> (good, Some w) | Some v' \<Rightarrow> (good \<and> w = v', Some v'))
           (True, vx) vs of
     (True, x) \<Rightarrow> x | (False, x) \<Rightarrow> None) = (if set vs \<subseteq> {v} then vx else Some v')"
    by (induction vs arbitrary: vx; case_tac vx; auto)
  }
  with assms show ?thesis unfolding the_trivial_def by simp
qed

lemma the_trivial_conv:
  shows "the_trivial v vs = (if \<exists>v' \<in> set vs. v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v} then Some (THE v'. v' \<in> set vs \<and> v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v}) else None)"
proof -
  { fix b a vs
    have "a \<noteq> v
       \<Longrightarrow> foldl (\<lambda>(good, v') w.
                     if w = v then (good, v')
                     else case v' of None \<Rightarrow> (good, Some w) | Some v' \<Rightarrow> (good \<and> w = v', Some v'))
            (b, Some a) vs =
           (b \<and> set vs \<subseteq> {v, a}, Some a)"
     by (induction vs arbitrary: b; clarsimp)
  }
  note this[simp]
  { fix b vx
    have "\<lbrakk> vx \<in> insert None (Some ` set vs); case_option True (\<lambda>vx. vx \<noteq> v) vx \<rbrakk>
    \<Longrightarrow> foldl (\<lambda>(good, v') w.
                    if w = v then (good, v')
                    else case v' of None \<Rightarrow> (good, Some w) | Some v' \<Rightarrow> (good \<and> w = v', Some v'))
        (b, vx) vs = (b \<and> (case vx of Some w \<Rightarrow> set vs \<subseteq> {v, w} | None \<Rightarrow> \<exists>w. set vs \<subseteq> {v, w}),
        (case vx of Some w \<Rightarrow> Some w | None \<Rightarrow> if (\<exists>v'\<in>set vs. v' \<noteq> v) then Some (hd (filter (\<lambda>v'. v' \<noteq> v) vs)) else None))"
    by (induction vs arbitrary: b vx; auto)
  }
  hence "the_trivial v vs = (if \<exists>v' \<in> set vs. v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v} then Some (hd (filter (\<lambda>v'. v' \<noteq> v) vs)) else None)"
    unfolding the_trivial_def by (auto split: bool.splits)
  thus ?thesis
  apply (auto split: if_splits)
  apply (rule the_equality [THEN sym])
   by (thin_tac "P" for P, (induction vs; auto))+
qed

lemma the_trivial_SomeE:
  assumes "the_trivial v vs = Some v'"
  obtains "v \<noteq> v'" and "set vs = {v'}" | "v \<noteq> v'" and "set vs = {v,v'}"
using assms
apply atomize_elim
apply (subst(asm) the_trivial_conv)
apply (split if_splits; simp)
by (subgoal_tac "(THE v'. v' \<in> set vs \<and> v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v}) = hd (filter (\<lambda>v'. v' \<noteq> v) vs)")
  (fastforce simp: set_double_filter_hd set_single_hd set_minus_one)+

locale CFG_SSA_wf_base_code = CFG_SSA_base_code \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  + CFG_SSA_wf_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "usesOf \<circ> uses" "\<lambda>g. Mapping.lookup (phis g)"
  for \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set"
    and \<alpha>n :: "'g \<Rightarrow> 'node list"
    and invar :: "'g \<Rightarrow> bool"
    and inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list"
    and Entry :: "'g \<Rightarrow> 'node"
    and "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'g \<Rightarrow> ('node, 'val set) mapping"
    and phis :: "'g \<Rightarrow> ('node, 'val) phis_code"
begin
  definition [code]:
    "trivial_code (v::'val) vs = (the_trivial v vs \<noteq> None)"
  definition[code]: "trivial_phis g = Set.filter (\<lambda>(n,v). trivial_code v (the (Mapping.lookup (phis g) (n,v)))) (Mapping.keys (phis g))"
  definition [code]: "redundant_code g = (trivial_phis g \<noteq> {})"
end

locale CFG_SSA_wf_code = CFG_SSA_code \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  + CFG_SSA_wf_base_code \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
  + CFG_SSA_wf \<alpha>e \<alpha>n invar inEdges' Entry "defs" "usesOf \<circ> uses" "\<lambda>g. Mapping.lookup (phis g)"
  for \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set"
    and \<alpha>n :: "'g \<Rightarrow> 'node list"
    and invar :: "'g \<Rightarrow> bool"
    and inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list"
    and Entry :: "'g \<Rightarrow> 'node"
    and "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'g \<Rightarrow> ('node, 'val set) mapping"
    and phis :: "'g \<Rightarrow> ('node, 'val) phis_code"
begin
  lemma trivial_code:
    "phi g v = Some vs \<Longrightarrow> trivial g v = trivial_code v vs"
  unfolding trivial_def trivial_code_def
  apply (auto split: option.splits simp: isTrivialPhi_def)
    apply (clarsimp simp: the_trivial_conv split: if_splits)
   apply (clarsimp simp: the_trivial_conv split: if_splits)
  apply (erule the_trivial_SomeE)
   apply simp
   apply (rule phiArg_in_allVars; auto simp: phiArg_def)
  apply (rename_tac v')
  apply (rule_tac x=v' in bexI)
   apply simp
  apply (rule phiArg_in_allVars; auto simp: phiArg_def)
  done

  lemma trivial_phis:
    "trivial_phis g = {(n,v). Mapping.lookup (phis g) (n,v) \<noteq> None \<and> trivial g v}"
  unfolding trivial_phis_def Set.filter_def
  apply (auto simp add: phi_def keys_dom_lookup)
   apply (subst trivial_code)
    apply (auto simp: image_def trivial_in_allVars phis_phi)
  apply (frule trivial_phi)
  apply (auto simp add: trivial_code phi_def[symmetric] phis_phi)
  done

  lemma redundant_code:
    "redundant g = redundant_code g"
  unfolding redundant_def redundant_code_def trivial_phis[of g]
  apply (auto simp: image_def trivial_in_allVars)
  apply (frule trivial_phi)
  apply (auto simp: phi_def)
  done

  lemma trivial_code_mapI:
  "\<lbrakk> trivial_code v vs; f ` (set vs - {v}) \<noteq> {v} ; f v = v \<rbrakk> \<Longrightarrow> trivial_code v (map f vs)"
  unfolding trivial_code_def the_trivial_conv
    by (auto split: if_splits)

  lemma trivial_code_map_conv:
    "f v = v \<Longrightarrow> trivial_code v (map f vs) \<longleftrightarrow> (\<exists>v'\<in>set vs. f v' \<noteq> v \<and> (f ` set vs) - {f v'} \<subseteq> {v})"
    unfolding trivial_code_def the_trivial_conv
    by auto

end

locale CFG_SSA_Transformed_code = ssa: CFG_SSA_wf_code \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
   +
   CFG_SSA_Transformed \<alpha>e \<alpha>n invar inEdges' Entry oldDefs oldUses "defs" "usesOf \<circ> uses" "\<lambda>g. Mapping.lookup (phis g)" var
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  oldDefs :: "'g \<Rightarrow> 'node \<Rightarrow> 'var::linorder set" and
  oldUses :: "'g \<Rightarrow> 'node \<Rightarrow> 'var set" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> ('node, 'val set) mapping" and
  phis :: "'g \<Rightarrow> ('node, 'val) phis_code" and
  var :: "'g \<Rightarrow> 'val \<Rightarrow> 'var"
+
assumes dom_uses_in_graph: "Mapping.keys (uses g) \<subseteq> set (\<alpha>n g)"

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__50_on_rules imports n_german_lemma_on_inv__50
begin
section{*All lemmas on causal relation between inv__50*}
lemma lemma_inv__50_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__50  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__50) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end