(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedMap, transfer of iterators to OrderedSet

*)
section \<open>\isaheader{Implementing Sets by Maps}\<close>
theory SetByMap
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
  SetGA
  MapGA
begin
text_raw \<open>\label{thy:SetByMap}\<close>

text \<open>
  In this theory, we show how to implement sets
  by maps.
\<close>

(* TODO: We could also define some more operations directly,
  e.g. union, ball, bex, \<dots> *)

text \<open>Auxiliary lemma\<close>
lemma foldli_foldli_map_eq:
  "foldli (foldli l (\<lambda>x. True) (\<lambda>x l. l@[f x]) []) c f' \<sigma>0
    = foldli l c (f' o f) \<sigma>0"
proof -
  show ?thesis
    apply (simp add: map_by_foldl foldli_map foldli_foldl)
    done
qed

locale SetByMapDefs =
  map: StdBasicMapDefs ops
  for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
  definition "\<alpha> s \<equiv> dom (map.\<alpha> s)"
  definition "invar s \<equiv> map.invar s"
  definition empty where "empty \<equiv> map.empty"
  definition "memb x s \<equiv> map.lookup x s \<noteq> None"
  definition "ins x s \<equiv> map.update x () s"
  definition "ins_dj x s \<equiv> map.update_dj x () s"
  definition "delete x s \<equiv> map.delete x s"
  definition list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    where "list_it s c f \<sigma>0 \<equiv> it_to_it (map.list_it s) c (f o fst) \<sigma>0"

  local_setup \<open>Locale_Code.lc_decl_del @{term list_it}\<close>

  lemma list_it_alt: "list_it s = map_iterator_dom (map.iteratei s)"
  proof -
    have A: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>x. f (fst x))" by auto
    show ?thesis
      unfolding list_it_def[abs_def] map_iterator_dom_def
        poly_map_iteratei_defs.iteratei_def
        set_iterator_image_def set_iterator_image_filter_def
      by (auto simp: comp_def)
  qed

  lemma list_it_unfold:
    "it_to_it (list_it s) c f \<sigma>0 = map.iteratei s c (f o fst) \<sigma>0"
    unfolding list_it_def[abs_def] it_to_it_def
    unfolding poly_map_iteratei_defs.iteratei_def it_to_it_def
    by (simp add: foldli_foldli_map_eq comp_def)

  definition [icf_rec_def]: "dflt_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = \<alpha>,
    bset_op_invar = invar,
    bset_op_empty = empty,
    bset_op_memb = memb,
    bset_op_ins = ins,
    bset_op_ins_dj = ins_dj,
    bset_op_delete = delete,
    bset_op_list_it = list_it
    \<rparr>"
  local_setup \<open>Locale_Code.lc_decl_del @{term dflt_basic_ops}\<close>

end

setup \<open>
  (Record_Intf.add_unf_thms_global @{thms
    SetByMapDefs.list_it_def[abs_def]
  })
\<close>

(*lemmas [code_unfold] = SetByMapDefs.list_it_def[abs_def]*)

locale SetByMap = SetByMapDefs ops +
  map: StdBasicMap ops
  for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
  lemma empty_impl: "set_empty \<alpha> invar empty"
    apply unfold_locales
    unfolding \<alpha>_def invar_def empty_def
    by (auto simp: map.empty_correct)

  lemma memb_impl: "set_memb \<alpha> invar memb"
    apply unfold_locales
    unfolding \<alpha>_def invar_def memb_def
    by (auto simp: map.lookup_correct)

  lemma ins_impl: "set_ins \<alpha> invar ins"
    apply unfold_locales
    unfolding \<alpha>_def invar_def ins_def
    by (auto simp: map.update_correct)

  lemma ins_dj_impl: "set_ins_dj \<alpha> invar ins_dj"
    apply unfold_locales
    unfolding \<alpha>_def invar_def ins_dj_def
    by (auto simp: map.update_dj_correct)

  lemma delete_impl: "set_delete \<alpha> invar delete"
    apply unfold_locales
    unfolding \<alpha>_def invar_def delete_def
    by (auto simp: map.delete_correct)

  lemma list_it_impl: "poly_set_iteratei \<alpha> invar list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>xy. f (fst xy))"
      by auto

    from map_iterator_dom_correct[OF map.iteratei_correct[OF I']]
    show "set_iterator (list_it s) (\<alpha> s)"
      unfolding \<alpha>_def list_it_alt .

    show "finite (\<alpha> s)"
      unfolding \<alpha>_def by (simp add: map.finite[OF I'])
  qed

  lemma dflt_basic_ops_impl: "StdBasicSet dflt_basic_ops"
    apply (rule StdBasicSet.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule empty_impl memb_impl ins_impl
      ins_dj_impl delete_impl
      list_it_impl[unfolded SetByMapDefs.list_it_def[abs_def]]
    )+
    done
end

locale OSetByOMapDefs = SetByMapDefs ops +
  map: StdBasicOMapDefs ops
  for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
  definition ordered_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    where "ordered_list_it s c f \<sigma>0
    \<equiv> it_to_it (map.ordered_list_it s) c (f o fst) \<sigma>0"
    (*where "list_it s c f \<sigma>0 \<equiv> it_to_it (map.list_it s) c (f o fst) \<sigma>0"*)
  local_setup \<open>Locale_Code.lc_decl_del @{term ordered_list_it}\<close>

  definition rev_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    where "rev_list_it s c f \<sigma>0 \<equiv> it_to_it (map.rev_list_it s) c (f o fst) \<sigma>0"
    (*where "rev_list_it s c f \<sigma>0 \<equiv> map.rev_iterateoi s c (f o fst) \<sigma>0"*)
  local_setup \<open>Locale_Code.lc_decl_del @{term rev_list_it}\<close>

  definition [icf_rec_def]: "dflt_basic_oops \<equiv>
    set_basic_ops.extend dflt_basic_ops \<lparr>
      bset_op_ordered_list_it = ordered_list_it,
      bset_op_rev_list_it = rev_list_it
      \<rparr>"
  local_setup \<open>Locale_Code.lc_decl_del @{term dflt_basic_oops}\<close>

end

setup \<open>
  (Record_Intf.add_unf_thms_global @{thms
    OSetByOMapDefs.ordered_list_it_def[abs_def]
    OSetByOMapDefs.rev_list_it_def[abs_def]
  })
\<close>

(*lemmas [code_unfold] = OSetByOMapDefs.ordered_list_it_def[abs_def]
  OSetByOMapDefs.rev_list_it_def[abs_def]*)

locale OSetByOMap = OSetByOMapDefs ops +
  SetByMap ops + map: StdBasicOMap ops
  for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
  lemma ordered_list_it_impl: "poly_set_iterateoi \<alpha> invar ordered_list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>xy. f (fst xy))"
      by auto

    have A: "\<And>s. ordered_list_it s = map_iterator_dom (map.iterateoi s)"
      unfolding ordered_list_it_def[abs_def]
        map_iterator_dom_def set_iterator_image_alt_def map.iterateoi_def
      by (simp add: S comp_def)

    from map_iterator_linord_dom_correct[OF map.iterateoi_correct[OF I']]
    show "set_iterator_linord (ordered_list_it s) (\<alpha> s)"
      unfolding \<alpha>_def A .

    show "finite (\<alpha> s)"
      unfolding \<alpha>_def by (simp add: map.finite[OF I'])
  qed

  lemma rev_list_it_impl: "poly_set_rev_iterateoi \<alpha> invar rev_list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>xy. f (fst xy))"
      by auto

    have A: "\<And>s. rev_list_it s = map_iterator_dom (map.rev_iterateoi s)"
      unfolding rev_list_it_def[abs_def]
        map_iterator_dom_def set_iterator_image_alt_def map.rev_iterateoi_def
      by (simp add: S comp_def)

    from map_iterator_rev_linord_dom_correct[
      OF map.rev_iterateoi_correct[OF I']]
    show "set_iterator_rev_linord (rev_list_it s) (\<alpha> s)"
      unfolding \<alpha>_def A .

    show "finite (\<alpha> s)"
      unfolding \<alpha>_def by (simp add: map.finite[OF I'])

  qed

  lemma dflt_basic_oops_impl: "StdBasicOSet dflt_basic_oops"
  proof -
    interpret aux: StdBasicSet dflt_basic_ops by (rule dflt_basic_ops_impl)

    show ?thesis
      apply (rule StdBasicOSet.intro)
      apply (rule StdBasicSet.intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule
        ordered_list_it_impl[unfolded ordered_list_it_def[abs_def]]
        rev_list_it_impl[unfolded rev_list_it_def[abs_def]]
      )+
      done
  qed
end

sublocale SetByMap < basic: StdBasicSet "dflt_basic_ops"
  by (rule dflt_basic_ops_impl)

sublocale OSetByOMap < obasic: StdBasicOSet "dflt_basic_oops"
  by (rule dflt_basic_oops_impl)

lemma proper_it'_map2set: "proper_it' it it'
  \<Longrightarrow> proper_it' (\<lambda>s c f. it s c (f o fst)) (\<lambda>s c f. it' s c (f o fst))"
  unfolding proper_it'_def
  apply clarsimp
  apply (drule_tac x=s in spec)
  apply (erule proper_itE)
  apply (rule proper_itI)
  apply (auto simp add: foldli_map[symmetric] intro!: ext)
  done

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Set Implementation by List} *}
theory ListSetImpl
imports "../spec/SetSpec" "../gen_algo/SetGA" "../../Lib/Dlist_add"
begin
text_raw {*\label{thy:ListSetImpl}*}

(*@impl Set
  @type 'a ls
  @abbrv ls,l
  Sets implemented by distinct lists. For efficient
  @{text "insert_dj"}-operations, use the version with explicit invariant (lsi).
*)

type_synonym
  'a ls = "'a dlist"

subsection "Definitions"

definition ls_\<alpha> :: "'a ls \<Rightarrow> 'a set" where "ls_\<alpha> l == set (list_of_dlist l)"

definition ls_basic_ops :: "('a,'a ls) set_basic_ops" where
  [icf_rec_def]: "ls_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = ls_\<alpha>,
    bset_op_invar = \<lambda>_. True,
    bset_op_empty = \<lambda>_. Dlist.empty,
    bset_op_memb = (\<lambda>x s. Dlist.member s x),
    bset_op_ins = Dlist.insert,
    bset_op_ins_dj = Dlist.insert,
    bset_op_delete = dlist_remove',
    bset_op_list_it = dlist_iteratei
    \<rparr>"

setup Locale_Code.open_block
interpretation ls_basic!: StdBasicSet ls_basic_ops
  apply unfold_locales
  unfolding ls_basic_ops_def ls_\<alpha>_def[abs_def]
  apply (auto simp: dlist_member_empty Dlist.member_def List.member_def
    dlist_iteratei_correct
    dlist_remove'_correct set_dlist_remove1'
  )
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "ls_ops \<equiv> ls_basic.dflt_ops\<lparr>
  set_op_to_list := list_of_dlist
  \<rparr>"

setup Locale_Code.open_block
interpretation ls!: StdSetDefs ls_ops .
interpretation ls!: StdSet ls_ops
proof -
  interpret aux: StdSet ls_basic.dflt_ops
    by (rule ls_basic.dflt_ops_impl)

  show "StdSet ls_ops"
    unfolding ls_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales)
    apply (simp_all add: ls_\<alpha>_def)
    done
qed

interpretation ls!: StdSet_no_invar ls_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "ls"*}

lemma pi_ls[proper_it]:
  "proper_it' dlist_iteratei dlist_iteratei"
  apply (rule proper_it'I)
  unfolding dlist_iteratei_def
  by (intro icf_proper_iteratorI)

lemma pi_ls'[proper_it]:
  "proper_it' ls.iteratei ls.iteratei"
  apply (rule proper_it'I)
  unfolding ls.iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_ls: proper_it_loc dlist_iteratei dlist_iteratei
  apply unfold_locales by (rule pi_ls)

interpretation pi_ls': proper_it_loc ls.iteratei ls.iteratei
  apply unfold_locales by (rule pi_ls')

definition test_codegen where "test_codegen \<equiv> (
  ls.empty,
  ls.memb,
  ls.ins,
  ls.delete,
  ls.list_it,
  ls.sng,
  ls.isEmpty,
  ls.isSng,
  ls.ball,
  ls.bex,
  ls.size,
  ls.size_abort,
  ls.union,
  ls.union_dj,
  ls.diff,
  ls.filter,
  ls.inter,
  ls.subset,
  ls.equal,
  ls.disjoint,
  ls.disjoint_witness,
  ls.sel,
  ls.to_list,
  ls.from_list
)"

export_code test_codegen in SML

end


theory Type_Graph
  imports
    Main
    HOL.Order_Relation
    Graph_Theory.Digraph
    Multiplicity_Pair
begin

section "Label definitions"

datatype ('lt) LabDef = type 'lt | edge 'lt | flag 'lt | bool | int | real | string

fun unlabel :: "'lt LabDef \<Rightarrow> 'lt" where
  "unlabel (type t) = t" |
  "unlabel (edge e) = e" |
  "unlabel (flag f) = f" |
  "unlabel _ = undefined"

subsection "Type labels"

inductive_set Lab\<^sub>t :: "'nt LabDef set"
  where
    rule_type_labels: "\<And>n. type n \<in> Lab\<^sub>t"

lemma lab_type_member[simp]: "x \<in> Lab\<^sub>t \<Longrightarrow> \<exists>y. x = type y"
  by (simp add: Lab\<^sub>t.simps)

lemma lab_type_contains_no_edge_labels[simp]: "edge x \<notin> Lab\<^sub>t"
  using lab_type_member by blast

lemma lab_type_contains_no_flag_labels[simp]: "flag x \<notin> Lab\<^sub>t"
  using lab_type_member by blast

lemma lab_type_contains_no_bool[simp]: "bool \<notin> Lab\<^sub>t"
  using lab_type_member by blast

lemma lab_type_contains_no_int[simp]: "int \<notin> Lab\<^sub>t"
  using lab_type_member by blast

lemma lab_type_contains_no_real[simp]: "real \<notin> Lab\<^sub>t"
  using lab_type_member by blast

lemma lab_type_contains_no_string[simp]: "string \<notin> Lab\<^sub>t"
  using lab_type_member by blast

subsection "Edge labels"

inductive_set Lab\<^sub>e :: "'nt LabDef set"
  where
    rule_edge_labels: "\<And>n. edge n \<in> Lab\<^sub>e"

lemma lab_edge_member[simp]: "x \<in> Lab\<^sub>e \<Longrightarrow> \<exists>y. x = edge y"
  by (simp add: Lab\<^sub>e.simps)

lemma lab_edge_contains_no_type_labels[simp]: "type x \<notin> Lab\<^sub>e"
  using lab_edge_member by blast

lemma lab_edge_contains_no_flag_labels[simp]: "flag x \<notin> Lab\<^sub>e"
  using lab_edge_member by blast

lemma lab_edge_contains_no_bool[simp]: "bool \<notin> Lab\<^sub>e"
  using lab_edge_member by blast

lemma lab_edge_contains_no_int[simp]: "int \<notin> Lab\<^sub>e"
  using lab_edge_member by blast

lemma lab_edge_contains_no_real[simp]: "real \<notin> Lab\<^sub>e"
  using lab_edge_member by blast

lemma lab_edge_contains_no_string[simp]: "string \<notin> Lab\<^sub>e"
  using lab_edge_member by blast

lemma lab_edge_lab_type_intersect[simp]: "Lab\<^sub>e \<inter> Lab\<^sub>t = {}"
  using lab_edge_member by fastforce

subsection "Flag labels"

inductive_set Lab\<^sub>f :: "'nt LabDef set"
  where
    rule_type_labels: "\<And>n. flag n \<in> Lab\<^sub>f"

lemma lab_flag_member[simp]: "x \<in> Lab\<^sub>f \<Longrightarrow> \<exists>y. x = flag y"
  by (simp add: Lab\<^sub>f.simps)

lemma lab_flag_contains_no_type_labels[simp]: "type x \<notin> Lab\<^sub>f"
  using lab_flag_member by blast

lemma lab_flag_contains_no_edge_labels[simp]: "edge x \<notin> Lab\<^sub>f"
  using lab_flag_member by blast

lemma lab_flag_contains_no_bool[simp]: "bool \<notin> Lab\<^sub>f"
  using lab_flag_member by blast

lemma lab_flag_contains_no_int[simp]: "int \<notin> Lab\<^sub>f"
  using lab_flag_member by blast

lemma lab_flag_contains_no_real[simp]: "real \<notin> Lab\<^sub>f"
  using lab_flag_member by blast

lemma lab_flag_contains_no_string[simp]: "string \<notin> Lab\<^sub>f"
  using lab_flag_member by blast

lemma lab_flag_lab_type_intersect[simp]: "Lab\<^sub>f \<inter> Lab\<^sub>t = {}"
  using lab_flag_member by fastforce

lemma lab_flag_lab_edge_intersect[simp]: "Lab\<^sub>f \<inter> Lab\<^sub>e = {}"
  using lab_flag_member by fastforce

subsection "Labels"

definition Lab :: "'nt LabDef set" where
  "Lab = Lab\<^sub>t \<union> Lab\<^sub>e \<union> Lab\<^sub>f"

lemma lab_member[simp]: "x \<in> Lab \<Longrightarrow> (\<exists>y. x = type y) \<or> (\<exists>y. x = edge y) \<or> (\<exists>y. x = flag y)"
  by (simp add: Lab\<^sub>e.simps Lab\<^sub>f.simps Lab\<^sub>t.simps Lab_def)

lemma lab_contains_no_bool[simp]: "bool \<notin> Lab"
  using lab_member by blast

lemma lab_contains_no_int[simp]: "int \<notin> Lab"
  using lab_member by blast

lemma lab_contains_no_real[simp]: "real \<notin> Lab"
  using lab_member by blast

lemma lab_contains_no_string[simp]: "string \<notin> Lab"
  using lab_member by blast

lemma lab_lab_type_intersect[simp]: "Lab \<inter> Lab\<^sub>t = Lab\<^sub>t"
  using Lab_def by blast

lemma lab_lab_edge_intersect[simp]: "Lab \<inter> Lab\<^sub>e = Lab\<^sub>e"
  using Lab_def by blast

lemma lab_lab_flag_intersect[simp]: "Lab \<inter> Lab\<^sub>f = Lab\<^sub>f"
  using Lab_def by blast

lemma lab_contains_lab_type[simp]: "Lab\<^sub>t \<subseteq> Lab"
  by (simp add: inf.absorb_iff2)

lemma lab_contains_lab_edge[simp]: "Lab\<^sub>e \<subseteq> Lab"
  by (simp add: inf.absorb_iff2)

lemma lab_contains_lab_flag[simp]: "Lab\<^sub>f \<subseteq> Lab"
  by (simp add: inf.absorb_iff2)

subsection "Primitive type labels"

definition Lab\<^sub>p :: "'nt LabDef set" where
  "Lab\<^sub>p = {bool, int, real, string}"

lemma lab_primitive_member[simp]: "x \<in> Lab\<^sub>p \<Longrightarrow> x = bool \<or> x = int \<or> x = real \<or> x = string"
  by (simp add: Lab\<^sub>p_def)

lemma lab_primitive_contains_no_type_labels[simp]: "type x \<notin> Lab\<^sub>p"
  using lab_primitive_member by blast

lemma lab_primitive_contains_no_edge_labels[simp]: "edge x \<notin> Lab\<^sub>p"
  using lab_primitive_member by blast

lemma lab_primitive_contains_no_flag_labels[simp]: "flag x \<notin> Lab\<^sub>p"
  using lab_primitive_member by blast

lemma lab_primitive_lab_intersect[simp]: "Lab\<^sub>p \<inter> Lab = {}"
  using lab_primitive_member by fastforce

lemma lab_primitive_lab_type_intersect[simp]: "Lab\<^sub>p \<inter> Lab\<^sub>t = {}"
  using lab_primitive_member by fastforce

lemma lab_primitive_lab_edge_intersect[simp]: "Lab\<^sub>p \<inter> Lab\<^sub>e = {}"
  using lab_primitive_member by fastforce

lemma lab_primitive_lab_flag_intersect[simp]: "Lab\<^sub>p \<inter> Lab\<^sub>f = {}"
  using lab_primitive_member by fastforce

section "Type graph tuple definition"

record ('lt) type_graph =
  NT :: "'lt LabDef set"
  ET :: "('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) set"
  inh :: "'lt LabDef rel"
  abs :: "'lt LabDef set"
  mult :: "('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<Rightarrow> multiplicity_pair"
  contains :: "('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) set"

inductive type_graph_eq :: "('lt) type_graph \<Rightarrow> ('lt) type_graph \<Rightarrow> bool"
  for TG1 TG2 :: "('lt) type_graph"
  where
    rule_equality: "\<lbrakk> NT TG1 = NT TG2;
                      ET TG1 = ET TG2;
                      inh TG1 = inh TG2;
                      abs TG1 = abs TG2;
                      mult TG1 = mult TG2;
                      contains TG1 = contains TG2 \<rbrakk> \<Longrightarrow> type_graph_eq TG1 TG2"

definition src :: "('a \<times> 'b \<times> 'a) \<Rightarrow> 'a" where
  [simp]: "src e = fst e"

definition lab :: "('a \<times> 'b \<times> 'a) \<Rightarrow> 'b" where
  [simp]: "lab e = fst (snd e)"

definition tgt :: "('a \<times> 'b \<times> 'a) \<Rightarrow> 'a" where
  [simp]: "tgt e = snd (snd e)"

definition edge_to_tuple :: "'a \<times> 'b \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  [simp]: "edge_to_tuple a \<equiv> (src a, tgt a)"

section "Graph theory projection"

definition type_graph_proj :: "('lt) type_graph \<Rightarrow> ('lt LabDef, 'lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) pre_digraph" where
  "type_graph_proj TG = \<lparr> verts = NT TG, arcs = ET TG, tail = tgt, head = src \<rparr>"

declare [[coercion type_graph_proj]]

section "Type graph validity"

locale type_graph = fixes TG :: "('lt) type_graph"
  assumes structure_nodes_wellformed: "\<And>n. n \<in> NT TG \<Longrightarrow> n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
  assumes structure_edges_wellformed: "\<And>s l t. (s, l, t) \<in> ET TG \<Longrightarrow> s \<in> NT TG \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> NT TG"
  assumes structure_inheritance_wellformed[simp]: "Field (inh TG) = NT TG"
  assumes structure_abstract_wellformed[simp]: "\<And>n. n \<in> abs TG \<Longrightarrow> n \<in> NT TG"
  assumes structure_mult_wellformed[simp]: "\<And>e. e \<in> ET TG \<Longrightarrow> multiplicity_pair (mult TG e)"
  assumes structure_mult_domain[simp]: "\<And>e. e \<notin> ET TG \<Longrightarrow> mult TG e = undefined"
  assumes structure_contains_wellformed[simp]: "\<And>e. e \<in> contains TG \<Longrightarrow> e \<in> ET TG"
  assumes validity_edges_inh[simp]: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG \<Longrightarrow> (s2, l, t2) \<in> ET TG \<Longrightarrow>
    (s1, s2) \<in> inh TG \<or> (s2, s1) \<in> inh TG \<Longrightarrow> (t1, t2) \<in> inh TG \<or> (t2, t1) \<in> inh TG \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes validity_flags[simp]: "\<And>s l t. (s, l, t) \<in> ET TG \<Longrightarrow> l \<in> Lab\<^sub>f \<Longrightarrow> s = t"
  assumes validity_inh: "Partial_order (inh TG)"
  assumes validity_mult_containment[simp]: "\<And>e. e \<in> contains TG \<Longrightarrow> upper (m_in (mult TG e)) = \<^bold>1"

context type_graph
begin

lemma structure_nodes_wellformed_alt[simp]: "\<And>n. n \<in> NT TG \<Longrightarrow> n \<in> Lab\<^sub>t \<or> n \<in> Lab\<^sub>p"
  using structure_nodes_wellformed by auto

lemma structure_edges_wellformed_src_node[simp]: "\<And>s. (s, l, t) \<in> ET TG \<Longrightarrow> s \<in> NT TG"
  by (simp add: structure_edges_wellformed)

lemma structure_edges_wellformed_edge_lab[simp]: "\<And>l. (s, l, t) \<in> ET TG \<Longrightarrow> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f"
  using structure_edges_wellformed by auto

lemma structure_edges_wellformed_edge_lab_alt1[simp]: "\<And>l. (s, l, t) \<in> ET TG \<Longrightarrow> l \<in> Lab\<^sub>e \<or> l \<in> Lab\<^sub>f"
  using structure_edges_wellformed_edge_lab by auto

lemma structure_edges_wellformed_tgt_node[simp]: "\<And>t. (s, l, t) \<in> ET TG \<Longrightarrow> t \<in> NT TG"
  by (simp add: structure_edges_wellformed)

lemma structure_edges_wellformed_alt: "\<And>e. e \<in> ET TG \<Longrightarrow> src e \<in> NT TG \<and> lab e \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> tgt e \<in> NT TG"
proof (intro conjI)
  fix e
  assume e_in_edges: "e \<in> ET TG"
  show "src e \<in> NT TG"
    using e_in_edges prod.collapse structure_edges_wellformed_src_node src_def
    by metis
  show "lab e \<in> Lab\<^sub>e \<union> Lab\<^sub>f"
    using e_in_edges prod.collapse structure_edges_wellformed_edge_lab lab_def
    by metis
  show "tgt e \<in> NT TG"
    using e_in_edges prod.collapse structure_edges_wellformed_tgt_node tgt_def
    by metis
qed

lemma structure_edges_wellformed_src_node_alt[simp]: "\<And>e. e \<in> ET TG \<Longrightarrow> src e \<in> NT TG"
  by auto

lemma structure_edges_wellformed_edge_lab_alt2[simp]: "\<And>e. e \<in> ET TG \<Longrightarrow> lab e \<in> Lab\<^sub>e \<or> lab e \<in> Lab\<^sub>f"
  using structure_edges_wellformed_alt by blast

lemma structure_edges_wellformed_tgt_node_alt[simp]: "\<And>e. e \<in> ET TG \<Longrightarrow> tgt e \<in> NT TG"
  by auto

lemma structure_inheritance_wellformed_first_node[simp]: "\<And>x. (x, y) \<in> inh TG \<Longrightarrow> x \<in> NT TG"
  using FieldI1 structure_inheritance_wellformed by fastforce

lemma structure_inheritance_wellformed_second_node[simp]: "\<And>y. (x, y) \<in> inh TG \<Longrightarrow> y \<in> NT TG"
  using FieldI2 structure_inheritance_wellformed by fastforce

lemma structure_inheritance_wellformed_alt: "\<And>x. x \<in> inh TG \<Longrightarrow> fst x \<in> NT TG \<and> snd x \<in> NT TG"
  by auto

lemma structure_inheritance_wellformed_first_node_alt[simp]: "\<And>x. x \<in> inh TG \<Longrightarrow> fst x \<in> NT TG"
  by auto

lemma structure_inheritance_wellformed_second_node_alt[simp]: "\<And>x. x \<in> inh TG \<Longrightarrow> snd x \<in> NT TG"
  by auto

lemma validity_edges_inh_alt: "\<And>e1 e2. e1 \<in> ET TG \<Longrightarrow> e2 \<in> ET TG \<Longrightarrow>
    (src e1, src e2) \<in> inh TG \<or> (src e2, src e1) \<in> inh TG \<Longrightarrow>
    (tgt e1, tgt e2) \<in> inh TG \<or> (tgt e2, tgt e1) \<in> inh TG \<Longrightarrow>
    lab e1 = lab e2 \<Longrightarrow> src e1 = src e2 \<and> tgt e1 = tgt e2"
  using validity_edges_inh
  by fastforce

lemma validity_flags_alt: "\<And>e. e \<in> ET TG \<Longrightarrow> lab e \<in> Lab\<^sub>f \<Longrightarrow> src e = tgt e"
  by auto

lemma validity_inh_antisym[simp]: "antisym (inh TG)"
  using partial_order_on_def validity_inh by blast

lemma validity_inh_trans[simp]: "trans (inh TG)"
  using partial_order_on_def preorder_on_def validity_inh by blast

lemma validity_inh_refl[simp]: "refl_on (Field (inh TG)) (inh TG)"
  using partial_order_on_def preorder_on_def validity_inh by auto

lemma validity_inh_node[simp]: "\<And>n. n \<in> NT TG \<Longrightarrow> (n, n) \<in> (inh TG)"
  using refl_onD structure_inheritance_wellformed validity_inh_refl by fastforce

lemma validity_inh_domain[simp]: "Domain (inh TG) = NT TG"
proof
  show "Domain (inh TG) \<subseteq> NT TG"
    by auto
next
  show "NT TG \<subseteq> Domain (inh TG)"
  proof
    fix x
    assume "x \<in> NT TG"
    then show "x \<in> Domain (inh TG)"
      by (intro DomainI) (fact validity_inh_node)
  qed
qed

lemma validity_inh_range[simp]: "Range (inh TG) = NT TG"
proof
  show "Range (inh TG) \<subseteq> NT TG"
    by auto
next
  show "NT TG \<subseteq> Range (inh TG)"
  proof
    fix x
    assume "x \<in> NT TG"
    then show "x \<in> Range (inh TG)"
      by (intro RangeI) (fact validity_inh_node)
  qed
qed

end

section "Graph theory compatibility"

sublocale type_graph \<subseteq> pre_digraph "type_graph_proj TG"
  rewrites "verts TG = NT TG" and "arcs TG = ET TG" and "tail TG = tgt" and "head TG = src"
  by unfold_locales (simp_all add: type_graph_proj_def)

sublocale type_graph \<subseteq> wf_digraph TG
proof
  have verts_are_nodes: "verts (type_graph_proj TG) = NT TG"
    by (simp add: type_graph_proj_def)
  have head_is_src: "head (type_graph_proj TG) = src"
    by (simp add: type_graph_proj_def)
  have tail_is_tgt: "tail (type_graph_proj TG) = tgt"
    by (simp add: type_graph_proj_def)
  fix e
  assume "e \<in> arcs (type_graph_proj TG)"
  then have e_in_edges: "e \<in> ET TG"
    by (simp add: type_graph_proj_def)
  show "tail (type_graph_proj TG) e \<in> verts (type_graph_proj TG)"
    using e_in_edges verts_are_nodes tail_is_tgt structure_edges_wellformed_tgt_node_alt
    by auto
  show "head (type_graph_proj TG) e \<in> verts (type_graph_proj TG)"
    using e_in_edges verts_are_nodes head_is_src structure_edges_wellformed_src_node_alt
    by auto
qed

section "Validity of trivial type graphs"

definition tg_empty :: "('lt) type_graph" where
  [simp]: "tg_empty = \<lparr>
    NT = {},
    ET = {},
    inh = {},
    abs = {},
    mult = (\<lambda>x. undefined),
    contains = {}
  \<rparr>"

lemma tg_empty_correct[simp]: "type_graph tg_empty"
  by (intro type_graph.intro) (simp_all)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Lemmas for Word Length 32"

theory Word_Lemmas_32
imports
  Word_Lemmas_Prefix
  Word_Setup_32
begin

lemma ucast_8_32_inj:
  "inj (ucast ::  8 word \<Rightarrow> 32 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 32 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_32 = upper_bits_unset_is_l2p [where 'a=32, folded word_bits_def]
lemmas le_2p_upper_bits_32 = le_2p_upper_bits [where 'a=32, folded word_bits_def]
lemmas le2p_bits_unset_32 = le2p_bits_unset[where 'a=32, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (32) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower32' = unat_power_lower[where 'a=32]
lemmas unat_power_lower32 [simp] = unat_power_lower32'[unfolded word_bits_len_of]

lemmas word32_less_sub_le' = word_less_sub_le[where 'a = 32]
lemmas word32_less_sub_le[simp] = word32_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word32) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word32_power_less_1' = word_power_less_1[where 'a = 32]
lemmas word32_power_less_1[simp] = word32_power_less_1'[folded word_bits_def]

lemma of_nat32_0:
  "\<lbrakk>of_nat n = (0::word32); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word32) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_def)
  done

lemmas unat_of_nat32' = unat_of_nat_eq[where 'a=32]
lemmas unat_of_nat32 = unat_of_nat32'[unfolded word_bits_len_of]

lemmas word_power_nonzero_32 = word_power_nonzero [where 'a=32, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 32, unfolded word_bits_len_of]]

lemmas div_power_helper_32 = div_power_helper [where 'a=32, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 32)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_32 = of_nat_power [where 'a=32, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word32
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word32' = unat_mask[where 'a=32]
lemmas unat_mask_word32 = unat_mask_word32'[folded word_bits_def]

lemma unat_less_2p_word_bits:
  "unat (x :: 32 word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size::word32)) = 2 ^ (min sz word_bits - 2)"
  apply (case_tac "sz < word_bits")
   apply (case_tac "2\<le>sz")
    apply (clarsimp simp: word_size_def word_bits_def min_def mask_def)
    apply (drule (2) Suc_div_unat_helper
           [where 'a=32 and sz=sz and us=2, simplified, symmetric])
   apply (simp add: not_le word_size_def word_bits_def)
   apply (case_tac sz, simp add: unat_word_ariths)
   apply (case_tac nat, simp add: unat_word_ariths
                                  unat_mask_word32 min_def word_bits_def)
   apply simp
  apply (simp add: unat_word_ariths
                   unat_mask_word32 min_def word_bits_def word_size_def)
  done

lemmas word32_minus_one_le' = word_minus_one_le[where 'a=32]
lemmas word32_minus_one_le = word32_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::word8
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word32)"
proof
  assume "ucast a = (0xFF::word32)"
  also
  have "(0xFF::word32) = ucast (0xFF::word8)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word32) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma unat_ucast_8_32:
  fixes x :: "word8"
  shows "unat (ucast x :: word32) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word32)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word32)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_32:
  "(ucast x \<le> (ucast y :: word32)) = (x \<le> (y :: word8))"
  by (simp add: ucast_le_ucast)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word32)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word32. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_32_0:
  "(2 ^ 32 :: word32) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word32 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_32_max_word  = max_word_mask [symmetric, where 'a=32, simplified]

lemma of_nat32_n_less_equal_power_2:
 "n < 32 \<Longrightarrow> ((of_nat n)::32 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word32) = [0, 0, 0, 0 :: word8]"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma unat_ucast_10_32 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word32) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma bool_mask [simp]:
  fixes x :: word32
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word32_bounds:
  "- (2 ^ (size (x :: word32) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (x :: word32) - 1)) - 1) = (2147483647 :: int)"
  "- (2 ^ (size (y :: 32 signed word) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (y :: 32 signed word) - 1)) - 1) = (2147483647 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::32 word) \<ge> -2147483648"
  by (metis sint_ge word32_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word32'
    = signed_arith_ineq_checks_to_eq[where 'a=32]
      signed_arith_ineq_checks_to_eq[where 'a="32 signed"]

lemmas signed_arith_ineq_checks_to_eq_word32
    = signed_arith_ineq_checks_to_eq_word32' [unfolded word32_bounds]

lemmas signed_mult_eq_checks32_to_64'
    = signed_mult_eq_checks_double_size[where 'a=32 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="32 signed" and 'b=64]

lemmas signed_mult_eq_checks32_to_64 = signed_mult_eq_checks32_to_64'[simplified]

lemmas sdiv_word32_max' = sdiv_word_max [where 'a=32] sdiv_word_max [where 'a="32 signed"]
lemmas sdiv_word32_max = sdiv_word32_max'[simplified word_size, simplified]

lemmas sdiv_word32_min' = sdiv_word_min [where 'a=32] sdiv_word_min [where 'a="32 signed"]
lemmas sdiv_word32_min = sdiv_word32_min' [simplified word_size, simplified]

lemmas sint32_of_int_eq' = sint_of_int_eq [where 'a=32]
lemmas sint32_of_int_eq = sint32_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word32) :: sword32) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word8) :: sword8) = (of_nat x)"
  by (auto simp: ucast_of_nat is_down)

lemmas signed_shift_guard_simpler_32'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_32 = signed_shift_guard_simpler_32'[simplified]

lemma word32_31_less:
  "31 < len_of TYPE (32 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (32)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_32
    = signed_shift_guard_to_word[OF word32_31_less(1-2)]
    signed_shift_guard_to_word[OF word32_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "32 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 32 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word32) >> 1 = 0 \<Longrightarrow> x < 2"
  by word_bitwise clarsimp

lemma has_zero_byte:
  "~~ (((((v::word32) && 0x7f7f7f7f) + 0x7f7f7f7f) || v) || 0x7f7f7f7f) \<noteq> 0
    \<Longrightarrow> v && 0xff000000 = 0 \<or> v && 0xff0000 = 0 \<or> v && 0xff00 = 0 \<or> v && 0xff = 0"
  apply clarsimp
  apply word_bitwise
  by metis

lemma mask_step_down_32:
  "(b::32word) && 0x1 = (1::32word) \<Longrightarrow> (\<exists>x. x < 32 \<and> mask x = b >> 1) \<Longrightarrow> (\<exists>x. mask x = b)"
  apply clarsimp
  apply (rule_tac x="x + 1" in exI)
  apply (subgoal_tac "x \<le> 31")
   apply (erule le_step_down_nat, clarsimp simp:mask_def, word_bitwise, clarsimp+)+
   apply (clarsimp simp:mask_def, word_bitwise, clarsimp)
  apply clarsimp
  done

lemma unat_of_int_32:
  "\<lbrakk>i \<ge> 0; i \<le>2 ^ 31\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword32)) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (simp add: word_of_int uint_word_of_int)
  done

lemmas word_ctz_not_minus_1_32 = word_ctz_not_minus_1[where 'a=32, simplified]

(* Helper for packing then unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64[simp]:
  "(((ucast ((ucast (x::64 word))::32 word))::64 word) || (((ucast ((ucast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_assemble_id)

(* Another variant of packing and unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64'[simp]:
  "(((ucast ((scast (x::64 word))::32 word))::64 word) || (((ucast ((scast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_scast_assemble_id)

(* Specialisations of down_cast_same for adding to local simpsets. *)
lemma cast_down_u64: "(scast::64 word \<Rightarrow> 32 word) = (ucast::64 word \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

lemma cast_down_s64: "(scast::64 sword \<Rightarrow> 32 word) = (ucast::64 sword \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

end


section {* Domain Quantales *}

theory Domain_Quantale
  imports "$AFP/KAD/Modal_Kleene_Algebra"
begin

subsection {* Notation *}

notation
  times (infixl "\<cdot>" 70)

notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf (infixl "\<sqinter>" 65) and
  sup (infixl "\<squnion>" 65) and
  Inf ("\<Sqinter>_" [900] 900) and
  Sup ("\<Squnion>_" [900] 900)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

subsection {* Definitions of Lattice-Ordered Monoids with Domain*}

class bd_lattice_ordered_monoid = bounded_lattice + distrib_lattice + monoid_mult +
  assumes left_distrib: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  and right_distrib: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  and bot_annil [simp]: "\<bottom> \<cdot> x = \<bottom>"
  and bot_annir [simp]: "x \<cdot> \<bottom> = \<bottom>"
begin

sublocale semiring_one_zero "op \<squnion>" "op \<cdot>" "1" "bot"
  by (standard, auto simp: sup.assoc sup.commute sup_left_commute left_distrib right_distrib sup_absorb1)

sublocale dioid_one_zero "op \<squnion>" "op \<cdot>" "1" bot "op \<le>" "op <"
  by (standard, simp add: local.le_iff_sup, auto)

end

no_notation ads_d ("d")
  and ars_r ("r")
  and antirange_op ("ar _" [999] 1000)

class domain_bdlo_monoid = bd_lattice_ordered_monoid +
  assumes rdv: "(z \<sqinter> x \<cdot> top) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> top"

begin

definition "d x = 1 \<sqinter> x \<cdot> \<top>"

sublocale ds: domain_semiring "op \<squnion>" "op \<cdot>" "1" "\<bottom>" "d" "op \<le>" "op <"
proof standard
  fix x y
  show "x \<squnion> d x \<cdot> x = d x \<cdot> x"
    by (metis d_def local.inf_sup_absorb local.left_distrib local.mult_1_left local.mult_1_right local.rdv local.sup.absorb_iff1 local.sup.idem local.sup.left_commute top_greatest)
  show "d (x \<cdot> d y) = d (x \<cdot> y)"
    by (simp add: d_def local.inf_absorb2 local.rdv  mult_assoc)
  show "d x \<squnion> 1 = 1"
    by (simp add: d_def local.sup.commute)
  show "d bot = bot"
    by (simp add: d_def local.inf.absorb1 local.inf.commute)
  show "d (x \<squnion> y) = d x \<squnion> d y"
    by (simp add: d_def local.inf_sup_distrib1)
qed

end

class boolean_monoid = boolean_algebra + monoid_mult +
assumes left_distrib': "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
and right_distrib': "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
and bot_annil' [simp]: "\<bottom> \<cdot> x = \<bottom>"
and bot_annir' [simp]: "x \<cdot> \<bottom> = \<bottom>"

begin

subclass bd_lattice_ordered_monoid
  by (standard, simp_all add: local.left_distrib' local.right_distrib')

lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)

end

class domain_boolean_monoid = boolean_monoid +
  assumes rdv': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"

begin

sublocale dblo: domain_bdlo_monoid "1" "op \<cdot>" "op \<sqinter>" "op \<le>" "op <" "op \<squnion>" "\<bottom>" "\<top>"
  by (standard, simp add: local.rdv')

definition "a x = 1 \<sqinter> -(dblo.d x)"

lemma a_d_iff: "a x = 1 \<sqinter> -(x \<cdot> \<top>)"
  by (auto simp: a_def dblo.d_def inf_sup_distrib1)

lemma topr: "-(x \<cdot> \<top>) \<cdot> \<top> = -(x \<cdot> \<top>)"
proof (rule antisym)
  show "-(x \<cdot> \<top>) \<le> -(x \<cdot> \<top>) \<cdot> \<top>"
    by (metis local.mult_isol_var local.mult_oner local.order_refl local.top_greatest)
  have "-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>) = \<bottom>"
    by simp
  hence "(-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>)) \<cdot> \<top>  = \<bottom>"
    by simp
  hence "-(x \<cdot> \<top>) \<cdot> \<top> \<sqinter> (x \<cdot> \<top>)  = \<bottom>"
    by (metis local.rdv')
  thus "-(x \<cdot> \<top>) \<cdot> \<top> \<le> -(x \<cdot> \<top>)"
    by (simp add: local.inf_bot_iff_le)
qed

lemma dd_a: "dblo.d x = a (a x)"
  by (metis a_d_iff dblo.d_def local.double_compl local.inf_top.left_neutral local.mult_1_left local.rdv' topr)

lemma ad_a [simp]: "a (dblo.d x) = a x"
  by (simp add: a_def)

lemma da_a [simp]: "dblo.d (a x) = a x"
  using ad_a dd_a by auto

lemma a1 [simp]: "a x \<cdot> x = \<bottom>"
proof -
  have "a x \<cdot> x \<cdot> \<top> = \<bottom>"
    by (metis a_d_iff local.inf_compl_bot local.mult_1_left local.rdv' topr)
  then show ?thesis
    by (metis (no_types) dblo.d_def dblo.ds.domain_very_strict local.inf_bot_right)
qed

lemma a2 [simp]: "a (x \<cdot> y) \<squnion> a (x \<cdot> a (a y)) = a (x \<cdot> a (a y))"
  by (metis a_def dblo.ds.dsr2 dd_a local.sup.idem)

lemma a3 [simp]: "a (a x) \<squnion> a x = 1"
  by (metis a_def da_a local.inf.commute local.sup.commute local.sup_compl_top local.sup_inf_absorb local.sup_inf_distrib1)

subclass domain_bdlo_monoid ..

sublocale ad: antidomain_semiring a "op \<squnion>" "op \<cdot>" "1" "\<bottom>" "op \<le>" "op <"
  rewrites ad_eq: "ad.ads_d x = d x"
proof -
  show "class.antidomain_semiring a op \<squnion> op \<cdot> 1 \<bottom> op \<le> op <"
    by (standard, simp_all)
  then interpret ad: antidomain_semiring a "op \<squnion>" "op \<cdot>" "1" "\<bottom>" "op \<le>" "op <" .
  show "ad.ads_d x = d x"
    by (simp add: ad.ads_d_def dd_a)
qed

end

class range_boolean_monoid = boolean_monoid +
  assumes ldv': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"
begin

definition "r x = 1 \<sqinter> \<top> \<cdot> x"

definition "ar x = 1 \<sqinter> -(r x)"

lemma ar_r_iff: "ar x = 1 \<sqinter> -(\<top> \<cdot> x)"
  by (simp add: ar_def local.inf_sup_distrib1 r_def)

lemma topl: "\<top>\<cdot>(-(\<top> \<cdot> x)) = -(\<top> \<cdot> x)"
proof (rule antisym)
  show "\<top> \<cdot> - (\<top> \<cdot> x) \<le> - (\<top> \<cdot> x)"
    by (metis local.bot_annir' local.compl_inf_bot local.inf_bot_iff_le local.ldv')
  show "- (\<top> \<cdot> x) \<le> \<top> \<cdot> - (\<top> \<cdot> x)"
    by (metis local.inf_le2 local.inf_top.right_neutral local.mult_1_left local.mult_isor)
qed

lemma r_ar: "r x = ar (ar x)"
  by (metis ar_r_iff local.double_compl local.inf.commute local.inf_top.right_neutral local.ldv' local.mult_1_right r_def topl)

lemma ar_ar [simp]: "ar (r x) = ar x"
  by (simp add: ar_def local.ldv' r_def)

lemma rar_ar [simp]: "r (ar x) = ar x"
  using r_ar ar_ar by auto

lemma ar1 [simp]: "x \<cdot> ar x = \<bottom>"
proof -
  have "\<top> \<cdot> x \<cdot> ar x = \<bottom>"
    by (metis ar_r_iff local.inf_compl_bot local.ldv' local.mult_oner topl)
  then show ?thesis
    by (metis ar_r_iff local.double_compl local.inf_bot_iff_le local.inf_le2 local.inf_top.right_neutral local.ldv' local.mult_1_left local.mult_isor local.mult_oner topl)
qed

lemma ars: "r (r x \<cdot> y) = r (x \<cdot> y)"
  by (metis local.inf.commute local.inf_top.right_neutral local.ldv' local.mult_oner mult_assoc r_def)

lemma ar2 [simp]: "ar (x \<cdot> y) \<squnion> ar (ar (ar x) \<cdot> y) = ar (ar (ar x) \<cdot> y)"
  by (metis ar_def ars r_ar local.sup.idem)

lemma ar3 [simp]: "ar (ar x) \<squnion> ar x = 1 "
  by (metis ar_def rar_ar local.inf.commute local.sup.commute local.sup_compl_top local.sup_inf_absorb local.sup_inf_distrib1)

sublocale ar: antirange_semiring "op \<squnion>" "op \<cdot>" "1" "\<bottom>" ar "op \<le>" "op <"
  rewrites ar_eq: "ar.ars_r x = r x"
proof -
  show "class.antirange_semiring op \<squnion> op \<cdot> 1 \<bottom> ar op \<le> op <"
    by (standard, simp_all)
  then interpret ar: antirange_semiring "op \<squnion>" "op \<cdot>" "1" "\<bottom>" ar "op \<le>" "op <" .
  show "ar.ars_r x = r x"
    by (simp add: ar.ars_r_def r_ar)
qed

end

subsection {* Definition of Quantale *}

class quantale = complete_lattice + monoid_mult +
  assumes Sup_distr: "\<Squnion> X \<cdot> y = \<Squnion> {z. \<exists>x \<in> X. z = x \<cdot> y}"
  and Sup_distl: "x \<cdot> \<Squnion> Y = \<Squnion> {z. \<exists>y \<in> Y. z = x \<cdot> y}"

begin

lemma bot_annil'' [simp]: "\<bottom> \<cdot> x = \<bottom>"
  using Sup_distr[where X="{}"] by auto

lemma bot_annirr'' [simp]: "x \<cdot> \<bottom> = \<bottom>"
  using Sup_distl[where Y="{}"] by auto

lemma sup_distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  using Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma sup_distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)

sublocale semiring_one_zero "op \<squnion>" "op \<cdot>" "1" "\<bottom>"
  by (standard, auto simp: sup.assoc sup.commute sup_left_commute sup_distl sup_distr)

sublocale dioid_one_zero "op \<squnion>" "op \<cdot>" "1" "\<bottom>" "op \<le>" "op <"
  by (standard, simp add: local.le_iff_sup, auto)

lemma Sup_sup_pred: "x \<squnion> \<Squnion>{y. P y} = \<Squnion>{y. y = x \<or> P y}"
  apply (rule antisym)
  apply (simp add: Collect_mono local.Sup_subset_mono local.Sup_upper)
  using local.Sup_least local.Sup_upper local.le_supI2 by fastforce

definition star :: "'a \<Rightarrow> 'a" where
  "star x = (\<Squnion>i. x ^ i)"

lemma star_def_var1: "star x = \<Squnion>{y. \<exists>i. y = x ^ i}"
  by (simp add: star_def full_SetCompr_eq)

lemma star_def_var2: "star x = \<Squnion>{x ^ i |i. True}"
  by (simp add: star_def full_SetCompr_eq)

lemma star_unfoldl' [simp]: "1 \<squnion> x \<cdot> (star x) = star x"
proof -
  have "1 \<squnion> x \<cdot> (star x) = x ^ 0 \<squnion> x \<cdot> \<Squnion>{y. \<exists>i. y = x ^ i}"
    by (simp add: star_def_var1)
  also have "... = x ^ 0 \<squnion> \<Squnion>{y. \<exists>i. y = x ^ (i + 1)}"
    by (simp add: Sup_distl, metis)
  also have "... = \<Squnion>{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
    using Sup_sup_pred by auto
  also have "... = \<Squnion>{y. \<exists>i. y = x ^ i}"
    by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
  finally show ?thesis
    by (simp add: star_def_var1)
qed

lemma star_unfoldr' [simp]: "1 \<squnion> (star x) \<cdot> x = star x"
proof -
  have "1 \<squnion> (star x) \<cdot> x = x ^ 0 \<squnion> \<Squnion>{y. \<exists>i. y = x ^ i} \<cdot> x"
    by (simp add: star_def_var1)
  also have "... = x ^ 0 \<squnion> \<Squnion>{y. \<exists>i. y = x ^ i \<cdot> x}"
    by (simp add: Sup_distr, metis)
  also have "... = x ^ 0 \<squnion> \<Squnion>{y. \<exists>i. y = x ^ (i + 1)}"
    using local.power_Suc2 by auto
   also have "... = \<Squnion>{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
    using Sup_sup_pred by auto
  also have "... = \<Squnion>{y. \<exists>i. y = x ^ i}"
    by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
  finally show ?thesis
    by (simp add: star_def_var1)
qed

lemma (in dioid_one_zero) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by auto
  case Suc thus ?case
    by (auto, metis mult.assoc mult_isol order_trans)
qed

lemma (in dioid_one_zero) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (x ^ n) \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by auto
  case Suc
  {
    fix n
    assume "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ n \<le> y"
      and "z + y \<cdot> x \<le> y"
    hence "z \<cdot> x ^ n \<le> y"
      by auto
    also have "z \<cdot> x ^ Suc n = z \<cdot> x \<cdot> x ^ n"
      by (metis mult.assoc power_Suc)
    moreover have "... = (z \<cdot> x ^ n) \<cdot> x"
      by (metis mult.assoc power_commutes)
    moreover have "... \<le> y \<cdot> x"
      by (metis calculation(1) mult_isor)
    moreover have "... \<le> y"
      using `z + y \<cdot> x \<le> y` by auto
    ultimately have "z \<cdot> x ^ Suc n \<le> y" by auto
  }
  thus ?case
    by (metis Suc)
qed

lemma star_inductl': "z \<squnion> x \<cdot> y \<le> y \<Longrightarrow> (star x) \<cdot> z \<le> y"
proof -
  assume "z \<squnion> x \<cdot> y \<le> y"
  hence "\<forall>i. x ^ i \<cdot> z \<le> y"
    by (simp add: local.power_inductl)
  hence "\<Squnion>{w. \<exists>i. w = x ^ i \<cdot> z} \<le> y"
    by (intro Sup_least, auto)
  hence "\<Squnion>{w. \<exists>i. w = x ^ i} \<cdot> z \<le> y"
    using local.Sup_distr local.Sup_le_iff by auto
  thus "(star x) \<cdot> z \<le> y"
    by (simp add: local.star_def_var1)
qed

lemma star_inductr': "z \<squnion> y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (star x) \<le> y"
proof -
  assume "z \<squnion> y \<cdot> x \<le> y"
  hence "\<forall>i. z \<cdot> x ^ i  \<le> y"
    by (simp add: local.power_inductr)
  hence "\<Squnion>{w. \<exists>i. w = z \<cdot> x ^ i} \<le> y"
    by (intro Sup_least, auto)
  hence "z \<cdot> \<Squnion>{w. \<exists>i. w = x ^ i} \<le> y"
    using local.Sup_distl local.Sup_le_iff by auto
  thus "z \<cdot> (star x) \<le> y"
    by (simp add: local.star_def_var1)
qed

sublocale ka: kleene_algebra "op \<squnion>" "op \<cdot>" "1" "\<bottom>" "op \<le>" "op <" star
  by standard (simp_all add: star_inductl' local.star_inductr')

end

class distributive_quantale = quantale + distrib_lattice (* this is probably not true as we need infinite distributivity laws ! *)

begin

subclass bd_lattice_ordered_monoid
  by (standard, simp_all add: local.distrib_left)

lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
nitpick
oops

end

subsection {* Domain Quantales *}

class domain_quantale = distributive_quantale +
  assumes rdv'': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"

begin

subclass domain_bdlo_monoid
  by (standard, simp add: local.rdv'')

end

class range_quantale = distributive_quantale +
  assumes ldv'': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"

class boolean_quantale = quantale + complete_boolean_algebra

begin

subclass boolean_monoid
  by (standard, simp_all add: local.sup_distl)

lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
nitpick
oops

lemma "(1 \<sqinter> -(x \<cdot> \<top>)) \<cdot> x = \<bottom>"
nitpick
oops

end

class domain_boolean_quantale = domain_quantale + boolean_quantale

begin

subclass domain_boolean_monoid
  by (standard, simp add: local.rdv'')

lemma fbox_eq: "ad.fbox x q = Sup{d(p)| p. d(p)*x \<le> x*d(q)}"
  apply (rule Sup_eqI[symmetric])
  apply clarsimp
  using local.ad.fbox_demodalisation3 local.ad.fbox_simp apply auto[1]
  apply clarsimp
  by (metis local.ad.fbox_def local.ad.fbox_demodalisation3 local.ad.fbox_simp local.da_a local.eq_refl)

lemma fdia_eq: "ad.fdia x p = Inf{d(q)|q. x*d(p) \<le> d(q)*x}"
  apply (rule Inf_eqI[symmetric])
  apply clarsimp
  using local.ds.fdemodalisation2 apply auto[1]
  apply clarsimp
  by (metis local.ad.fd_eq_fdia local.ad.fdia_def local.da_a local.double_compl local.ds.fdemodalisation2 local.inf_bot_iff_le local.inf_compl_bot)

(* proof of axioms for RKAT -- H p x q \<longleftrightarrow> p \<le> fbox x q *)
definition R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "R p q \<equiv> Sup{x. d(p)*x \<le> x*d(q)}"

lemma "x \<le> R p q \<Longrightarrow> d(p) \<le> ad.fbox x (d q)"
proof (simp add: R_def ad.kat_1_equiv ad.kat_2_equiv)
  assume "x \<le> \<Squnion>{x. d p \<cdot> x \<cdot> a q = \<bottom>}"
  hence "d p \<cdot> x \<cdot> a q \<le> d p \<cdot> \<Squnion>{x. d p \<cdot> x \<cdot> a q = \<bottom>} \<cdot> a q "
    using local.mult_double_iso by blast
  also have "... = \<Squnion>{d p \<cdot> x \<cdot> a q | x. d p \<cdot> x \<cdot> a q = \<bottom>}"
    apply (subst Sup_distl)
    apply (subst Sup_distr)
    apply clarsimp
    apply metis
  done
  also have "... = \<bottom>"
    by (auto simp: Sup_eqI)
  finally show ?thesis
    using ad.fbox_demodalisation3 local.ad.kat_3 local.ad.kat_4 local.le_bot by blast
qed

lemma "d(p) \<le> ad.fbox x (d q) \<Longrightarrow> x \<le> R p q"
  apply (simp add: R_def)
  apply (rule Sup_upper)
  apply simp
  using local.ad.fbox_demodalisation3 local.ad.fbox_simp apply auto[1]
done

end

interpretation rel_dbq: domain_boolean_quantale Inter Union "op \<inter>" "op \<subseteq>" "op \<subset>" "op \<union>" "{}" UNIV minus uminus Id "op O"
  apply (standard, simp_all add: O_assoc)
  by blast +

class range_boolean_quantale = range_quantale + boolean_quantale

begin

subclass range_boolean_monoid
  by (standard, simp add: local.ldv'')

lemma fbox_eq: "ar.bbox x (r q) = Sup{r(p)| p. x*r(p) \<le> r(q)*x}"
  apply (rule Sup_eqI[symmetric])
  apply clarsimp
  using ar.ardual.fbox_demodalisation3 local.ar.ardual.fbox_simp apply auto[1]
  apply clarsimp
  by (metis local.ar.ardual.fbox_def local.ar.ardual.fbox_demodalisation3 local.eq_refl local.rar_ar)

lemma fdia_eq: "ar.bdia x (r p) = Inf{r(q)|q. r(p)*x \<le> x*r(q)}"
  apply (rule Inf_eqI[symmetric])
  apply clarsimp
  using ar.ars_r_def local.ar.ardual.fdemodalisation22 local.ar.ardual.kat_3_equiv_opp local.ar.ardual.kat_4_equiv_opp apply auto[1]
  apply clarsimp
  using ar.bdia_def local.ar.ardual.ds.fdemodalisation2 local.r_ar by fastforce

end

class modal_boolean_quantale = domain_boolean_quantale + range_boolean_quantale +
  assumes domrange' [simp]: "d (r x) = r x"
  and rangedom' [simp]: "r (d x) = d x"
begin

sublocale mka: modal_kleene_algebra "op \<squnion>" "op \<cdot>" 1 \<bottom> "op \<le>" "op <" star a ar
  by standard (simp_all add: ar_eq ad_eq)

end

no_notation fbox ("( |_] _)" [61,81] 82)
  and antidomain_semiringl_class.fbox ("( |_] _)" [61,81] 82)
notation ad.fbox ("( |_] _)" [61,81] 82)

lemma recursion: "mono (f :: 'a \<Rightarrow> 'a :: domain_boolean_quantale) \<Longrightarrow>
  (\<And>x. d p \<le> |x] d q \<Longrightarrow> d p \<le> |f x] d q) \<Longrightarrow>  d p \<le> |lfp f] d q"
  apply (erule lfp_ordinal_induct [where f=f], simp)
  apply (auto simp: ad.addual.ardual.fbox_demodalisation3 Sup_distr Sup_distl intro: Sup_mono)
done

end


(*
    Title:      Code_Rational.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Code Generation for rational numbers in Haskell\<close>

theory Code_Rational
imports

  (*VERY IMPORTANT! When code is exported, the order of the imports is very important.
  In this case, I have to import here the following three theories.
  They allow the computation of the Gauss-Jordan algorithm in Haskell*)

  Code_Real_Approx_By_Float_Haskell
  Code_Generation_IArrays

  (*These theories are necessary for the serialisation:*)
  HOL.Rat
  "HOL-Library.Code_Target_Int"
begin

subsection\<open>Serializations\<close>

text\<open>The following \<open>code_printing code_module\<close> module is the usual way to import libraries
in Haskell. In this case, we rebind some functions from Data.Ratio.
See @{url "https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2013-June/msg00007.html"}\<close>

code_printing code_module Rational \<rightharpoonup> (Haskell)
 \<open>module Rational(fract, numerator, denominator) where

  import qualified Data.Ratio
  import Data.Ratio(numerator, denominator)

  fract (a, b) = a Data.Ratio.% b\<close>

context
includes integer.lifting
begin
lift_definition Frct_integer :: "integer \<times> integer => rat"
  is "Frct :: int \<times> int => rat" .
end

consts Foo::rat
code_datatype Foo

context
includes integer.lifting
begin

lemma [code]:
"Rat.of_int a = Frct_integer (of_int a, 1)"
  by transfer (auto simp: Fract_of_int_eq Rat.of_int_def)

definition numerator :: "rat => int"
where "numerator x = fst (quotient_of x)"

definition denominator :: "rat => int"
where "denominator x = snd (quotient_of x)"

lift_definition numerator_integer :: "rat => integer"
  is "numerator" .

lift_definition denominator_integer :: "rat => integer"
  is "denominator" .

lemma [code]:
"inverse x = Frct_integer (denominator_integer x, numerator_integer x)"
  apply (cases x)
  apply transfer
  apply (auto simp: inverse_eq_divide numerator_def denominator_def quotient_of_Fract One_rat_def)
  done

lemma quotient_of_num_den: "quotient_of x = ((numerator x), (denominator x))"
unfolding numerator_def denominator_def
by simp

lemma [code]: "quotient_of x = (int_of_integer (numerator_integer x), int_of_integer(denominator_integer x))"
by (transfer, simp add: quotient_of_num_den)
end

code_printing
  type_constructor rat \<rightharpoonup> (Haskell) "Prelude.Rational"
  | class_instance rat :: "HOL.equal" => (Haskell) -
  | constant "0 :: rat" \<rightharpoonup> (Haskell) "(Prelude.toRational (0::Integer))"
  | constant "1 :: rat" \<rightharpoonup> (Haskell) "(Prelude.toRational (1::Integer))"
  | constant "Frct_integer" \<rightharpoonup> (Haskell) "Rational.fract (_)"
  | constant "numerator_integer" \<rightharpoonup> (Haskell) "Rational.numerator (_)"
  | constant "denominator_integer" \<rightharpoonup> (Haskell) "Rational.denominator (_)"
  | constant "HOL.equal :: rat \<Rightarrow> rat \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) "(_) == (_)"
  |  constant "(<) :: rat => rat => bool" \<rightharpoonup>
    (Haskell) "_ < _"
  |  constant "(\<le>) :: rat => rat => bool" \<rightharpoonup>
    (Haskell) "_ <= _"
  | constant "(+) :: rat \<Rightarrow> rat \<Rightarrow> rat" \<rightharpoonup>
    (Haskell) "(_) + (_)"
  | constant "(-) :: rat \<Rightarrow> rat \<Rightarrow> rat" \<rightharpoonup>
    (Haskell) "(_) - (_)"
  | constant "(*) :: rat \<Rightarrow> rat \<Rightarrow> rat" \<rightharpoonup>
    (Haskell) "(_) * (_)"
  | constant "(/) :: rat \<Rightarrow> rat \<Rightarrow> rat" \<rightharpoonup>
    (Haskell) " (_) '/ (_)"
 | constant "uminus :: rat => rat" \<rightharpoonup>
    (Haskell) "Prelude.negate"

(*
definition "test1 = (3::rat)"
definition "test2 = (3/9::rat)"
definition "test3 = (3/8 + 8/7::rat)"
definition "test4 = (3/8 - 8/7::rat)"
definition "test5 = (3/8 * 8/7::rat)"
definition "test6 = (3/8 / 8/7::rat)"
definition "test7 = (34 < (53 :: rat))"
definition "test8 = (34 <= (53 :: rat))"
definition "test9 = (inverse (8/5::rat))"
definition "test10 = quotient_of (8/3::rat)"
export_code
  test1
  test2
  test3
  test4
  test5
  test6
  test7
  test8
  test9
  test10
  in Haskell
  module_name "Rational_Haskell"
  file "haskell"
*)
end


section\<open>Events\<close>

theory Event imports Adversary begin

record event =
  Sender::agent
  Receiver::agent
  Message::msg

subsection\<open>Function knows\<close>

fun knows :: "event list \<Rightarrow> msg set"
where knows_Nil:   "knows [] = initState"
    | knows_Cons:  "knows (ev # evs) = insert (Message ev) (knows evs)"

(*
abbreviation "trace1 \<equiv> [Says (Friend 1) (Friend 2) (Key 0), Gets (Friend 1) (Key 1), Notes (Friend 2) (Key 2)]"
value "knows Spy trace1"
value "knows (Friend 1) trace1"
abbreviation "trace2 \<equiv> [Says (Friend 1) (Friend 2) (Key 0), Gets (Friend 1) (Key 1), Notes (Friend 2) (Key 2)]"
*)

lemmas parts_insert_knows_A = parts_insert [of _ "knows evs"] for A evs

lemma knows_Spy_subset_knows_Spy_Says:
     "knows evs \<subseteq> knows (ev # evs)"
by (simp add: subset_insertI)

lemmas analz_mono_contra =
       knows_Spy_subset_knows_Spy_Says [THEN analz_mono, THEN contra_subsetD]

lemma Says_imp_knows_Spy [rule_format]:
     "ev \<in> set evs \<longrightarrow> Message ev \<in> knows evs"
proof (induction rule: list.induct)
  case Nil
  then show ?case by simp
next
  case (Cons x1 x2)
  then show ?case by simp
qed

lemmas knows_Spy_partsEs =
     Says_imp_knows_Spy [THEN parts.Inj, elim_format]
     parts.Body [elim_format]

lemmas Says_imp_analz_Spy = Says_imp_knows_Spy [THEN analz.Inj]

lemmas spies_partsEs = knows_Spy_partsEs
lemmas Says_imp_spies = Says_imp_knows_Spy
lemmas parts_insert_spies = parts_insert_knows_A [of _]

lemma knows_Says[simp]: "knows (\<lparr>Sender=A, Receiver=B, Message=X\<rparr> # evs) = insert X (knows evs)"
by simp

lemma Says_imp_knows [rule_format]: "\<lparr>Sender=A, Receiver=B, Message=X\<rparr> \<in> set evs \<longrightarrow> X \<in> knows evs"
proof (induction rule: list.induct)
  case Nil
  then show ?case by simp
next
  case (Cons x1 x2)
  show ?case
  proof
    assume "\<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set (x1 # x2)"
    hence "\<lparr>Sender = A, Receiver = B, Message = X\<rparr> = x1 \<or> \<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set x2" by simp
    thus "X \<in> knows (x1 # x2)"
    proof
      assume "\<lparr>Sender = A, Receiver = B, Message = X\<rparr> = x1"
      thus "X \<in> knows (x1 # x2)" by auto
    next
      assume "\<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set x2"
      with Cons.IH have "X \<in> knows x2" by simp
      thus "X \<in> knows (x1 # x2)" by auto
    qed
  qed
qed

lemma knows_Spy_imp_Says_Notes_initState [rule_format]:
     "[| X \<in> knows evs |] ==> \<exists>A B.
  \<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set evs \<or> X \<in> initState"
proof (erule rev_mp)
  show "X \<in> knows  evs \<longrightarrow> (\<exists>A B. \<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set evs \<or> X \<in> initState)"
  proof (induction rule: list.induct)
    case Nil
    then show ?case by simp
  next
    case (Cons x1 x2)
    show ?case
    proof
      assume "X \<in> knows (x1 # x2)"
      hence "X=Message x1 \<or> X\<in>(knows x2)" by simp
      thus "\<exists>A B. \<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set (x1 # x2) \<or> X \<in> initState"
      proof
        assume "X=Message x1"
        thus "\<exists>A B. \<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set (x1 # x2) \<or> X \<in> initState"
          by (metis list.set_intros(1) old.unit.exhaust surjective)
      next
        assume "X\<in>(knows x2)"
        thus "\<exists>A B. \<lparr>Sender = A, Receiver = B, Message = X\<rparr> \<in> set (x1 # x2) \<or> X \<in> initState"
          using Cons.IH by auto
      qed
    qed
  qed
qed

lemmas analz_impI = impI [where P = "Y \<notin> analz (knows evs)"] for Y evs

lemmas syan_impI = impI [where P = "Y \<notin> synth (analz (knows evs))"] for Y evs

lemma initState_subset_knows: "initState \<subseteq> knows evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_Spy_subset_knows_Spy_Says [THEN subsetD])
done

lemma spies_pubK[iff]: "Key (pubK A) \<in> knows evs"
  by (induct evs) (simp_all add: imageI)

lemmas [iff] = spies_pubK [THEN analz.Inj]

subsection\<open>Function used\<close>

fun used :: "event list \<Rightarrow> msg set" where
  used_Nil:   "used []         = parts initState" |
  used_Cons:  "used (ev # evs) = (parts {Message ev } \<union> used evs)"

lemma Nonce_notin_used_empty[simp]: "Nonce N \<notin> used []" by simp

lemma Says_imp_used [rule_format]: "ev \<in> set evs \<longrightarrow> Message ev \<in> used evs"
proof (induction rule: list.induct)
  case Nil
  then show ?case by simp
next
  case (Cons x1 x2)
  show ?case
  proof
    assume "ev \<in> set (x1 # x2)"
    hence "ev = x1 \<or> ev \<in> set x2" by simp
    thus "Message ev \<in> used (x1 # x2)"
    proof
      assume "ev = x1"
      thus "Message ev \<in> used (x1 # x2)" by auto
    next
      assume "ev \<in> set x2"
      with Cons.IH have "Message ev \<in> used x2" by simp
      thus "Message ev \<in> used (x1 # x2)" by auto
    qed
  qed
qed

lemma parts_knows_Spy_subset_used: "parts (knows evs) \<subseteq> used evs"
proof (induction rule: list.induct)
  case Nil
  then show ?case
  proof
    fix x assume "x \<in> parts (knows[])"
    hence "x \<in> parts initState" by simp
    moreover have "used [] = parts initState" by simp
    ultimately show "x\<in>used []" by blast
  qed
next
  case (Cons x1 x2)
  thus "parts (knows (x1 # x2)) \<subseteq> used (x1 # x2)"
    by (metis (no_types, lifting) Event.knows_Cons Event.used_Cons Un_assoc Un_upper1 parts_insert subset_Un_eq)
qed

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp))
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

end


section \<open> General Minimal Mereology \<close>

(*<*)
theory GMM
 imports GM MM
begin
(*>*)

text \<open> The theory of \emph{general minimal mereology} adds general mereology to minimal mereology.\footnote{
See @{cite "casati_parts_1999"} p. 46.} \<close>

locale GMM = GM + MM
begin

text \<open> It is natural to assume that just as closed minimal mereology and closed extensional mereology
are the same theory, so are general minimal mereology and general extensional mereology.\footnote{For
this mistake see @{cite "simons_parts:_1987"} p. 37 and @{cite "casati_parts_1999"} p. 46. The mistake
is corrected in @{cite "pontow_note_2004"} and @{cite "hovda_what_2009"}. For discussion of the significance
of this issue see, for example, @{cite "varzi_universalism_2009"} and @{cite "cotnoir_does_2016"}.}
But this is not the case, since the proof of strong supplementation in closed minimal mereology
required the product closure axiom. However, in general minimal mereology, the fusion axiom does not
entail the product closure axiom. So neither product closure nor strong supplementation are theorems. \<close>

lemma product_closure:
  "O x y \<Longrightarrow> (\<exists> z. \<forall> v. P v z \<longleftrightarrow> P v x \<and> P v y)"
  nitpick [expect = genuine] oops

lemma strong_supplementation: "\<not> P x y \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"
  nitpick [expect = genuine] oops

end

(*<*) end (*>*)


(*
 * Copyright 2017, Data61, CSIRO
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

(*
 Unified Correctness reasoning in Separation Logic. Defines a
 concrete model of type (heap x bool) as an early extension
 of SL to deal with failure.
*)

theory Unified_Correctness
imports
  Extended_Separation_Algebra
  Hoare_Sep_Tactics
  Det_Monad
begin

type_synonym ('a, 'b) heap = "'a \<Rightarrow> 'b option"
type_synonym ('a, 'b) machine = "('a, 'b) heap \<times> bool"

abbreviation "heap ::  ('a, 'b) machine \<Rightarrow> ('a, 'b) heap \<equiv> fst"
abbreviation "nf ::  ('a, 'b) machine \<Rightarrow> bool \<equiv> snd"

instantiation "prod" :: (cancellative_sep_algebra, cancellative_sep_algebra) cancellative_sep_algebra
begin
instance
  apply (intro_classes; clarsimp simp: sep_disj_prod_def plus_prod_def zero_prod_def)
  apply (simp add: sep_disj_positive)
  by (simp add: sep_add_cancel)
end

instantiation "bool" :: cancellative_sep_algebra
begin
instance
  by (intro_classes) (auto simp: zero_bool_def plus_bool_def sep_disj_bool_def)
end

definition
  maps_to:: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) machine \<Rightarrow> bool" ("_ \<mapsto>u _" [56,51] 56)
where
  "x \<mapsto>u y \<equiv> \<lambda>h. heap h = [x \<mapsto> y] \<and> nf h "

definition
  maps_to_ex :: "'a \<Rightarrow>  ('a, 'b) machine \<Rightarrow> bool" ("_ \<mapsto>u -" [56] 56)
where
  "x \<mapsto>u - \<equiv> (\<lambda>s. \<exists>y. (x \<mapsto>u y) s)"

lemma maps_to_maps_to_ex [elim!]:
  "(p \<mapsto>u v) s \<Longrightarrow> (p \<mapsto>u -) s"
  by (auto simp: maps_to_ex_def)

lemma maps_to_ex_simp[simp]: "(p \<mapsto>u -) ([p \<mapsto> v], True)"
  by (clarsimp simp: maps_to_ex_def maps_to_def, fastforce)

type_synonym ('a, 'b) machine_pred = "('a, 'b) machine \<Rightarrow> bool"

definition
  sept :: "('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred" (infix "-&" 50)
where
  "sept P Q \<equiv> \<lambda>s. \<exists>h h'. P h \<and> Q h' \<and>
                         (if nf h \<and> nf s
                          then h + s = h' \<and> h ## s
                          else nf h' \<longrightarrow> (nf h  \<longrightarrow> h ## h') \<and> (nf s \<longrightarrow> s ## h'))"

definition
  sep_con :: "('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred" (infix "\<and>&" 50)
where
  "sep_con P Q \<equiv> \<lambda>s. \<exists>h h'. P h \<and>  Q h' \<and>
                            (if nf h \<and> nf h'
                             then h' + h = s \<and> h ## h'
                             else nf s \<longrightarrow> (nf h \<longrightarrow> h ## s) \<and> (nf h' \<longrightarrow>  s ## h'))"

lemma delete_pointer_empty: "(p \<mapsto>u v -& p \<mapsto>u v) s \<Longrightarrow> \<box> s"
  apply (clarsimp simp: sept_def  maps_to_def zero_prod_def sep_empty_def split: if_splits)
  apply (drule mp)
   apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def  sep_disj_option_def
                  split: if_splits option.splits)
   apply (metis)
  apply (clarsimp)
  by (metis sep_add_cancelD disjoint_zero_sym sep_add_commute sep_add_zero_sym
             sep_disj_commuteI zero_prod_def)

lemma sep_con_commute:
  "sep_con P Q s \<Longrightarrow> sep_con Q P s"
  apply (clarsimp simp: sep_con_def)
  apply (rename_tac x y a b)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="b" in exI)
  apply (intro conjI)
   apply (clarsimp)
  apply (rule_tac x="x" in exI)
  apply (rule_tac x="y" in exI)
  apply (intro conjI)
   apply (clarsimp, intro conjI impI)
  using sep_add_commute apply fastforce
   apply (clarsimp simp: sep_disj_commute sep_add_commute)+
  using sep_disj_commuteI by fastforce

definition
  sep_imp :: "('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred" (infix "\<longrightarrow>&" 50)
where
  "sep_imp P Q \<equiv> not (sept P (not Q))"

definition
  sep_snake :: "('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred \<Rightarrow> ('a, 'b) machine_pred"
where
  "sep_snake P Q \<equiv> not ( sep_con P (not Q))"

lemma sep_mp:
  "sep_con P (sep_imp P R) s \<Longrightarrow> R s"
  apply (clarsimp simp: sep_con_def sep_imp_def pred_neg_def sept_def )
  apply (rename_tac x y a b)
  apply (erule_tac x=x in allE, erule_tac x=y in allE, simp)
  apply (erule_tac x="fst s" in allE, erule_tac x="snd s" in allE, simp)
  apply (elim disjE; clarsimp?)
  apply (erule notE)
  by (metis prod.collapse sep_add_commute sep_disj_commute)

lemma sep_curry:
  "R s \<Longrightarrow> sep_imp P (sep_con P R) s"
  apply (clarsimp simp: sep_con_def sep_imp_def pred_neg_def sept_def)
  apply (intro conjI; clarsimp)
   apply (rename_tac x y a b)
   apply (erule_tac x=x in allE, erule_tac x=y in allE, simp)
   apply (erule_tac x="fst s" in allE, erule_tac x="snd s" in allE, simp)
   apply (clarsimp simp: sep_add_commute sep_disj_commute)+
   apply (metis (mono_tags, lifting) prod.collapse sep_disj_commuteI)
  apply (rename_tac x y a b)
  apply (rule_tac x=x in exI, rule_tac x=y in exI, clarsimp)
  apply (rule_tac x="fst s" in exI, rule_tac x="snd s" in exI, simp)
  apply (metis (mono_tags, lifting) prod.collapse sep_disj_commuteI)
  done

lemma sep_adjoint:
  "(\<forall>s. sep_con P (sep_imp P R) s \<longrightarrow> R s) \<longleftrightarrow>
   (\<forall>s. R s \<longrightarrow> sep_imp P (sep_con P R) s)"
  using Unified_Correctness.sep_curry Unified_Correctness.sep_mp by blast

lemma sep_con_collapse:
  "sep_con (p \<mapsto>u v) (R and nf) s \<Longrightarrow> (p \<mapsto>u v \<and>* R) s"
  apply (clarsimp simp: sep_con_def)
  apply (clarsimp simp: sep_conj_def maps_to_def pred_conj_def)
  by (metis sep_add_commute)

section "Examples"

definition
  "delete_ptr p = do {
    state_assert (\<lambda>s.  s p \<noteq> None);
    modify (\<lambda>s. (\<lambda>p'. if p = p' then None else s p'))
  }"

lemma delete_ptr_sp:
  "\<lbrace>R\<rbrace> delete_ptr p  \<lbrace>\<lambda>_. (sept (p \<mapsto>u -) R) \<rbrace>u"
  apply (clarsimp simp: delete_ptr_def)
  apply (rule hoare_seq_extU[rotated])
   apply (rule modify_wpU)
  apply (rule hoare_chainU[OF state_assert_wpU, rotated])
   apply (assumption)
  apply (clarsimp)
  apply (rename_tac h f)
  apply (case_tac "h p = 0"; clarsimp simp: zero_option_def sept_def)
   apply (rule_tac x=" [p \<mapsto> undefined]" in exI)
   apply (rule_tac x=" True" in exI)
   apply (intro conjI, fastforce)
   apply (rule_tac x=h in exI, rule_tac x=f in exI)
   apply (clarsimp)
   apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (case_tac "f"; clarsimp)
   apply (rename_tac v)
   apply (rule_tac x="[p \<mapsto> v]" in exI)
   apply (rule_tac x="True" in exI)
   apply (intro conjI, fastforce)
   apply (clarsimp)
   apply (rule_tac x=h in exI, rule_tac x=True in exI)
   apply (clarsimp, intro conjI)
    apply (clarsimp simp: plus_prod_def, intro conjI)
     apply (rule ext)
     apply (clarsimp simp: plus_fun_def plus_option_def)
    apply (clarsimp simp: plus_bool_def)
   apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (rename_tac v)
  apply (rule_tac x="[p \<mapsto> v]" in exI)
  apply (rule_tac x="True" in exI)
  apply (intro conjI, fastforce)
  by blast

definition "the_f v d = (if (v = None) then d else (the v))"

definition
  "get_ptr p = do {
     v <- gets (\<lambda>s. s p);
     assert (v \<noteq> None);
     return (the_f v (0))
   }"

lemma maps_to_simp [simp]:
  "(p \<mapsto>u y) h = (h = ([p \<mapsto> y], True))"
  by (metis (mono_tags, lifting) fst_conv maps_to_def prod_eqI snd_conv)

lemma get_ptr_sp:
  "\<lbrace>R\<rbrace> get_ptr p \<lbrace>\<lambda>rv. (p \<mapsto>u rv \<and>& (p \<mapsto>u rv -& R))\<rbrace>u"
  apply (clarsimp simp: get_ptr_def, (rule hoare_seq_extU[rotated])+)
    apply (rule return_wpU assert_wpU)+
  apply (rule hoare_chainU[OF gets_wpU, rotated])
   apply (assumption)
  apply (clarsimp simp: gets_def validU_def)
  apply (rename_tac h f)
  apply (case_tac "(\<exists>y. h p = Some y)"; clarsimp simp: the_f_def  zero_option_def)
   apply (clarsimp simp: sep_con_def)
   apply (rule_tac x="(\<lambda>ptr. if ptr = p then None else  h ptr)" in exI)
   apply (rule_tac x="f" in exI)
   apply (clarsimp, intro conjI impI)
      apply (clarsimp simp: sept_def)
      apply (rule_tac x=h in exI, rule_tac x=f in exI, clarsimp, intro conjI)
       apply (clarsimp simp: plus_prod_def plus_bool_def)
       apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
      apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
     apply (clarsimp simp: plus_prod_def plus_bool_def)
     apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
    apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
   apply (clarsimp simp: sept_def)
   apply (blast)
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x="(\<lambda>ptr. if ptr = p then None else h ptr)" in exI, rule_tac x= False in exI)
  apply (clarsimp)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x=h in exI)
  apply (rule_tac x=f in exI)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  done

definition
  "set_ptr p v = do {
     x <- gets (\<lambda>s. s p);
     assert (x \<noteq> None);
     modify (\<lambda>s. s(p \<mapsto> v))
   }"

lemma set_ptr_sp:
  "\<lbrace>R\<rbrace> set_ptr p v \<lbrace>\<lambda>_. (p \<mapsto>u v \<and>& (p \<mapsto>u - -& R))\<rbrace>u"
  apply (clarsimp simp: set_ptr_def, (rule hoare_seq_extU[rotated])+)
    apply (rule return_wpU assert_wpU modify_wpU)+
  apply (rule hoare_chainU[OF gets_wpU, rotated])
   apply (assumption)
  apply (clarsimp simp: gets_def validU_def)
  apply (rename_tac h f)
  apply (case_tac "(\<exists>y. h p = Some y)"; clarsimp simp: the_f_def maps_to_ex_def zero_option_def)
   apply (clarsimp simp: sep_con_def)
   apply (rule_tac x="(\<lambda>ptr. if ptr = p then None else  h ptr)" in exI)
   apply (rule_tac x="f" in exI)
   apply (clarsimp, intro conjI impI)
      apply (clarsimp simp: sept_def)
      apply (rename_tac v)
      apply (rule_tac x="[p \<mapsto> v]" in exI, intro conjI, fastforce)
      apply (rule_tac x=f in exI, clarsimp)
      apply (rule exI, rule exI, intro conjI, fastforce)
       apply (clarsimp simp: plus_prod_def plus_bool_def)
       apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
      apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
     apply (clarsimp simp: plus_prod_def plus_bool_def)
     apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
    apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
   apply (clarsimp simp: sept_def)
   apply (blast)
  apply (clarsimp simp: sep_con_def)
  apply (rule_tac x="(\<lambda>ptr. if ptr = p then Some v else h ptr)" in exI, rule_tac x= False in exI)
  apply (clarsimp)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x="[p \<mapsto> undefined]" in exI)
  apply (rule conjI)
   apply (fastforce)
  apply (rule_tac x=True in exI)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_fun_def sep_disj_option_def sep_disj_bool_def)
  apply (blast)
  done

definition "move_ptr p p' = get_ptr p \<bind> set_ptr p'"

method guess_spec = (rule exI)+, (intro conjI; (fastforce)?)

lemma sep_con_impl2:
  "(p \<and>& q) s \<Longrightarrow> (\<And>s. q s \<Longrightarrow> q' s) \<Longrightarrow> (p \<and>& q') s"
  apply (clarsimp simp: sep_con_def)
  apply (rule exI, rule exI, rule conjI, assumption)
  by (metis (full_types) snd_conv)

lemma sept_impl2:
  "(p -& q) s \<Longrightarrow> (\<And>s. q s \<Longrightarrow> q' s) \<Longrightarrow> (p -& q') s"
  apply (clarsimp simp: sept_def)
  apply (fastforce)
  done

lemma sept_success:
  "(p \<mapsto>u v -& (p \<mapsto>u v' \<and>* (R and nf))) s \<Longrightarrow> (R and (\<lambda>s. nf s \<and> v = v')) s"
  apply (clarsimp simp: sept_def sep_conj_def maps_to_ex_def split: if_splits)
  apply (erule disjE, clarsimp simp: pred_conj_def)
   apply (subgoal_tac "v = v'", clarsimp)
    apply (metis sep_add_cancelD sep_add_commute sep_disj_commuteI)
   apply (clarsimp simp: plus_prod_def)
   apply (drule fun_cong[where x=p], clarsimp simp: plus_fun_def plus_option_def split: option.splits)
   apply (clarsimp simp: sep_disj_fun_def sep_disj_prod_def sep_disj_option_def split: if_splits, fastforce)
  apply (clarsimp simp: pred_conj_def plus_prod_def)
  apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_prod_def
                        sep_disj_option_def plus_bool_def sep_disj_bool_def
                 split: if_splits)
  apply (fastforce)
  done

lemma sep_add_cancel_maps_toD: "[p \<mapsto> v] + x = [p \<mapsto> v'] + y \<Longrightarrow> [p \<mapsto> v] ## x \<Longrightarrow>
    [p \<mapsto> v'] ## y \<Longrightarrow> v = v'"
  apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def
         sep_disj_prod_def sep_disj_option_def plus_bool_def sep_disj_bool_def split: if_splits)
  by (drule fun_cong[where x=p], clarsimp)

lemma sept_success_ex:
  "(p \<mapsto>u - -& (p \<mapsto>u - \<and>* (R and nf))) s \<Longrightarrow> (R and nf) s"
  apply (clarsimp simp: sept_def sep_conj_def maps_to_ex_def split: if_splits)
  apply (erule disjE, clarsimp simp: pred_conj_def)
  apply (clarsimp simp: plus_prod_def, frule sep_add_cancel_maps_toD; clarsimp simp: sep_disj_prod_def)
  apply (smt Extended_Separation_Algebra.cancellative_sep_algebra_class.sep_add_cancelD prod.collapse sep_add_commute sep_disj_commuteI)
   apply (clarsimp simp: plus_prod_def)
   apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_prod_def sep_disj_option_def plus_bool_def sep_disj_bool_def split: if_splits)
  apply (fastforce simp: pred_conj_def)
  done

lemma sep_maps_to_success:
  "(p \<mapsto>u v \<and>* R) s \<Longrightarrow> (\<And>s. R s \<Longrightarrow> nf s) \<Longrightarrow> ((p \<mapsto>u v \<and>* R) and nf) s"
  apply (clarsimp simp: sep_conj_def pred_conj_def)
  by (simp add: plus_prod_def plus_bool_def)

lemma maps_to_nf:
  "(p \<mapsto>u v) s \<Longrightarrow> ((p \<mapsto>u v) and nf) s"
  by (clarsimp simp: pred_conj_def maps_to_def)

lemma maps_to_ex_nf:
  "(p \<mapsto>u -) s \<Longrightarrow> ((p \<mapsto>u -) and nf) s"
  by (clarsimp simp: pred_conj_def maps_to_ex_def maps_to_def)

lemma move_ptr_validU:
  "\<lbrace>(p \<mapsto>u v \<and>* p' \<mapsto>u -)\<rbrace> move_ptr p p' \<lbrace>\<lambda>_. (p \<mapsto>u v \<and>* p' \<mapsto>u v)\<rbrace>u"
  apply (clarsimp simp: move_ptr_def, rule hoare_seq_extU)
   apply (rule hoare_chainU, rule get_ptr_sp, assumption, assumption)
  apply (rule hoare_chainU[OF set_ptr_sp])
   apply (assumption)
  apply (subgoal_tac "x=v", clarsimp)
   apply (drule sep_con_impl2)
    apply (drule sept_impl2)
     apply (drule sep_con_impl2)
      apply (drule sept_impl2)
       apply (sep_drule maps_to_ex_nf[where p=p'])
       apply (sep_select_asm 2, assumption)
      apply (drule sept_success, assumption+)
   apply (drule sep_con_impl2)
    apply (drule sept_impl2)
     apply (rule sep_con_collapse[where p=p and R="p' \<mapsto>u -"])
     apply (erule sep_con_impl2)
     apply (clarsimp simp: pred_conj_def)
    apply (drule sept_impl2)
     apply (sep_drule maps_to_nf)
     apply (sep_select_asm 2, assumption)
    apply (drule sept_success_ex, assumption)
   apply (drule sep_con_collapse, sep_solve)
  apply (drule sep_con_impl2)
   apply (drule sept_impl2)
    apply (drule sep_con_impl2)
     apply (drule sept_impl2)
      apply (sep_drule maps_to_ex_nf[where p=p'])
      apply (sep_select_asm 2, assumption)
     apply (drule sept_success, assumption+)
  apply (clarsimp simp: pred_conj_def sep_con_def sept_def)
  done

lemma sep_crashable: "\<exists>s. (nf -& nf) s \<and> \<not>nf s"
  apply (rule_tac x="(undefined,False)" in exI)
  apply (clarsimp simp: sept_def)
  apply (rule_tac x="[p \<mapsto> v]" in exI)
  apply (rule_tac x=True in exI)
  apply (clarsimp)
  apply (rule_tac x=0 in exI)
  apply (rule_tac x= True in exI)
  apply (clarsimp)
  apply (clarsimp simp: sep_disj_prod_def sep_disj_bool_def)
  done

end


theory Proof_4_2
  imports Proofs4
begin

abbreviation s where "s s0 PdOut_value paid_value opened_value \<equiv>
  (toEnv
       (setPstate
         (setVarBool
           (setPstate
             (setVarBool
               (setPstate
                 (setVarBool
                   (setVarBool
                     (setPstate
                       (setPstate
                         (setPstate
                           (setVarBool (setVarBool (setVarBool s0 Init' PdOut_value) Init'init' paid_value) Controller'isClosed'
                             opened_value)
                           Init'init' Controller'isClosed')
                         Controller'isClosed' EntranceController'isClosed')
                       Init' STOP)
                     Controller'minimalOpened' True)
                   EntranceController'isOpened' False)
                 Init'init' Controller'minimalOpened')
               EntranceController'isClosed' True)
             Controller'isClosed' EntranceController'isOpened')
           Controller'isOpened' False)
         Controller'minimalOpened' STOP))"

theorem proof_4_2: "VC2 inv4 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC2_def)
  apply(unfold inv4_def R4_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply(unfold extraInv_def)
   apply(erule conjE)
   apply(erule conjE)
   apply((rule allI)+)
  subgoal premises vc_prems for s1 s2
    apply(insert vc_prems(2))
    apply(erule conjE)
    subgoal premises invs0
      apply(rule impI)
      apply((erule conjE)+)
      apply(erule le_imp_less_or_eq[THEN disjE])
   apply(rule cut_rl[of "\<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4 s0 \<and>
         toEnvNum s2 s4 \<le> 100 \<and>
         \<not> getVarBool s4 Controller'minimalOpened' \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 Controller'minimalOpened')"])
      apply(erule exE)
    subgoal for s4
      apply(rule exI[of _ s4])
      by simp
     apply(insert invs0(1))[1]
     apply(erule conjE)
     apply(erule allE[of _ s1])
     apply(erule allE[of _ s2])
     apply(simp split: if_splits)
      apply(rule cut_rl[of "\<forall> s5. toEnvP s5 \<and> substate s2 s5 \<and> substate s5 (s s0 PdOut_value paid_value opened_value) \<longrightarrow>
pred4 s1 s2 (s s0 PdOut_value paid_value opened_value) s5"])
     apply(erule allE[of _ s2])
     apply(erule impE)
    using substate_refl apply blast
     apply(unfold pred4_def)
     apply(erule impE)
    apply(insert substate_refl substate_trans substate_antisym)[1]
    apply metis
     apply assumption
      apply(rule allI)
      subgoal premises prems for s5
        apply(induction rule: state_ind)
        using prems apply simp
         apply(rule impI)

         apply((erule conjE)+)
         apply(erule allE[of _ s0])
         apply(erule impE)
        using invs0(1) substate_refl apply(simp split: if_splits)

         apply(insert vc_prems(1))[1]
         apply(rule cut_rl[of False])
          apply blast
        subgoal premises ind_base
          using vc_prems(1) apply simp
          apply(insert invs0(2))
          apply((erule conjE)+)
          apply(rule cut_rl[of "toEnvNum emptyState s0 = 1"])
     using ind_base(10) substate_refl[of s0]
     apply (smt (verit) le_antisym ltime_le_toEnvNum numeral_le_one_iff semiring_norm(69))
     using substate_refl[of s0] by blast

        subgoal for s5
          apply(simp only: pred4_def)
          apply(rule impI)
          apply(cases "getVarBool (predEnv s5) open' = False")
           apply(rule exI[of _ "predEnv s5"])
           apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
            apply blast
       apply(rule conjI)
          using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 PdOut_value paid_value opened_value) "]
        apply force
       apply(rule conjI)
        apply blast
      using substate_antisym apply blast
      apply(drule impE)
        prefer 3
        apply assumption
       apply(((rule conjI),blast)+)
      using substate_imp_substatete_predEnv_or_eq apply blast
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
       apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        using predEnv_substate_imp_substate_or_eq by blast
      done
    done
  done
  done