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

theory Matching
  imports
    Abstract_Matching
    Unification (* for decompose *)
begin

function match_term_list
where
  "match_term_list [] \<sigma> = Some \<sigma>" |
  "match_term_list ((Var x, t) # P) \<sigma> =
    (if \<sigma> x = None \<or> \<sigma> x = Some t then match_term_list P (\<sigma> (x \<mapsto> t))
    else None)" |
  "match_term_list ((Fun f ss, Fun g ts) # P) \<sigma> =
    (case decompose (Fun f ss) (Fun g ts) of
      None \<Rightarrow> None
    | Some us \<Rightarrow> match_term_list (us @ P) \<sigma>)" |
  "match_term_list ((Fun f ss, Var x) # P) \<sigma> = None"
  by (pat_completeness) auto
termination
  by (standard, rule wf_inv_image [OF wf_measure [of size_mset], of "mset \<circ> fst"]) (auto simp: pair_size_def)

lemma match_term_list_Some_matchrel:
  assumes "match_term_list P \<sigma> = Some \<tau>"
  shows "((mset P, \<sigma>), ({#}, \<tau>)) \<in> matchrel\<^sup>*"
using assms
proof (induction P \<sigma> rule: match_term_list.induct)
  case (2 x t P \<sigma>)
  from "2.prems"
    have *: "\<sigma> x = None \<or> \<sigma> x = Some t"
    and **: "match_term_list P (\<sigma> (x \<mapsto> t)) = Some \<tau>" by (auto split: if_splits)
  from MATCH1.Var [of \<sigma> x t "mset P", OF *]
    have "((mset ((Var x, t) # P), \<sigma>), (mset P, \<sigma> (x \<mapsto> t))) \<in> matchrel\<^sup>*"
    by (simp add: MATCH1_matchrel_conv)
  with "2.IH" [OF * **] show ?case by (blast dest: rtrancl_trans)
next
  case (3 f ss g ts P \<sigma>)
  let ?s = "Fun f ss" and ?t = "Fun g ts"
  from "3.prems" have [simp]: "f = g"
    and *: "length ss = length ts"
    and **: "decompose ?s ?t = Some (zip ss ts)"
      "match_term_list (zip ss ts @ P) \<sigma> = Some \<tau>"
    by (auto split: option.splits)
  from MATCH1.Fun [OF *, of "mset P" g \<sigma>]
    have "((mset ((?s, ?t) # P), \<sigma>), (mset (zip ss ts @ P), \<sigma>)) \<in> matchrel\<^sup>*"
    by (simp add: MATCH1_matchrel_conv ac_simps)
  with "3.IH" [OF **] show ?case by (blast dest: rtrancl_trans)
qed simp_all

lemma match_term_list_None:
  assumes "match_term_list P \<sigma> = None"
  shows "matchers_map \<sigma> \<inter> matchers (set P) = {}"
using assms
proof (induction P \<sigma> rule: match_term_list.induct)
  case (2 x t P \<sigma>)
  have "\<not> (\<sigma> x = None \<or> \<sigma> x = Some t) \<or>
    (\<sigma> x = None \<or> \<sigma> x = Some t) \<and> match_term_list P (\<sigma> (x \<mapsto> t)) = None"
    using "2.prems" by (auto split: if_splits)
  then show ?case
  proof
    assume *: "\<not> (\<sigma> x = None \<or> \<sigma> x = Some t)"
    have "\<not> (\<exists>y. (({#(Var x, t)#}, \<sigma>), y) \<in> matchrel)"
    proof
      presume "\<not> ?thesis"
      then obtain y where "MATCH1 ({#(Var x, t)#}, \<sigma>) y"
        by (auto simp: MATCH1_matchrel_conv)
      then show False using * by (cases) simp_all
    qed simp
    moreover have "(({#(Var x, t)#}, \<sigma>), ({#(Var x, t)#}, \<sigma>)) \<in> matchrel\<^sup>*" by simp
    ultimately have "(({#(Var x, t)#}, \<sigma>), ({#(Var x, t)#}, \<sigma>)) \<in> matchrel\<^sup>!"
      by (metis NF_I normalizability_I)
    from irreducible_reachable_imp_matchers_empty [OF this]
      have "matchers_map \<sigma> \<inter> matchers {(Var x, t)} = {}" by simp
    then show ?case by auto
  next
    presume *: "\<sigma> x = None \<or> \<sigma> x = Some t"
      and "match_term_list P (\<sigma> (x \<mapsto> t)) = None"
    from "2.IH" [OF this] have "matchers_map (\<sigma> (x \<mapsto> t)) \<inter> matchers (set P) = {}" .
    with MATCH1_matchers [OF MATCH1.Var [of \<sigma> x, OF *], of "mset P"]
      show ?case by simp
  qed auto
next
  case (3 f ss g ts P \<sigma>)
  let ?s = "Fun f ss" and ?t = "Fun g ts"
  have "decompose ?s ?t = None \<or>
    decompose ?s ?t = Some (zip ss ts) \<and> match_term_list (zip ss ts @ P) \<sigma> = None"
    using "3.prems" by (auto split: option.splits)
  then show ?case
  proof
    assume "decompose ?s ?t = None"
    then show ?case by auto
  next
    presume "decompose ?s ?t = Some (zip ss ts)"
      and "match_term_list (zip ss ts @ P) \<sigma> = None"
    from "3.IH" [OF this] show ?case by auto
  qed auto
qed simp_all

text \<open>Compute a matching substitution for a list of term pairs @{term P},
where left-hand sides are "patterns" against which the right-hand sides are matched.\<close>
definition match_list ::
  "('v \<Rightarrow> ('f, 'w) term) \<Rightarrow> (('f, 'v) term \<times> ('f, 'w) term) list \<Rightarrow> ('f, 'v, 'w) gsubst option"
  where
    "match_list d P = map_option (subst_of_map d) (match_term_list P Map.empty)"

lemma match_list_sound:
  assumes "match_list d P = Some \<sigma>"
  shows "\<sigma> \<in> matchers (set P)"
  using matchrel_sound [of "mset P"]
    and match_term_list_Some_matchrel [of P Map.empty]
    and assms by (auto simp: match_list_def)

lemma match_list_matches:
  assumes "match_list d P = Some \<sigma>"
  shows "\<And>p t. (p, t) \<in> set P \<Longrightarrow> p \<cdot> \<sigma> = t"
  using match_list_sound [OF assms] by (force simp: matchers_def)

lemma match_list_complete:
  assumes "match_list d P = None"
  shows "matchers (set P) = {}"
  using match_term_list_None [of P Map.empty] and assms by (simp add: match_list_def)

lemma match_list_None_conv:
  "match_list d P = None \<longleftrightarrow> matchers (set P) = {}"
  using match_list_sound [of d P] and match_list_complete [of d P]
  by (metis empty_iff not_None_eq)

definition "match t l = match_list Var [(l, t)]"

lemma match_matches:
  assumes "match t p = Some \<sigma>"
  shows "p \<cdot> \<sigma> = t"
  using match_sound [OF assms] by (force simp: matchers_def)

lemma match_complete:
  assumes "match t p = None"
  shows "matchers {(p, t)} = {}"
  using match_list_complete [of Var "[(p, t)]"] and assms by (simp add: match_def)

definition matches :: "('f, 'w) term \<Rightarrow> ('f, 'v) term \<Rightarrow> bool"
where
  "matches t p = (case match_list (\<lambda> _. t) [(p,t)] of None \<Rightarrow> False | Some _ \<Rightarrow> True)"

lemma matches_iff:
  "matches t p \<longleftrightarrow> (\<exists>\<sigma>. p \<cdot> \<sigma> = t)"
  using match_list_sound [of _ "[(p,t)]"]
  and match_list_complete [of _ "[(p,t)]"]
  unfolding matches_def matchers_def
  by (force simp: split: option.splits)

lemma match_complete':
  assumes "p \<cdot> \<sigma> = t"
  shows "\<exists>\<tau>. match t p = Some \<tau> \<and> (\<forall>x\<in>vars_term p. \<sigma> x = \<tau> x)"
proof -
  from assms have \<sigma>: "\<sigma> \<in> matchers {(p,t)}" by (simp add: matchers_def)
  with match_complete[of t p]
  obtain \<tau> where match: "match t p = Some \<tau>" by (auto split: option.splits)
  from match_sound[OF this]
  have "\<tau> \<in> matchers {(p, t)}" .
  from matchers_vars_term_eq[OF \<sigma> this] match show ?thesis by auto
qed

abbreviation lvars :: "(('f, 'v) term \<times> ('f, 'w) term) list \<Rightarrow> 'v set"
where
  "lvars P \<equiv> \<Union> ((vars_term \<circ> fst) ` set P)"

lemma match_list_complete':
  assumes "\<And>s t. (s, t) \<in> set P \<Longrightarrow> s \<cdot> \<sigma> = t"
  shows "\<exists>\<tau>. match_list d P = Some \<tau> \<and> (\<forall>x\<in>lvars P. \<sigma> x = \<tau> x)"
proof -
  from assms have "\<sigma> \<in> matchers (set P)" by (force simp: matchers_def)
  moreover with match_list_complete [of d P] obtain \<tau>
    where "match_list d P = Some \<tau>" by auto
  moreover with match_list_sound [of d P]
    have "\<tau> \<in> matchers (set P)"
    by (auto simp: match_def split: option.splits)
  ultimately show ?thesis
    using matchers_vars_term_eq [of \<sigma> "set P" "\<tau>"] by auto
qed

end


(* Title:  ZF/ex/Ring.thy

*)

section \<open>Rings\<close>

theory Ring imports Group begin

no_notation
  cadd  (infixl \<open>\<oplus>\<close> 65) and
  cmult  (infixl \<open>\<otimes>\<close> 70)

(*First, we must simulate a record declaration:
record ring = monoid +
  add :: "[i, i] => i" (infixl "\<oplus>\<index>" 65)
  zero :: i ("\<zero>\<index>")
*)

definition
  add_field :: "i => i" where
  "add_field(M) = fst(snd(snd(snd(M))))"

definition
  ring_add :: "[i, i, i] => i" (infixl \<open>\<oplus>\<index>\<close> 65) where
  "ring_add(M,x,y) = add_field(M) ` <x,y>"

definition
  zero :: "i => i" (\<open>\<zero>\<index>\<close>) where
  "zero(M) = fst(snd(snd(snd(snd(M)))))"

lemma add_field_eq [simp]: "add_field(<C,M,I,A,z>) = A"
  by (simp add: add_field_def)

lemma add_eq [simp]: "ring_add(<C,M,I,A,z>, x, y) = A ` <x,y>"
  by (simp add: ring_add_def)

lemma zero_eq [simp]: "zero(<C,M,I,A,Z,z>) = Z"
  by (simp add: zero_def)

text \<open>Derived operations.\<close>

definition
  a_inv :: "[i,i] => i" (\<open>\<ominus>\<index> _\<close> [81] 80) where
  "a_inv(R) == m_inv (<carrier(R), add_field(R), zero(R), 0>)"

definition
  minus :: "[i,i,i] => i" (\<open>(_ \<ominus>\<index> _)\<close> [65,66] 65) where
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> x \<ominus>\<^bsub>R\<^esub> y = x \<oplus>\<^bsub>R\<^esub> (\<ominus>\<^bsub>R\<^esub> y)"

locale abelian_monoid = fixes G (structure)
  assumes a_comm_monoid:
    "comm_monoid (<carrier(G), add_field(G), zero(G), 0>)"

text \<open>
  The following definition is redundant but simple to use.
\<close>

locale abelian_group = abelian_monoid +
  assumes a_comm_group:
    "comm_group (<carrier(G), add_field(G), zero(G), 0>)"

locale ring = abelian_group R + monoid R for R (structure) +
  assumes l_distr: "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R); z \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> (x \<oplus> y) \<cdot> z = x \<cdot> z \<oplus> y \<cdot> z"
    and r_distr: "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R); z \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> z \<cdot> (x \<oplus> y) = z \<cdot> x \<oplus> z \<cdot> y"

locale cring = ring + comm_monoid R

locale "domain" = cring +
  assumes one_not_zero [simp]: "\<one> \<noteq> \<zero>"
    and integral: "\<lbrakk>a \<cdot> b = \<zero>; a \<in> carrier(R); b \<in> carrier(R)\<rbrakk> \<Longrightarrow>
                  a = \<zero> | b = \<zero>"

subsection \<open>Basic Properties\<close>

lemma (in abelian_monoid) a_monoid:
     "monoid (<carrier(G), add_field(G), zero(G), 0>)"
apply (insert a_comm_monoid)
apply (simp add: comm_monoid_def)
done

lemma (in abelian_group) a_group:
     "group (<carrier(G), add_field(G), zero(G), 0>)"
apply (insert a_comm_group)
apply (simp add: comm_group_def group_def)
done

lemma (in abelian_monoid) l_zero [simp]:
     "x \<in> carrier(G) \<Longrightarrow> \<zero> \<oplus> x = x"
apply (insert monoid.l_one [OF a_monoid])
apply (simp add: ring_add_def)
done

lemma (in abelian_monoid) zero_closed [intro, simp]:
     "\<zero> \<in> carrier(G)"
by (rule monoid.one_closed [OF a_monoid, simplified])

lemma (in abelian_group) a_inv_closed [intro, simp]:
     "x \<in> carrier(G) \<Longrightarrow> \<ominus> x \<in> carrier(G)"
by (simp add: a_inv_def  group.inv_closed [OF a_group, simplified])

lemma (in abelian_monoid) a_closed [intro, simp]:
     "[| x \<in> carrier(G); y \<in> carrier(G) |] ==> x \<oplus> y \<in> carrier(G)"
by (rule monoid.m_closed [OF a_monoid,
                  simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_group) minus_closed [intro, simp]:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<ominus> y \<in> carrier(G)"
by (simp add: minus_def)

lemma (in abelian_group) a_l_cancel [simp]:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (x \<oplus> y = x \<oplus> z) \<longleftrightarrow> (y = z)"
by (rule group.l_cancel [OF a_group,
             simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_group) a_r_cancel [simp]:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (y \<oplus> x = z \<oplus> x) \<longleftrightarrow> (y = z)"
by (rule group.r_cancel [OF a_group, simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) a_assoc:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
   \<Longrightarrow> (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
by (rule monoid.m_assoc [OF a_monoid, simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_group) l_neg:
     "x \<in> carrier(G) \<Longrightarrow> \<ominus> x \<oplus> x = \<zero>"
by (simp add: a_inv_def
     group.l_inv [OF a_group, simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) a_comm:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<oplus> y = y \<oplus> x"
by (rule comm_monoid.m_comm [OF a_comm_monoid,
    simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) a_lcomm:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> x \<oplus> (y \<oplus> z) = y \<oplus> (x \<oplus> z)"
by (rule comm_monoid.m_lcomm [OF a_comm_monoid,
    simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) r_zero [simp]:
     "x \<in> carrier(G) \<Longrightarrow> x \<oplus> \<zero> = x"
  using monoid.r_one [OF a_monoid]
  by (simp add: ring_add_def [symmetric])

lemma (in abelian_group) r_neg:
     "x \<in> carrier(G) \<Longrightarrow> x \<oplus> (\<ominus> x) = \<zero>"
  using group.r_inv [OF a_group]
  by (simp add: a_inv_def ring_add_def [symmetric])

lemma (in abelian_group) minus_zero [simp]:
     "\<ominus> \<zero> = \<zero>"
  by (simp add: a_inv_def
    group.inv_one [OF a_group, simplified ])

lemma (in abelian_group) minus_minus [simp]:
     "x \<in> carrier(G) \<Longrightarrow> \<ominus> (\<ominus> x) = x"
  using group.inv_inv [OF a_group, simplified]
  by (simp add: a_inv_def)

lemma (in abelian_group) minus_add:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> \<ominus> (x \<oplus> y) = \<ominus> x \<oplus> \<ominus> y"
  using comm_group.inv_mult [OF a_comm_group]
  by (simp add: a_inv_def ring_add_def [symmetric])

lemmas (in abelian_monoid) a_ac = a_assoc a_comm a_lcomm

text \<open>
  The following proofs are from Jacobson, Basic Algebra I, pp.~88--89
\<close>

context ring
begin

lemma l_null [simp]: "x \<in> carrier(R) \<Longrightarrow> \<zero> \<cdot> x = \<zero>"
proof -
  assume R: "x \<in> carrier(R)"
  then have "\<zero> \<cdot> x \<oplus> \<zero> \<cdot> x = (\<zero> \<oplus> \<zero>) \<cdot> x"
    by (blast intro: l_distr [THEN sym])
  also from R have "... = \<zero> \<cdot> x \<oplus> \<zero>" by simp
  finally have "\<zero> \<cdot> x \<oplus> \<zero> \<cdot> x = \<zero> \<cdot> x \<oplus> \<zero>" .
  with R show ?thesis by (simp del: r_zero)
qed

lemma r_null [simp]: "x \<in> carrier(R) \<Longrightarrow> x \<cdot> \<zero> = \<zero>"
proof -
  assume R: "x \<in> carrier(R)"
  then have "x \<cdot> \<zero> \<oplus> x \<cdot> \<zero> = x \<cdot> (\<zero> \<oplus> \<zero>)"
    by (simp add: r_distr del: l_zero r_zero)
  also from R have "... = x \<cdot> \<zero> \<oplus> \<zero>" by simp
  finally have "x \<cdot> \<zero> \<oplus> x \<cdot> \<zero> = x \<cdot> \<zero> \<oplus> \<zero>" .
  with R show ?thesis by (simp del: r_zero)
qed

lemma l_minus:
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> \<ominus> x \<cdot> y = \<ominus> (x \<cdot> y)"
proof -
  assume R: "x \<in> carrier(R)" "y \<in> carrier(R)"
  then have "(\<ominus> x) \<cdot> y \<oplus> x \<cdot> y = (\<ominus> x \<oplus> x) \<cdot> y" by (simp add: l_distr)
  also from R have "... = \<zero>" by (simp add: l_neg)
  finally have "(\<ominus> x) \<cdot> y \<oplus> x \<cdot> y = \<zero>" .
  with R have "(\<ominus> x) \<cdot> y \<oplus> x \<cdot> y \<oplus> \<ominus> (x \<cdot> y) = \<zero> \<oplus> \<ominus> (x \<cdot> y)" by simp
  with R show ?thesis by (simp add: a_assoc r_neg)
qed

lemma r_minus:
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> x \<cdot> \<ominus> y = \<ominus> (x \<cdot> y)"
proof -
  assume R: "x \<in> carrier(R)" "y \<in> carrier(R)"
  then have "x \<cdot> (\<ominus> y) \<oplus> x \<cdot> y = x \<cdot> (\<ominus> y \<oplus> y)" by (simp add: r_distr)
  also from R have "... = \<zero>" by (simp add: l_neg)
  finally have "x \<cdot> (\<ominus> y) \<oplus> x \<cdot> y = \<zero>" .
  with R have "x \<cdot> (\<ominus> y) \<oplus> x \<cdot> y \<oplus> \<ominus> (x \<cdot> y) = \<zero> \<oplus> \<ominus> (x \<cdot> y)" by simp
  with R show ?thesis by (simp add: a_assoc r_neg)
qed

lemma minus_eq:
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> x \<ominus> y = x \<oplus> \<ominus> y"
  by (simp only: minus_def)

end

subsection \<open>Morphisms\<close>

definition
  ring_hom :: "[i,i] => i" where
  "ring_hom(R,S) ==
    {h \<in> carrier(R) -> carrier(S).
      (\<forall>x y. x \<in> carrier(R) & y \<in> carrier(R) \<longrightarrow>
        h ` (x \<cdot>\<^bsub>R\<^esub> y) = (h ` x) \<cdot>\<^bsub>S\<^esub> (h ` y) &
        h ` (x \<oplus>\<^bsub>R\<^esub> y) = (h ` x) \<oplus>\<^bsub>S\<^esub> (h ` y)) &
      h ` \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>}"

lemma ring_hom_memI:
  assumes hom_type: "h \<in> carrier(R) \<rightarrow> carrier(S)"
    and hom_mult: "\<And>x y. \<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow>
      h ` (x \<cdot>\<^bsub>R\<^esub> y) = (h ` x) \<cdot>\<^bsub>S\<^esub> (h ` y)"
    and hom_add: "\<And>x y. \<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow>
      h ` (x \<oplus>\<^bsub>R\<^esub> y) = (h ` x) \<oplus>\<^bsub>S\<^esub> (h ` y)"
    and hom_one: "h ` \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>"
  shows "h \<in> ring_hom(R,S)"
by (auto simp add: ring_hom_def assms)

lemma ring_hom_closed:
     "\<lbrakk>h \<in> ring_hom(R,S); x \<in> carrier(R)\<rbrakk> \<Longrightarrow> h ` x \<in> carrier(S)"
by (auto simp add: ring_hom_def)

lemma ring_hom_mult:
     "\<lbrakk>h \<in> ring_hom(R,S); x \<in> carrier(R); y \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> h ` (x \<cdot>\<^bsub>R\<^esub> y) = (h ` x) \<cdot>\<^bsub>S\<^esub> (h ` y)"
by (simp add: ring_hom_def)

lemma ring_hom_add:
     "\<lbrakk>h \<in> ring_hom(R,S); x \<in> carrier(R); y \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> h ` (x \<oplus>\<^bsub>R\<^esub> y) = (h ` x) \<oplus>\<^bsub>S\<^esub> (h ` y)"
by (simp add: ring_hom_def)

lemma ring_hom_one: "h \<in> ring_hom(R,S) \<Longrightarrow> h ` \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>"
by (simp add: ring_hom_def)

locale ring_hom_cring = R: cring R + S: cring S
  for R (structure) and S (structure) and h +
  assumes homh [simp, intro]: "h \<in> ring_hom(R,S)"
  notes hom_closed [simp, intro] = ring_hom_closed [OF homh]
    and hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_add [simp] = ring_hom_add [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

lemma (in ring_hom_cring) hom_zero [simp]:
     "h ` \<zero>\<^bsub>R\<^esub> = \<zero>\<^bsub>S\<^esub>"
proof -
  have "h ` \<zero>\<^bsub>R\<^esub> \<oplus>\<^bsub>S\<^esub> h ` \<zero> = h ` \<zero>\<^bsub>R\<^esub> \<oplus>\<^bsub>S\<^esub> \<zero>\<^bsub>S\<^esub>"
    by (simp add: hom_add [symmetric] del: hom_add)
  then show ?thesis by (simp del: S.r_zero)
qed

lemma (in ring_hom_cring) hom_a_inv [simp]:
     "x \<in> carrier(R) \<Longrightarrow> h ` (\<ominus>\<^bsub>R\<^esub> x) = \<ominus>\<^bsub>S\<^esub> h ` x"
proof -
  assume R: "x \<in> carrier(R)"
  then have "h ` x \<oplus>\<^bsub>S\<^esub> h ` (\<ominus> x) = h ` x \<oplus>\<^bsub>S\<^esub> (\<ominus>\<^bsub>S\<^esub> (h ` x))"
    by (simp add: hom_add [symmetric] R.r_neg S.r_neg del: hom_add)
  with R show ?thesis by simp
qed

lemma (in ring) id_ring_hom [simp]: "id(carrier(R)) \<in> ring_hom(R,R)"
apply (rule ring_hom_memI)
apply (auto simp add: id_type)
done

end


section "Hash-Sets"
theory Hash_Set_Impl
imports Imp_Set_Spec Hash_Map_Impl
begin

subsection \<open>Auxiliary Definitions\<close>
definition map_of_set:: "'a set \<Rightarrow> 'a\<rightharpoonup>unit"
  where "map_of_set S x \<equiv> if x\<in>S then Some () else None"

lemma ne_some_unit_eq: "x\<noteq>Some () \<longleftrightarrow> x=None"
  by (cases x) auto

lemma map_of_set_simps[simp]:
  "dom (map_of_set s) = s"
  "map_of_set (dom m) = m"
  "map_of_set {} = Map.empty"
  "map_of_set s x = None \<longleftrightarrow> x\<notin>s"
  "map_of_set s x = Some u \<longleftrightarrow> x\<in>s"
  "map_of_set s (x\<mapsto>()) = map_of_set (insert x s)"
  "(map_of_set s) |` (-{x}) = map_of_set (s -{x})"
  apply (auto simp: map_of_set_def
    dom_def ne_some_unit_eq restrict_map_def
    intro!: ext)
  done

lemma map_of_set_eq':
  "map_of_set a = map_of_set b \<longleftrightarrow> a=b"
  apply (auto simp: map_of_set_def[abs_def])
  apply (metis option.simps(3))+
  done

lemma map_of_set_eq[simp]:
  "map_of_set s = m \<longleftrightarrow> dom m=s"
  apply (auto
    simp: dom_def map_of_set_def[abs_def] ne_some_unit_eq
    intro!: ext)
  apply (metis option.simps(3))
  done

subsection \<open>Main Definitions\<close>
type_synonym 'a hashset = "('a,unit) hashtable"
definition "is_hashset s ht \<equiv> is_hashmap (map_of_set s) ht"

lemma hs_set_impl: "imp_set is_hashset"
  apply unfold_locales
  apply rule
  unfolding is_hashset_def
  apply (subst map_of_set_eq'[symmetric])
  by (metis preciseD[OF is_hashmap_prec])
interpretation hs: imp_set is_hashset by (rule hs_set_impl)

definition hs_new :: "'a::{heap,hashable} hashset Heap"
  where "hs_new = hm_new"

lemma hs_new_impl: "imp_set_empty is_hashset hs_new"
  apply unfold_locales
  apply (sep_auto heap: hm_new_rule simp: is_hashset_def hs_new_def)
  done
interpretation hs: imp_set_empty is_hashset hs_new by (rule hs_new_impl)

definition hs_memb:: "'a::{heap,hashable} \<Rightarrow> 'a hashset \<Rightarrow> bool Heap"
  where "hs_memb x s \<equiv> do {
  r\<leftarrow>hm_lookup x s;
  return (case r of Some _ \<Rightarrow> True | None \<Rightarrow> False)
}"

lemma hs_memb_impl: "imp_set_memb is_hashset hs_memb"
  apply unfold_locales
  unfolding hs_memb_def
  apply (sep_auto
    heap: hm_lookup_rule
    simp: is_hashset_def split: option.split)
  done
interpretation hs: imp_set_memb is_hashset hs_memb by (rule hs_memb_impl)

definition hs_ins:: "'a::{heap,hashable} \<Rightarrow> 'a hashset \<Rightarrow> 'a hashset Heap"
  where "hs_ins x ht \<equiv> hm_update x () ht"

lemma hs_ins_impl: "imp_set_ins is_hashset hs_ins"
  apply unfold_locales
  apply (sep_auto heap: hm_update_rule simp: hs_ins_def is_hashset_def)
  done
interpretation hs: imp_set_ins is_hashset hs_ins by (rule hs_ins_impl)

definition hs_delete
  :: "'a::{heap,hashable} \<Rightarrow> 'a hashset \<Rightarrow> 'a hashset Heap"
  where "hs_delete x ht \<equiv> hm_delete x ht"

lemma hs_delete_impl: "imp_set_delete is_hashset hs_delete"
  apply unfold_locales
  apply (sep_auto heap: hm_delete_rule simp: is_hashset_def hs_delete_def)
  done
interpretation hs: imp_set_delete is_hashset hs_delete
  by (rule hs_delete_impl)

definition "hs_isEmpty == hm_isEmpty"

lemma hs_is_empty_impl: "imp_set_is_empty is_hashset hs_isEmpty"
  apply unfold_locales
  apply (sep_auto heap: hm_isEmpty_rule simp: is_hashset_def hs_isEmpty_def)
  done
interpretation hs: imp_set_is_empty is_hashset hs_isEmpty
  by (rule hs_is_empty_impl)

definition "hs_size == hm_size"

lemma hs_size_impl: "imp_set_size is_hashset hs_size"
  apply unfold_locales
  apply (sep_auto heap: hm_size_rule simp: is_hashset_def hs_size_def)
  done
interpretation hs: imp_set_size is_hashset hs_size by (rule hs_size_impl)

type_synonym ('a) hs_it = "('a,unit) hm_it"

definition "hs_is_it s hs its it
  \<equiv> hm_is_it (map_of_set s) hs (map_of_set its) it"

definition hs_it_init :: "('a::{heap,hashable}) hashset \<Rightarrow> 'a hs_it Heap"
  where "hs_it_init \<equiv> hm_it_init"

definition hs_it_has_next :: "('a::{heap,hashable}) hs_it \<Rightarrow> bool Heap"
  where "hs_it_has_next \<equiv> hm_it_has_next"

definition hs_it_next
  :: "('a::{heap,hashable}) hs_it \<Rightarrow> ('a\<times>'a hs_it) Heap"
  where
  "hs_it_next it \<equiv> do {
    ((x,_),it) \<leftarrow> hm_it_next it;
    return (x,it)
  }"

lemma hs_iterate_impl: "imp_set_iterate
  is_hashset hs_is_it hs_it_init hs_it_has_next hs_it_next"
  apply unfold_locales
  unfolding hs_it_init_def hs_it_next_def hs_it_has_next_def
    hs_is_it_def is_hashset_def
  apply sep_auto
  apply sep_auto
  apply sep_auto
  apply (sep_auto eintros: hm.quit_iteration)
  done
interpretation hs: imp_set_iterate
  is_hashset hs_is_it hs_it_init hs_it_has_next hs_it_next
  by (rule hs_iterate_impl)

export_code hs_new hs_memb hs_ins hs_delete hs_isEmpty hs_size
  hs_it_init hs_it_has_next hs_it_next
  checking SML_imp

end


(*  Title:      HOL/Predicate.thy
    Author:     Lukas Bulwahn and Florian Haftmann, TU Muenchen
*)

section \<open>Predicates as enumerations\<close>

theory Predicate
imports String
begin

subsection \<open>The type of predicate enumerations (a monad)\<close>

datatype (plugins only: extraction) (dead 'a) pred = Pred (eval: "'a \<Rightarrow> bool")

lemma pred_eqI:
  "(\<And>w. eval P w \<longleftrightarrow> eval Q w) \<Longrightarrow> P = Q"
  by (cases P, cases Q) (auto simp add: fun_eq_iff)

lemma pred_eq_iff:
  "P = Q \<Longrightarrow> (\<And>w. eval P w \<longleftrightarrow> eval Q w)"
  by (simp add: pred_eqI)

instantiation pred :: (type) complete_lattice
begin

definition
  "P \<le> Q \<longleftrightarrow> eval P \<le> eval Q"

definition
  "P < Q \<longleftrightarrow> eval P < eval Q"

definition
  "\<bottom> = Pred \<bottom>"

lemma eval_bot [simp]:
  "eval \<bottom>  = \<bottom>"
  by (simp add: bot_pred_def)

definition
  "\<top> = Pred \<top>"

lemma eval_top [simp]:
  "eval \<top>  = \<top>"
  by (simp add: top_pred_def)

definition
  "P \<sqinter> Q = Pred (eval P \<sqinter> eval Q)"

lemma eval_inf [simp]:
  "eval (P \<sqinter> Q) = eval P \<sqinter> eval Q"
  by (simp add: inf_pred_def)

definition
  "P \<squnion> Q = Pred (eval P \<squnion> eval Q)"

lemma eval_sup [simp]:
  "eval (P \<squnion> Q) = eval P \<squnion> eval Q"
  by (simp add: sup_pred_def)

definition
  "\<Sqinter>A = Pred (\<Sqinter>(eval ` A))"

lemma eval_Inf [simp]:
  "eval (\<Sqinter>A) = \<Sqinter>(eval ` A)"
  by (simp add: Inf_pred_def)

definition
  "\<Squnion>A = Pred (\<Squnion>(eval ` A))"

lemma eval_Sup [simp]:
  "eval (\<Squnion>A) = \<Squnion>(eval ` A)"
  by (simp add: Sup_pred_def)

instance proof
qed (auto intro!: pred_eqI simp add: less_eq_pred_def less_pred_def le_fun_def less_fun_def)

end

lemma eval_INF [simp]:
  "eval (\<Sqinter>(f ` A)) = \<Sqinter>((eval \<circ> f) ` A)"
  by (simp add: image_comp)

lemma eval_SUP [simp]:
  "eval (\<Squnion>(f ` A)) = \<Squnion>((eval \<circ> f) ` A)"
  by (simp add: image_comp)

instantiation pred :: (type) complete_boolean_algebra
begin

definition
  "- P = Pred (- eval P)"

lemma eval_compl [simp]:
  "eval (- P) = - eval P"
  by (simp add: uminus_pred_def)

definition
  "P - Q = Pred (eval P - eval Q)"

lemma eval_minus [simp]:
  "eval (P - Q) = eval P - eval Q"
  by (simp add: minus_pred_def)

instance proof
  fix A::"'a pred set set"
  show "\<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
  proof (simp add: less_eq_pred_def Sup_fun_def Inf_fun_def, safe)
    fix w
    assume A: "\<forall>x\<in>A. \<exists>f\<in>x. eval f w"
    define F where "F = (\<lambda> x . SOME f . f \<in> x \<and> eval f w)"
    have [simp]: "(\<forall>f\<in> (F ` A). eval f w)"
      by (metis (no_types, lifting) A F_def image_iff some_eq_ex)
    have "(\<exists>f. F ` A = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> (\<forall>f\<in>(F ` A). eval f w)"
      using A by (simp, metis (no_types, lifting) F_def someI)+
    from this show "\<exists>x. (\<exists>f. x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> (\<forall>f\<in>x. eval f w)"
      by (rule exI [of _ "F ` A"])
  qed
qed (auto intro!: pred_eqI)

end

definition single :: "'a \<Rightarrow> 'a pred" where
  "single x = Pred ((=) x)"

lemma eval_single [simp]:
  "eval (single x) = (=) x"
  by (simp add: single_def)

definition bind :: "'a pred \<Rightarrow> ('a \<Rightarrow> 'b pred) \<Rightarrow> 'b pred" (infixl "\<bind>" 70) where
  "P \<bind> f = (\<Squnion>(f ` {x. eval P x}))"

lemma eval_bind [simp]:
  "eval (P \<bind> f) = eval (\<Squnion>(f ` {x. eval P x}))"
  by (simp add: bind_def)

lemma bind_bind:
  "(P \<bind> Q) \<bind> R = P \<bind> (\<lambda>x. Q x \<bind> R)"
  by (rule pred_eqI) auto

lemma bind_single:
  "P \<bind> single = P"
  by (rule pred_eqI) auto

lemma single_bind:
  "single x \<bind> P = P x"
  by (rule pred_eqI) auto

lemma bottom_bind:
  "\<bottom> \<bind> P = \<bottom>"
  by (rule pred_eqI) auto

lemma sup_bind:
  "(P \<squnion> Q) \<bind> R = P \<bind> R \<squnion> Q \<bind> R"
  by (rule pred_eqI) auto

lemma Sup_bind:
  "(\<Squnion>A \<bind> f) = \<Squnion>((\<lambda>x. x \<bind> f) ` A)"
  by (rule pred_eqI) auto

lemma pred_iffI:
  assumes "\<And>x. eval A x \<Longrightarrow> eval B x"
  and "\<And>x. eval B x \<Longrightarrow> eval A x"
  shows "A = B"
  using assms by (auto intro: pred_eqI)

lemma singleI: "eval (single x) x"
  by simp

lemma singleI_unit: "eval (single ()) x"
  by simp

lemma singleE: "eval (single x) y \<Longrightarrow> (y = x \<Longrightarrow> P) \<Longrightarrow> P"
  by simp

lemma singleE': "eval (single x) y \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
  by simp

lemma bindI: "eval P x \<Longrightarrow> eval (Q x) y \<Longrightarrow> eval (P \<bind> Q) y"
  by auto

lemma bindE: "eval (R \<bind> Q) y \<Longrightarrow> (\<And>x. eval R x \<Longrightarrow> eval (Q x) y \<Longrightarrow> P) \<Longrightarrow> P"
  by auto

lemma botE: "eval \<bottom> x \<Longrightarrow> P"
  by auto

lemma supI1: "eval A x \<Longrightarrow> eval (A \<squnion> B) x"
  by auto

lemma supI2: "eval B x \<Longrightarrow> eval (A \<squnion> B) x"
  by auto

lemma supE: "eval (A \<squnion> B) x \<Longrightarrow> (eval A x \<Longrightarrow> P) \<Longrightarrow> (eval B x \<Longrightarrow> P) \<Longrightarrow> P"
  by auto

lemma single_not_bot [simp]:
  "single x \<noteq> \<bottom>"
  by (auto simp add: single_def bot_pred_def fun_eq_iff)

lemma not_bot:
  assumes "A \<noteq> \<bottom>"
  obtains x where "eval A x"
  using assms by (cases A) (auto simp add: bot_pred_def)

subsection \<open>Emptiness check and definite choice\<close>

definition is_empty :: "'a pred \<Rightarrow> bool" where
  "is_empty A \<longleftrightarrow> A = \<bottom>"

lemma is_empty_bot:
  "is_empty \<bottom>"
  by (simp add: is_empty_def)

lemma not_is_empty_single:
  "\<not> is_empty (single x)"
  by (auto simp add: is_empty_def single_def bot_pred_def fun_eq_iff)

lemma is_empty_sup:
  "is_empty (A \<squnion> B) \<longleftrightarrow> is_empty A \<and> is_empty B"
  by (auto simp add: is_empty_def)

definition singleton :: "(unit \<Rightarrow> 'a) \<Rightarrow> 'a pred \<Rightarrow> 'a" where
  "singleton default A = (if \<exists>!x. eval A x then THE x. eval A x else default ())" for default

lemma singleton_eqI:
  "\<exists>!x. eval A x \<Longrightarrow> eval A x \<Longrightarrow> singleton default A = x" for default
  by (auto simp add: singleton_def)

lemma eval_singletonI:
  "\<exists>!x. eval A x \<Longrightarrow> eval A (singleton default A)" for default
proof -
  assume assm: "\<exists>!x. eval A x"
  then obtain x where x: "eval A x" ..
  with assm have "singleton default A = x" by (rule singleton_eqI)
  with x show ?thesis by simp
qed

lemma single_singleton:
  "\<exists>!x. eval A x \<Longrightarrow> single (singleton default A) = A" for default
proof -
  assume assm: "\<exists>!x. eval A x"
  then have "eval A (singleton default A)"
    by (rule eval_singletonI)
  moreover from assm have "\<And>x. eval A x \<Longrightarrow> singleton default A = x"
    by (rule singleton_eqI)
  ultimately have "eval (single (singleton default A)) = eval A"
    by (simp (no_asm_use) add: single_def fun_eq_iff) blast
  then have "\<And>x. eval (single (singleton default A)) x = eval A x"
    by simp
  then show ?thesis by (rule pred_eqI)
qed

lemma singleton_undefinedI:
  "\<not> (\<exists>!x. eval A x) \<Longrightarrow> singleton default A = default ()" for default
  by (simp add: singleton_def)

lemma singleton_bot:
  "singleton default \<bottom> = default ()" for default
  by (auto simp add: bot_pred_def intro: singleton_undefinedI)

lemma singleton_single:
  "singleton default (single x) = x" for default
  by (auto simp add: intro: singleton_eqI singleI elim: singleE)

lemma singleton_sup_single_single:
  "singleton default (single x \<squnion> single y) = (if x = y then x else default ())" for default
proof (cases "x = y")
  case True then show ?thesis by (simp add: singleton_single)
next
  case False
  have "eval (single x \<squnion> single y) x"
    and "eval (single x \<squnion> single y) y"
  by (auto intro: supI1 supI2 singleI)
  with False have "\<not> (\<exists>!z. eval (single x \<squnion> single y) z)"
    by blast
  then have "singleton default (single x \<squnion> single y) = default ()"
    by (rule singleton_undefinedI)
  with False show ?thesis by simp
qed

lemma singleton_sup_aux:
  "singleton default (A \<squnion> B) = (if A = \<bottom> then singleton default B
    else if B = \<bottom> then singleton default A
    else singleton default
      (single (singleton default A) \<squnion> single (singleton default B)))" for default
proof (cases "(\<exists>!x. eval A x) \<and> (\<exists>!y. eval B y)")
  case True then show ?thesis by (simp add: single_singleton)
next
  case False
  from False have A_or_B:
    "singleton default A = default () \<or> singleton default B = default ()"
    by (auto intro!: singleton_undefinedI)
  then have rhs: "singleton default
    (single (singleton default A) \<squnion> single (singleton default B)) = default ()"
    by (auto simp add: singleton_sup_single_single singleton_single)
  from False have not_unique:
    "\<not> (\<exists>!x. eval A x) \<or> \<not> (\<exists>!y. eval B y)" by simp
  show ?thesis proof (cases "A \<noteq> \<bottom> \<and> B \<noteq> \<bottom>")
    case True
    then obtain a b where a: "eval A a" and b: "eval B b"
      by (blast elim: not_bot)
    with True not_unique have "\<not> (\<exists>!x. eval (A \<squnion> B) x)"
      by (auto simp add: sup_pred_def bot_pred_def)
    then have "singleton default (A \<squnion> B) = default ()" by (rule singleton_undefinedI)
    with True rhs show ?thesis by simp
  next
    case False then show ?thesis by auto
  qed
qed

lemma singleton_sup:
  "singleton default (A \<squnion> B) = (if A = \<bottom> then singleton default B
    else if B = \<bottom> then singleton default A
    else if singleton default A = singleton default B then singleton default A else default ())" for default
  using singleton_sup_aux [of default A B] by (simp only: singleton_sup_single_single)

subsection \<open>Derived operations\<close>

definition if_pred :: "bool \<Rightarrow> unit pred" where
  if_pred_eq: "if_pred b = (if b then single () else \<bottom>)"

definition holds :: "unit pred \<Rightarrow> bool" where
  holds_eq: "holds P = eval P ()"

definition not_pred :: "unit pred \<Rightarrow> unit pred" where
  not_pred_eq: "not_pred P = (if eval P () then \<bottom> else single ())"

lemma if_predI: "P \<Longrightarrow> eval (if_pred P) ()"
  unfolding if_pred_eq by (auto intro: singleI)

lemma if_predE: "eval (if_pred b) x \<Longrightarrow> (b \<Longrightarrow> x = () \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding if_pred_eq by (cases b) (auto elim: botE)

lemma not_predI: "\<not> P \<Longrightarrow> eval (not_pred (Pred (\<lambda>u. P))) ()"
  unfolding not_pred_eq by (auto intro: singleI)

lemma not_predI': "\<not> eval P () \<Longrightarrow> eval (not_pred P) ()"
  unfolding not_pred_eq by (auto intro: singleI)

lemma not_predE: "eval (not_pred (Pred (\<lambda>u. P))) x \<Longrightarrow> (\<not> P \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  unfolding not_pred_eq
  by (auto split: if_split_asm elim: botE)

lemma not_predE': "eval (not_pred P) x \<Longrightarrow> (\<not> eval P x \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  unfolding not_pred_eq
  by (auto split: if_split_asm elim: botE)
lemma "f () = False \<or> f () = True"
by simp

lemma closure_of_bool_cases [no_atp]:
  fixes f :: "unit \<Rightarrow> bool"
  assumes "f = (\<lambda>u. False) \<Longrightarrow> P f"
  assumes "f = (\<lambda>u. True) \<Longrightarrow> P f"
  shows "P f"
proof -
  have "f = (\<lambda>u. False) \<or> f = (\<lambda>u. True)"
    apply (cases "f ()")
    apply (rule disjI2)
    apply (rule ext)
    apply (simp add: unit_eq)
    apply (rule disjI1)
    apply (rule ext)
    apply (simp add: unit_eq)
    done
  from this assms show ?thesis by blast
qed

lemma unit_pred_cases:
  assumes "P \<bottom>"
  assumes "P (single ())"
  shows "P Q"
using assms unfolding bot_pred_def bot_fun_def bot_bool_def empty_def single_def proof (cases Q)
  fix f
  assume "P (Pred (\<lambda>u. False))" "P (Pred (\<lambda>u. () = u))"
  then have "P (Pred f)"
    by (cases _ f rule: closure_of_bool_cases) simp_all
  moreover assume "Q = Pred f"
  ultimately show "P Q" by simp
qed

lemma holds_if_pred:
  "holds (if_pred b) = b"
unfolding if_pred_eq holds_eq
by (cases b) (auto intro: singleI elim: botE)

lemma if_pred_holds:
  "if_pred (holds P) = P"
unfolding if_pred_eq holds_eq
by (rule unit_pred_cases) (auto intro: singleI elim: botE)

lemma is_empty_holds:
  "is_empty P \<longleftrightarrow> \<not> holds P"
unfolding is_empty_def holds_eq
by (rule unit_pred_cases) (auto elim: botE intro: singleI)

definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a pred \<Rightarrow> 'b pred" where
  "map f P = P \<bind> (single \<circ> f)"

lemma eval_map [simp]:
  "eval (map f P) = (\<Squnion>x\<in>{x. eval P x}. (\<lambda>y. f x = y))"
  by (simp add: map_def comp_def image_comp)

functor map: map
  by (rule ext, rule pred_eqI, auto)+

subsection \<open>Implementation\<close>

datatype (plugins only: code extraction) (dead 'a) seq =
  Empty
| Insert "'a" "'a pred"
| Join "'a pred" "'a seq"

primrec pred_of_seq :: "'a seq \<Rightarrow> 'a pred" where
  "pred_of_seq Empty = \<bottom>"
| "pred_of_seq (Insert x P) = single x \<squnion> P"
| "pred_of_seq (Join P xq) = P \<squnion> pred_of_seq xq"

definition Seq :: "(unit \<Rightarrow> 'a seq) \<Rightarrow> 'a pred" where
  "Seq f = pred_of_seq (f ())"

code_datatype Seq

primrec member :: "'a seq \<Rightarrow> 'a \<Rightarrow> bool"  where
  "member Empty x \<longleftrightarrow> False"
| "member (Insert y P) x \<longleftrightarrow> x = y \<or> eval P x"
| "member (Join P xq) x \<longleftrightarrow> eval P x \<or> member xq x"

lemma eval_member:
  "member xq = eval (pred_of_seq xq)"
proof (induct xq)
  case Empty show ?case
  by (auto simp add: fun_eq_iff elim: botE)
next
  case Insert show ?case
  by (auto simp add: fun_eq_iff elim: supE singleE intro: supI1 supI2 singleI)
next
  case Join then show ?case
  by (auto simp add: fun_eq_iff elim: supE intro: supI1 supI2)
qed

lemma eval_code [(* FIXME declare simp *)code]: "eval (Seq f) = member (f ())"
  unfolding Seq_def by (rule sym, rule eval_member)

primrec "apply" :: "('a \<Rightarrow> 'b pred) \<Rightarrow> 'a seq \<Rightarrow> 'b seq" where
  "apply f Empty = Empty"
| "apply f (Insert x P) = Join (f x) (Join (P \<bind> f) Empty)"
| "apply f (Join P xq) = Join (P \<bind> f) (apply f xq)"

lemma apply_bind:
  "pred_of_seq (apply f xq) = pred_of_seq xq \<bind> f"
proof (induct xq)
  case Empty show ?case
    by (simp add: bottom_bind)
next
  case Insert show ?case
    by (simp add: single_bind sup_bind)
next
  case Join then show ?case
    by (simp add: sup_bind)
qed

lemma bind_code [code]:
  "Seq g \<bind> f = Seq (\<lambda>u. apply f (g ()))"
  unfolding Seq_def by (rule sym, rule apply_bind)

lemma bot_set_code [code]:
  "\<bottom> = Seq (\<lambda>u. Empty)"
  unfolding Seq_def by simp

primrec adjunct :: "'a pred \<Rightarrow> 'a seq \<Rightarrow> 'a seq" where
  "adjunct P Empty = Join P Empty"
| "adjunct P (Insert x Q) = Insert x (Q \<squnion> P)"
| "adjunct P (Join Q xq) = Join Q (adjunct P xq)"

lemma adjunct_sup:
  "pred_of_seq (adjunct P xq) = P \<squnion> pred_of_seq xq"
  by (induct xq) (simp_all add: sup_assoc sup_commute sup_left_commute)

lemma sup_code [code]:
  "Seq f \<squnion> Seq g = Seq (\<lambda>u. case f ()
    of Empty \<Rightarrow> g ()
     | Insert x P \<Rightarrow> Insert x (P \<squnion> Seq g)
     | Join P xq \<Rightarrow> adjunct (Seq g) (Join P xq))"
proof (cases "f ()")
  case Empty
  thus ?thesis
    unfolding Seq_def by (simp add: sup_commute [of "\<bottom>"])
next
  case Insert
  thus ?thesis
    unfolding Seq_def by (simp add: sup_assoc)
next
  case Join
  thus ?thesis
    unfolding Seq_def
    by (simp add: adjunct_sup sup_assoc sup_commute sup_left_commute)
qed

primrec contained :: "'a seq \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "contained Empty Q \<longleftrightarrow> True"
| "contained (Insert x P) Q \<longleftrightarrow> eval Q x \<and> P \<le> Q"
| "contained (Join P xq) Q \<longleftrightarrow> P \<le> Q \<and> contained xq Q"

lemma single_less_eq_eval:
  "single x \<le> P \<longleftrightarrow> eval P x"
  by (auto simp add: less_eq_pred_def le_fun_def)

lemma contained_less_eq:
  "contained xq Q \<longleftrightarrow> pred_of_seq xq \<le> Q"
  by (induct xq) (simp_all add: single_less_eq_eval)

lemma less_eq_pred_code [code]:
  "Seq f \<le> Q = (case f ()
   of Empty \<Rightarrow> True
    | Insert x P \<Rightarrow> eval Q x \<and> P \<le> Q
    | Join P xq \<Rightarrow> P \<le> Q \<and> contained xq Q)"
  by (cases "f ()")
    (simp_all add: Seq_def single_less_eq_eval contained_less_eq)

instantiation pred :: (type) equal
begin

definition equal_pred
  where [simp]: "HOL.equal P Q \<longleftrightarrow> P = (Q :: 'a pred)"

instance by standard simp

end

lemma [code nbe]:
  "HOL.equal P P \<longleftrightarrow> True" for P :: "'a pred"
  by (fact equal_refl)

lemma [code]:
  "case_pred f P = f (eval P)"
  by (fact pred.case_eq_if)

lemma [code]:
  "rec_pred f P = f (eval P)"
  by (cases P) simp

inductive eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "eq x x"

lemma eq_is_eq: "eq x y \<equiv> (x = y)"
  by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases)

primrec null :: "'a seq \<Rightarrow> bool" where
  "null Empty \<longleftrightarrow> True"
| "null (Insert x P) \<longleftrightarrow> False"
| "null (Join P xq) \<longleftrightarrow> is_empty P \<and> null xq"

lemma null_is_empty:
  "null xq \<longleftrightarrow> is_empty (pred_of_seq xq)"
  by (induct xq) (simp_all add: is_empty_bot not_is_empty_single is_empty_sup)

lemma is_empty_code [code]:
  "is_empty (Seq f) \<longleftrightarrow> null (f ())"
  by (simp add: null_is_empty Seq_def)

primrec the_only :: "(unit \<Rightarrow> 'a) \<Rightarrow> 'a seq \<Rightarrow> 'a" where
  "the_only default Empty = default ()" for default
| "the_only default (Insert x P) =
    (if is_empty P then x else let y = singleton default P in if x = y then x else default ())" for default
| "the_only default (Join P xq) =
    (if is_empty P then the_only default xq else if null xq then singleton default P
       else let x = singleton default P; y = the_only default xq in
       if x = y then x else default ())" for default

lemma the_only_singleton:
  "the_only default xq = singleton default (pred_of_seq xq)" for default
  by (induct xq)
    (auto simp add: singleton_bot singleton_single is_empty_def
    null_is_empty Let_def singleton_sup)

lemma singleton_code [code]:
  "singleton default (Seq f) =
    (case f () of
      Empty \<Rightarrow> default ()
    | Insert x P \<Rightarrow> if is_empty P then x
        else let y = singleton default P in
          if x = y then x else default ()
    | Join P xq \<Rightarrow> if is_empty P then the_only default xq
        else if null xq then singleton default P
        else let x = singleton default P; y = the_only default xq in
          if x = y then x else default ())" for default
  by (cases "f ()")
   (auto simp add: Seq_def the_only_singleton is_empty_def
      null_is_empty singleton_bot singleton_single singleton_sup Let_def)

definition the :: "'a pred \<Rightarrow> 'a" where
  "the A = (THE x. eval A x)"

lemma the_eqI:
  "(THE x. eval P x) = x \<Longrightarrow> the P = x"
  by (simp add: the_def)

lemma the_eq [code]: "the A = singleton (\<lambda>x. Code.abort (STR ''not_unique'') (\<lambda>_. the A)) A"
  by (rule the_eqI) (simp add: singleton_def the_def)

code_reflect Predicate
  datatypes pred = Seq and seq = Empty | Insert | Join

ML \<open>
signature PREDICATE =
sig
  val anamorph: ('a -> ('b * 'a) option) -> int -> 'a -> 'b list * 'a
  datatype 'a pred = Seq of (unit -> 'a seq)
  and 'a seq = Empty | Insert of 'a * 'a pred | Join of 'a pred * 'a seq
  val map: ('a -> 'b) -> 'a pred -> 'b pred
  val yield: 'a pred -> ('a * 'a pred) option
  val yieldn: int -> 'a pred -> 'a list * 'a pred
end;

structure Predicate : PREDICATE =
struct

fun anamorph f k x =
 (if k = 0 then ([], x)
  else case f x
   of NONE => ([], x)
    | SOME (v, y) => let
        val k' = k - 1;
        val (vs, z) = anamorph f k' y
      in (v :: vs, z) end);

datatype pred = datatype Predicate.pred
datatype seq = datatype Predicate.seq

fun map f = @{code Predicate.map} f;

fun yield (Seq f) = next (f ())
and next Empty = NONE
  | next (Insert (x, P)) = SOME (x, P)
  | next (Join (P, xq)) = (case yield P
     of NONE => next xq
      | SOME (x, Q) => SOME (x, Seq (fn _ => Join (Q, xq))));

fun yieldn k = anamorph yield k;

end;
\<close>

text \<open>Conversion from and to sets\<close>

definition pred_of_set :: "'a set \<Rightarrow> 'a pred" where
  "pred_of_set = Pred \<circ> (\<lambda>A x. x \<in> A)"

lemma eval_pred_of_set [simp]:
  "eval (pred_of_set A) x \<longleftrightarrow> x \<in>A"
  by (simp add: pred_of_set_def)

definition set_of_pred :: "'a pred \<Rightarrow> 'a set" where
  "set_of_pred = Collect \<circ> eval"

lemma member_set_of_pred [simp]:
  "x \<in> set_of_pred P \<longleftrightarrow> Predicate.eval P x"
  by (simp add: set_of_pred_def)

definition set_of_seq :: "'a seq \<Rightarrow> 'a set" where
  "set_of_seq = set_of_pred \<circ> pred_of_seq"

lemma member_set_of_seq [simp]:
  "x \<in> set_of_seq xq = Predicate.member xq x"
  by (simp add: set_of_seq_def eval_member)

lemma of_pred_code [code]:
  "set_of_pred (Predicate.Seq f) = (case f () of
     Predicate.Empty \<Rightarrow> {}
   | Predicate.Insert x P \<Rightarrow> insert x (set_of_pred P)
   | Predicate.Join P xq \<Rightarrow> set_of_pred P \<union> set_of_seq xq)"
  by (auto split: seq.split simp add: eval_code)

lemma of_seq_code [code]:
  "set_of_seq Predicate.Empty = {}"
  "set_of_seq (Predicate.Insert x P) = insert x (set_of_pred P)"
  "set_of_seq (Predicate.Join P xq) = set_of_pred P \<union> set_of_seq xq"
  by auto

text \<open>Lazy Evaluation of an indexed function\<close>

function iterate_upto :: "(natural \<Rightarrow> 'a) \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> 'a Predicate.pred"
where
  "iterate_upto f n m =
    Predicate.Seq (%u. if n > m then Predicate.Empty
     else Predicate.Insert (f n) (iterate_upto f (n + 1) m))"
by pat_completeness auto

termination by (relation "measure (%(f, n, m). nat_of_natural (m + 1 - n))")
  (auto simp add: less_natural_def)

text \<open>Misc\<close>

declare Inf_set_fold [where 'a = "'a Predicate.pred", code]
declare Sup_set_fold [where 'a = "'a Predicate.pred", code]

(* FIXME: better implement conversion by bisection *)

lemma pred_of_set_fold_sup:
  assumes "finite A"
  shows "pred_of_set A = Finite_Set.fold sup bot (Predicate.single ` A)" (is "?lhs = ?rhs")
proof (rule sym)
  interpret comp_fun_idem "sup :: 'a Predicate.pred \<Rightarrow> 'a Predicate.pred \<Rightarrow> 'a Predicate.pred"
    by (fact comp_fun_idem_sup)
  from \<open>finite A\<close> show "?rhs = ?lhs" by (induct A) (auto intro!: pred_eqI)
qed

lemma pred_of_set_set_fold_sup:
  "pred_of_set (set xs) = fold sup (List.map Predicate.single xs) bot"
proof -
  interpret comp_fun_idem "sup :: 'a Predicate.pred \<Rightarrow> 'a Predicate.pred \<Rightarrow> 'a Predicate.pred"
    by (fact comp_fun_idem_sup)
  show ?thesis by (simp add: pred_of_set_fold_sup fold_set_fold [symmetric])
qed

lemma pred_of_set_set_foldr_sup [code]:
  "pred_of_set (set xs) = foldr sup (List.map Predicate.single xs) bot"
  by (simp add: pred_of_set_set_fold_sup ac_simps foldr_fold fun_eq_iff)

no_notation
  bind (infixl "\<bind>" 70)

hide_type (open) pred seq
hide_const (open) Pred eval single bind is_empty singleton if_pred not_pred holds
  Empty Insert Join Seq member pred_of_seq "apply" adjunct null the_only eq map the
  iterate_upto
hide_fact (open) null_def member_def

end


(* Author: Tobias Nipkow *)

subsection "Computable Abstract Interpretation"

theory Abs_Int1
imports Abs_State
begin

text\<open>Abstract interpretation over type \<open>st\<close> instead of functions.\<close>

context Gamma_semilattice
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
  "aval' (N i) S = num' i" |
  "aval' (V x) S = fun S x" |
  "aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

lemma aval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> aval a s \<in> \<gamma>(aval' a S)"
  by (induction a) (auto simp: gamma_num' gamma_plus' \<gamma>_st_def)

fun bval' :: "bexp \<Rightarrow> 'av st \<Rightarrow> bool option" where
  "bval' (Bc v) _ = Some v" |
  "bval' (Not b) S = (case bval' b S of None \<Rightarrow> None | Some v' \<Rightarrow> Some (\<not>v'))" |
  "bval' (And b\<^sub>1 b\<^sub>2) S = (case (bval' b\<^sub>1 S, bval' b\<^sub>2 S) of
    (Some False, _) \<Rightarrow> Some False |
    (_, Some False) \<Rightarrow> Some False |
    (None, _) \<Rightarrow> None |
    (_, None) \<Rightarrow> None |
    (Some True, Some True) \<Rightarrow> Some True)" |
  "bval' (Less a\<^sub>1 a\<^sub>2) S = less' (aval' a\<^sub>1 S) (aval' a\<^sub>2 S)"

lemma bval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> bval' b S = None \<or> bval' b S = Some (bval b s)"
  by (induct b) (auto simp: gamma_less' aval'_correct split: bool.split_asm)

lemma gamma_Step_subcomm: fixes C1 C2 :: "'a::semilattice_sup acom"
  assumes "!!x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"
          "!!b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
proof(induction C arbitrary: S)
qed (auto simp: assms intro!: mono_gamma_o sup_ge1 sup_ge2)

lemma in_gamma_update: "\<lbrakk> s \<in> \<gamma>\<^sub>s S; i \<in> \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) \<in> \<gamma>\<^sub>s(update S x a)"
by(simp add: \<gamma>_st_def)

end

locale Abs_Int = Gamma_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

definition "step' = Step
  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S' \<Rightarrow> Some(update S' x (aval' e S')))
  (\<lambda>b S. case S of None \<Rightarrow> None |
    Some S' \<Rightarrow> (case bval' b S' of Some False \<Rightarrow> None | _ \<Rightarrow> Some S'))"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

lemma strip_step'[simp]: "strip(step' S C) = strip C"
by(simp add: step'_def)

text\<open>Correctness:\<close>

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
proof (rule gamma_Step_subcomm, auto simp: intro!: aval'_correct in_gamma_update split: option.splits bool.splits)
  fix b s S
  assume "s \<in> \<gamma>\<^sub>s S"
  then have "bval' b S = None \<or> bval' b S = Some (bval b s)" by (simp add: bval'_correct)
  moreover assume "bval' b S = Some False"
  ultimately have "\<not>bval b s" by auto
  moreover assume "bval b s"
  ultimately show False by auto
qed

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

end


(* Title:  Digraph.thy
   Author: Lars Noschinski, TU München
   Author: René Neumann
*)

theory Digraph
imports
  Main
  Rtrancl_On
  Stuff
begin

section \<open>Digraphs\<close>

record ('a,'b) pre_digraph =
  verts :: "'a set"
  arcs :: "'b set"
  tail :: "'b \<Rightarrow> 'a"
  head :: "'b \<Rightarrow> 'a"

definition arc_to_ends :: "('a,'b) pre_digraph \<Rightarrow> 'b \<Rightarrow> 'a \<times> 'a" where
  "arc_to_ends G e \<equiv> (tail G e, head G e)"

locale pre_digraph =
  fixes G :: "('a, 'b) pre_digraph" (structure)

locale wf_digraph = pre_digraph +
  assumes tail_in_verts[simp]: "e \<in> arcs G \<Longrightarrow> tail G e \<in> verts G"
  assumes head_in_verts[simp]: "e \<in> arcs G \<Longrightarrow> head G e \<in> verts G"
begin

lemma wf_digraph: "wf_digraph G" by intro_locales

lemmas wellformed = tail_in_verts head_in_verts

end

definition arcs_ends :: "('a,'b) pre_digraph \<Rightarrow> ('a \<times> 'a) set" where
  "arcs_ends G \<equiv> arc_to_ends G ` arcs G"

definition symmetric :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "symmetric G \<equiv> sym (arcs_ends G)"

text \<open>
  Matches "pseudo digraphs" from \<^cite>\<open>"bangjensen2009digraphs"\<close>, except for
  allowing the null graph. For a discussion of that topic,
  see also \<^cite>\<open>"harary1974nullgraph"\<close>.
\<close>
locale fin_digraph = wf_digraph +
  assumes finite_verts[simp]: "finite (verts G)"
    and finite_arcs[simp]: "finite (arcs G)"

locale loopfree_digraph = wf_digraph +
  assumes no_loops: "e \<in> arcs G \<Longrightarrow> tail G e \<noteq> head G e"

locale nomulti_digraph = wf_digraph +
  assumes no_multi_arcs: "\<And>e1 e2. \<lbrakk>e1 \<in> arcs G; e2 \<in> arcs G;
     arc_to_ends G e1 = arc_to_ends G e2\<rbrakk> \<Longrightarrow> e1 = e2"

locale sym_digraph = wf_digraph +
  assumes sym_arcs[intro]: "symmetric G"

locale digraph = fin_digraph + loopfree_digraph + nomulti_digraph

text \<open>
  We model graphs as symmetric digraphs. This is fine for many purposes,
  but not for all. For example, the path $a,b,a$ is considered to be a cycle
  in a digraph (and hence in a symmetric digraph), but not in an undirected
  graph.
\<close>
locale pseudo_graph = fin_digraph + sym_digraph

locale graph = digraph + pseudo_graph

lemma (in wf_digraph) fin_digraphI[intro]:
  assumes "finite (verts G)"
  assumes "finite (arcs G)"
  shows "fin_digraph G"
using assms by unfold_locales

lemma (in wf_digraph) sym_digraphI[intro]:
  assumes "symmetric G"
  shows "sym_digraph G"
using assms by unfold_locales

lemma (in digraph) graphI[intro]:
  assumes "symmetric G"
  shows "graph G"
using assms by unfold_locales

definition (in wf_digraph) arc :: "'b \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where
  "arc e uv \<equiv> e \<in> arcs G \<and> tail G e = fst uv \<and> head G e = snd uv"

lemma (in fin_digraph) fin_digraph: "fin_digraph G"
  by unfold_locales

lemma (in nomulti_digraph) nomulti_digraph: "nomulti_digraph G" by unfold_locales

lemma arcs_ends_conv: "arcs_ends G = (\<lambda>e. (tail G e, head G e)) ` arcs G"
  by (auto simp: arc_to_ends_def arcs_ends_def)

lemma symmetric_conv: "symmetric G \<longleftrightarrow> (\<forall>e1 \<in> arcs G. \<exists>e2 \<in> arcs G. tail G e1 = head G e2 \<and> head G e1 = tail G e2)"
  unfolding symmetric_def arcs_ends_conv sym_def by auto

lemma arcs_ends_symmetric:
  assumes "symmetric G"
  shows "(u,v) \<in> arcs_ends G \<Longrightarrow> (v,u) \<in> arcs_ends G"
  using assms unfolding symmetric_def sym_def by auto

lemma (in nomulti_digraph) inj_on_arc_to_ends:
  "inj_on (arc_to_ends G) (arcs G)"
  by (rule inj_onI) (rule no_multi_arcs)

subsection \<open>Reachability\<close>

abbreviation dominates :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<rightarrow>\<index> _" [100,100] 40) where
  "dominates G u v \<equiv> (u,v) \<in> arcs_ends G"

abbreviation reachable1 :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<rightarrow>\<^sup>+\<index> _" [100,100] 40) where
  "reachable1 G u v \<equiv> (u,v) \<in> (arcs_ends G)^+"

definition reachable :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<rightarrow>\<^sup>*\<index> _" [100,100] 40) where
  "reachable G u v \<equiv> (u,v) \<in> rtrancl_on (verts G) (arcs_ends G)"

lemma reachableE[elim]:
  assumes "u \<rightarrow>\<^bsub>G\<^esub> v"
  obtains e where "e \<in> arcs G" "tail G e = u" "head G e = v"
using assms by (auto simp add: arcs_ends_conv)

lemma (in loopfree_digraph) adj_not_same:
  assumes "a \<rightarrow> a" shows "False"
  using assms by (rule reachableE) (auto dest: no_loops)

lemma reachable_in_vertsE:
  assumes "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v" obtains "u \<in> verts G" "v \<in> verts G"
  using assms unfolding reachable_def by induct auto

lemma reachable_rtranclI:
  "u \<rightarrow>\<^sup>*\<^bsub>G \<^esub> v \<Longrightarrow> (u, v) \<in> (arcs_ends G)\<^sup>*"
  unfolding reachable_def by (rule rtrancl_on_rtranclI)

context wf_digraph begin

lemma adj_in_verts:
  assumes "u \<rightarrow>\<^bsub>G\<^esub> v" shows "u \<in> verts G" "v \<in> verts G"
  using assms unfolding arcs_ends_conv by auto

lemma dominatesI: assumes "arc_to_ends G a = (u,v)" "a \<in> arcs G" shows "u \<rightarrow>\<^bsub>G\<^esub> v"
  using assms by (auto simp: arcs_ends_def intro: rev_image_eqI)

lemma reachable_refl [intro!, Pure.intro!, simp]: "v \<in> verts G \<Longrightarrow> v \<rightarrow>\<^sup>* v"
  unfolding reachable_def by auto

lemma adj_reachable_trans[trans]:
  assumes "a \<rightarrow>\<^bsub>G\<^esub> b" "b \<rightarrow>\<^sup>*\<^bsub>G\<^esub> c" shows "a \<rightarrow>\<^sup>*\<^bsub>G\<^esub> c"
  using assms by (auto simp: reachable_def intro: converse_rtrancl_on_into_rtrancl_on adj_in_verts)

lemma reachable_adj_trans[trans]:
  assumes "a \<rightarrow>\<^sup>*\<^bsub>G\<^esub> b" "b \<rightarrow>\<^bsub>G\<^esub> c" shows "a \<rightarrow>\<^sup>*\<^bsub>G\<^esub> c"
  using assms by (auto simp: reachable_def intro: rtrancl_on_into_rtrancl_on adj_in_verts)

lemma reachable_adjI [intro, simp]: "u \<rightarrow> v \<Longrightarrow> u \<rightarrow>\<^sup>* v"
  by (auto intro: adj_reachable_trans adj_in_verts)

lemma reachable_trans[trans]:
  assumes "u \<rightarrow>\<^sup>*v" "v \<rightarrow>\<^sup>* w" shows "u \<rightarrow>\<^sup>* w"
  using assms unfolding reachable_def by (rule rtrancl_on_trans)

lemma reachable_induct[consumes 1, case_names base step]:
  assumes major: "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
    and cases: "u \<in> verts G \<Longrightarrow> P u"
       "\<And>x y. \<lbrakk>u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x; x \<rightarrow>\<^bsub>G\<^esub> y; P x\<rbrakk> \<Longrightarrow> P y"
  shows "P v"
  using assms unfolding reachable_def by (rule rtrancl_on_induct) auto

lemma converse_reachable_induct[consumes 1, case_names base step, induct pred: reachable]:
  assumes major: "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
    and cases: "v \<in> verts G \<Longrightarrow> P v"
       "\<And>x y. \<lbrakk>x \<rightarrow>\<^bsub>G\<^esub> y; y \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v; P y\<rbrakk> \<Longrightarrow> P x"
  shows "P u"
  using assms unfolding reachable_def by (rule converse_rtrancl_on_induct) auto

lemma (in pre_digraph) converse_reachable_cases:
  assumes "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  obtains (base) "u = v" "u \<in> verts G"
    | (step) w where "u \<rightarrow>\<^bsub>G\<^esub> w" "w \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  using assms unfolding reachable_def by (cases rule: converse_rtrancl_on_cases) auto

lemma reachable_in_verts:
  assumes "u \<rightarrow>\<^sup>* v" shows "u \<in> verts G" "v \<in> verts G"
  using assms by induct (simp_all add: adj_in_verts)

lemma reachable1_in_verts:
  assumes "u \<rightarrow>\<^sup>+ v" shows "u \<in> verts G" "v \<in> verts G"
  using assms
  by induct (simp_all add: adj_in_verts)

lemma reachable1_reachable[intro]:
  "v \<rightarrow>\<^sup>+ w \<Longrightarrow> v \<rightarrow>\<^sup>* w"
  unfolding reachable_def
  by (rule rtrancl_consistent_rtrancl_on) (simp_all add: reachable1_in_verts adj_in_verts)

lemmas reachable1_reachableE[elim] = reachable1_reachable[elim_format]

lemma reachable_neq_reachable1[intro]:
  assumes reach: "v \<rightarrow>\<^sup>* w"
  and neq: "v \<noteq> w"
  shows "v \<rightarrow>\<^sup>+ w"
proof -
  from reach have "(v,w) \<in> (arcs_ends G)^*" by (rule reachable_rtranclI)
  with neq show ?thesis by (auto dest: rtranclD)
qed

lemmas reachable_neq_reachable1E[elim] = reachable_neq_reachable1[elim_format]

lemma reachable1_reachable_trans [trans]:
  "u \<rightarrow>\<^sup>+ v \<Longrightarrow> v \<rightarrow>\<^sup>* w \<Longrightarrow> u \<rightarrow>\<^sup>+ w"
by (metis trancl_trans reachable_neq_reachable1)

lemma reachable_reachable1_trans [trans]:
  "u \<rightarrow>\<^sup>* v \<Longrightarrow> v \<rightarrow>\<^sup>+ w \<Longrightarrow> u \<rightarrow>\<^sup>+ w"
by (metis trancl_trans reachable_neq_reachable1)

lemma reachable_conv:
  "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (u,v) \<in> (arcs_ends G)^* \<inter> (verts G \<times> verts G)"
  apply (auto intro: reachable_in_verts)
  apply (induct rule: rtrancl_induct)
   apply auto
  done

lemma reachable_conv':
  assumes "u \<in> verts G"
  shows "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (u,v) \<in> (arcs_ends G)\<^sup>*" (is "?L = ?R")
proof
  assume "?R" then show "?L" using assms  by induct auto
qed (auto simp: reachable_conv)

end

lemma (in sym_digraph) symmetric_reachable':
  assumes "v \<rightarrow>\<^sup>*\<^bsub>G\<^esub> w" shows "w \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  using sym_arcs assms by (rule symmetric_reachable)

subsection \<open>Degrees of vertices\<close>

definition in_arcs :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b set" where
  "in_arcs G v \<equiv> {e \<in> arcs G. head G e = v}"

definition out_arcs :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b set" where
  "out_arcs G v \<equiv> {e \<in> arcs G. tail G e = v}"

definition in_degree :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> nat" where
  "in_degree G v \<equiv> card (in_arcs G v)"

definition out_degree :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> nat" where
  "out_degree G v \<equiv> card (out_arcs G v)"

lemma (in fin_digraph) finite_in_arcs[intro]:
  "finite (in_arcs G v)"
  unfolding in_arcs_def by auto

lemma (in fin_digraph) finite_out_arcs[intro]:
  "finite (out_arcs G v)"
  unfolding out_arcs_def by auto

lemma in_in_arcs_conv[simp]:
  "e \<in> in_arcs G v \<longleftrightarrow> e \<in> arcs G \<and> head G e = v"
  unfolding in_arcs_def by auto

lemma in_out_arcs_conv[simp]:
  "e \<in> out_arcs G v \<longleftrightarrow> e \<in> arcs G \<and> tail G e = v"
  unfolding out_arcs_def by auto

lemma inout_arcs_arc_simps[simp]:
  assumes "e \<in> arcs G"
  shows "tail G e = u \<Longrightarrow> out_arcs G u \<inter> insert e E = insert e (out_arcs G u \<inter> E)"
        "tail G e \<noteq> u \<Longrightarrow> out_arcs G u \<inter> insert e E = out_arcs G u \<inter> E"
        "out_arcs G u \<inter> {} = {}" (* XXX: should be unnecessary *)
        "head G e = u \<Longrightarrow> in_arcs G u \<inter> insert e E = insert e (in_arcs G u \<inter> E)"
        "head G e \<noteq> u \<Longrightarrow> in_arcs G u \<inter> insert e E = in_arcs G u \<inter> E"
        "in_arcs G u \<inter> {} = {}" (* XXX: should be unnecessary *)
  using assms by auto

lemma in_arcs_int_arcs[simp]: "in_arcs G u \<inter> arcs G = in_arcs G u" and
      out_arcs_int_arcs[simp]: "out_arcs G u \<inter> arcs G = out_arcs G u"
  by auto

lemma in_arcs_in_arcs: "x \<in> in_arcs G u \<Longrightarrow> x \<in> arcs G"
  and out_arcs_in_arcs: "x \<in> out_arcs G u \<Longrightarrow> x \<in> arcs G"
  by (auto simp: in_arcs_def out_arcs_def)

subsection \<open>Graph operations\<close>

context pre_digraph begin

definition add_arc :: "'b \<Rightarrow>  ('a,'b) pre_digraph" where
  "add_arc a = \<lparr> verts = verts G \<union> {tail G a, head G a}, arcs = insert a (arcs G), tail = tail G, head = head G \<rparr>"

definition  del_arc :: "'b \<Rightarrow> ('a,'b) pre_digraph" where
  "del_arc a = \<lparr> verts = verts G, arcs = arcs G - {a}, tail = tail G, head = head G \<rparr>"

definition add_vert :: "'a \<Rightarrow>  ('a,'b) pre_digraph" where
  "add_vert v = \<lparr> verts = insert v (verts G), arcs = arcs G, tail = tail G, head = head G \<rparr>"

definition del_vert :: "'a \<Rightarrow>  ('a,'b) pre_digraph" where
  "del_vert v = \<lparr> verts = verts G - {v}, arcs = {a \<in> arcs G. tail G a \<noteq> v \<and> head G a \<noteq> v}, tail = tail G, head = head G \<rparr>"

lemma
  verts_add_arc: "\<lbrakk> tail G a \<in> verts G; head G a \<in> verts G \<rbrakk> \<Longrightarrow> verts (add_arc a) = verts G"  and
  verts_add_arc_conv: "verts (add_arc a) = verts G \<union> {tail G a, head G a}" and
  arcs_add_arc: "arcs (add_arc a) = insert a (arcs G)" and
  tail_add_arc: "tail (add_arc a) = tail G" and
  head_add_arc: "head (add_arc a) = head G"
  by (auto simp: add_arc_def)

lemmas add_arc_simps[simp] = verts_add_arc arcs_add_arc tail_add_arc head_add_arc

lemma
  verts_del_arc: "verts (del_arc a) = verts G"  and
  arcs_del_arc: "arcs (del_arc a) = arcs G - {a}" and
  tail_del_arc: "tail (del_arc a) = tail G" and
  head_del_arc: "head (del_arc a) = head G"
  by (auto simp: del_arc_def)

lemmas del_arc_simps[simp] = verts_del_arc arcs_del_arc tail_del_arc head_del_arc

lemma
    verts_add_vert: "verts (pre_digraph.add_vert G u) = insert u (verts G)" and
    arcs_add_vert: "arcs (pre_digraph.add_vert G u) = arcs G" and
    tail_add_vert: "tail (pre_digraph.add_vert G u) = tail G" and
    head_add_vert: "head (pre_digraph.add_vert G u) = head G"
  by (auto simp: pre_digraph.add_vert_def)

lemmas add_vert_simps = verts_add_vert arcs_add_vert tail_add_vert head_add_vert

lemma
    verts_del_vert: "verts (pre_digraph.del_vert G u) = verts G - {u}" and
    arcs_del_vert: "arcs (pre_digraph.del_vert G u) = {a \<in> arcs G. tail G a \<noteq> u \<and> head G a \<noteq> u}" and
    tail_del_vert: "tail (pre_digraph.del_vert G u) = tail G" and
    head_del_vert: "head (pre_digraph.del_vert G u) = head G" and
    ends_del_vert: "arc_to_ends (pre_digraph.del_vert G u) = arc_to_ends G"
  by (auto simp: pre_digraph.del_vert_def arc_to_ends_def)

lemmas del_vert_simps = verts_del_vert arcs_del_vert tail_del_vert head_del_vert

lemma add_add_arc_collapse[simp]: "pre_digraph.add_arc (add_arc a) a = add_arc a"
  by (auto simp: pre_digraph.add_arc_def)

lemma add_del_arc_collapse[simp]: "pre_digraph.add_arc (del_arc a) a = add_arc a"
  by (auto simp: pre_digraph.verts_add_arc_conv pre_digraph.add_arc_simps)

lemma del_add_arc_collapse[simp]:
  "\<lbrakk> tail G a \<in> verts G; head G a \<in> verts G \<rbrakk> \<Longrightarrow> pre_digraph.del_arc (add_arc a) a = del_arc a"
  by (auto simp: pre_digraph.add_arc_simps pre_digraph.del_arc_simps)

lemma del_del_arc_collapse[simp]: "pre_digraph.del_arc (del_arc a) a = del_arc a"
  by (auto simp: pre_digraph.add_arc_simps pre_digraph.del_arc_simps)

lemma add_arc_commute: "pre_digraph.add_arc (add_arc b) a = pre_digraph.add_arc (add_arc a) b"
  by (auto simp: pre_digraph.add_arc_def)

lemma del_arc_commute: "pre_digraph.del_arc (del_arc b) a = pre_digraph.del_arc (del_arc a) b"
  by (auto simp: pre_digraph.del_arc_def)

lemma del_arc_in: "a \<notin> arcs G \<Longrightarrow> del_arc a = G"
  by (rule pre_digraph.equality) (auto simp: add_arc_def)

lemma in_arcs_add_arc_iff:
  "in_arcs (add_arc a) u = (if head G a = u then insert a (in_arcs G u) else in_arcs G u)"
  by auto

lemma out_arcs_add_arc_iff:
  "out_arcs (add_arc a) u = (if tail G a = u then insert a (out_arcs G u) else out_arcs G u)"
  by auto

lemma in_arcs_del_arc_iff:
  "in_arcs (del_arc a) u = (if head G a = u then in_arcs G u - {a} else in_arcs G u)"
  by auto

lemma out_arcs_del_arc_iff:
  "out_arcs (del_arc a) u = (if tail G a = u then out_arcs G u - {a} else out_arcs G u)"
  by auto

lemma (in wf_digraph) add_arc_in: "a \<in> arcs G \<Longrightarrow> add_arc a = G"
  by (rule pre_digraph.equality) (auto simp: add_arc_def)

end

context wf_digraph begin

lemma wf_digraph_add_arc[intro]:
  "wf_digraph (add_arc a)" by unfold_locales (auto simp: verts_add_arc_conv)

lemma wf_digraph_del_arc[intro]:
  "wf_digraph (del_arc a)" by unfold_locales (auto simp: verts_add_arc_conv)

lemma wf_digraph_del_vert: "wf_digraph (del_vert u)"
  by standard (auto simp: del_vert_simps)

lemma wf_digraph_add_vert: "wf_digraph (add_vert u)"
  by standard (auto simp: add_vert_simps)

lemma del_vert_add_vert:
  assumes "u \<notin> verts G"
  shows "pre_digraph.del_vert (add_vert u) u = G"
  using assms by (intro pre_digraph.equality) (auto simp: pre_digraph.del_vert_def add_vert_def)

end

context fin_digraph begin

lemma in_degree_add_arc_iff:
  "in_degree (add_arc a) u = (if head G a = u \<and> a \<notin> arcs G then in_degree G u + 1 else in_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> in_arcs G u" by (auto simp: in_arcs_def)
  with finite_in_arcs show ?thesis
    unfolding in_degree_def by (auto simp: in_arcs_add_arc_iff intro: arg_cong[where f=card])
qed

lemma out_degree_add_arc_iff:
  "out_degree (add_arc a) u = (if tail G a = u \<and> a \<notin> arcs G then out_degree G u + 1 else out_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> out_arcs G u" by (auto simp: out_arcs_def)
  with finite_out_arcs show ?thesis
    unfolding out_degree_def by (auto simp: out_arcs_add_arc_iff intro: arg_cong[where f=card])
qed

lemma in_degree_del_arc_iff:
  "in_degree (del_arc a) u = (if head G a = u \<and> a \<in> arcs G then in_degree G u - 1 else in_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> in_arcs G u" by (auto simp: in_arcs_def)
  with finite_in_arcs show ?thesis
    unfolding in_degree_def by (auto simp: in_arcs_del_arc_iff intro: arg_cong[where f=card])
qed

lemma out_degree_del_arc_iff:
  "out_degree (del_arc a) u = (if tail G a = u \<and> a \<in> arcs G then out_degree G u - 1 else out_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> out_arcs G u" by (auto simp: out_arcs_def)
  with finite_out_arcs show ?thesis
    unfolding out_degree_def by (auto simp: out_arcs_del_arc_iff intro: arg_cong[where f=card])
qed

lemma fin_digraph_del_vert: "fin_digraph (del_vert u)"
  by standard (auto simp: del_vert_simps)

lemma fin_digraph_del_arc: "fin_digraph (del_arc a)"
  by standard (auto simp: del_vert_simps)

end

end


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

(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Equivalence between Separation Algebra Formulations"

theory Sep_Eq
imports
  Separation_Algebra
  Separation_Algebra_Alt
begin

text \<open>
  In this theory we show that our total formulation of separation algebra is
  equivalent in strength to Calcagno et al's original partial one.

  This theory is not intended to be included in own developments.
\<close>

no_notation map_add (infixl "++" 100)
declare [[syntax_ambiguity_warning = false]]

section "Total implies Partial"

definition add2 :: "'a::sep_algebra => 'a => 'a option" where
  "add2 x y \<equiv> if x ## y then Some (x + y) else None"

lemma add2_zero: "add2 x 0 = Some x"
  by (simp add: add2_def)

lemma add2_assoc:
  "lift2 add2 a (lift2 add2 b c) = lift2 add2 (lift2 add2 a b) c"
  by (auto simp: add2_def lift2_def sep_add_assoc
              dest: sep_disj_addD sep_disj_addI3
                    sep_add_disjD sep_disj_addI2 sep_disj_commuteI
              split: option.splits)

interpretation total_partial: sep_algebra_alt 0 add2
  by (unfold_locales) (auto intro: add2_zero add2_comm add2_assoc)

section "Partial implies Total"

definition
  sep_add' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a :: sep_algebra_alt" where
  "sep_add' x y \<equiv> if disjoint x y then the (add x y) else undefined"

lemma sep_disj_zero':
  "disjoint x 0"
  by simp

lemma sep_disj_commuteI':
  "disjoint x y \<Longrightarrow> disjoint y x"
  by (clarsimp simp: disjoint_def add_comm)

lemma sep_add_zero':
  "sep_add' x 0 = x"
  by (simp add: sep_add'_def)

lemma sep_add_commute':
  "disjoint x y \<Longrightarrow> sep_add' x y = sep_add' y x"
  by (clarsimp simp: sep_add'_def disjoint_def add_comm)

lemma sep_add_assoc':
  "\<lbrakk> disjoint x y; disjoint y z; disjoint x z \<rbrakk> \<Longrightarrow>
  sep_add' (sep_add' x y) z = sep_add' x (sep_add' y z)"
  using add_assoc [of "Some x" "Some y" "Some z"]
  by (clarsimp simp: disjoint_def sep_add'_def lift2_def
               split: option.splits)

lemma sep_disj_addD1':
  "disjoint x (sep_add' y z) \<Longrightarrow> disjoint y z \<Longrightarrow> disjoint x y"
proof (clarsimp simp: disjoint_def sep_add'_def)
  fix a assume a: "y \<oplus> z = Some a"
  fix b assume b: "x \<oplus> a = Some b"
  with a have "Some x ++ (Some y ++ Some z) = Some b" by (simp add: lift2_def)
  hence "(Some x ++ Some y) ++ Some z = Some b" by (simp add: add_assoc)
  thus "\<exists>b. x \<oplus> y = Some b" by (simp add: lift2_def split: option.splits)
qed

lemma sep_disj_addI1':
  "disjoint x (sep_add' y z) \<Longrightarrow> disjoint y z \<Longrightarrow> disjoint (sep_add' x y) z"
  apply (clarsimp simp: disjoint_def sep_add'_def)
  apply (rule conjI)
   apply clarsimp
   apply (frule lift_to_add2, assumption)
   apply (simp add: add_assoc)
   apply (clarsimp simp: lift2_def add_comm)
  apply clarsimp
  apply (frule lift_to_add2, assumption)
  apply (simp add: add_assoc)
  apply (clarsimp simp: lift2_def)
  done

interpretation partial_total: sep_algebra sep_add' 0 disjoint
  apply (unfold_locales)
        apply (rule sep_disj_zero')
       apply (erule sep_disj_commuteI')
      apply (rule sep_add_zero')
     apply (erule sep_add_commute')
    apply (erule (2) sep_add_assoc')
   apply (erule (1) sep_disj_addD1')
  apply (erule (1) sep_disj_addI1')
  done

end


(*  Title:      HOL/Library/AList.thy
    Author:     Norbert Schirmer, Tobias Nipkow, Martin Wildmoser, TU Muenchen
*)

section {* Implementation of Association Lists *}

theory AList
imports Main
begin

text {*
  The operations preserve distinctness of keys and
  function @{term "clearjunk"} distributes over them. Since
  @{term clearjunk} enforces distinctness of keys it can be used
  to establish the invariant, e.g. for inductive proofs.
*}

subsection {* @{text update} and @{text updates} *}

primrec update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "update k v [] = [(k, v)]"
| "update k v (p # ps) = (if fst p = k then (k, v) # ps else p # update k v ps)"

lemma update_conv': "map_of (update k v al)  = (map_of al)(k\<mapsto>v)"
  by (induct al) (auto simp add: fun_eq_iff)

corollary update_conv: "map_of (update k v al) k' = ((map_of al)(k\<mapsto>v)) k'"
  by (simp add: update_conv')

lemma dom_update: "fst ` set (update k v al) = {k} \<union> fst ` set al"
  by (induct al) auto

lemma update_keys:
  "map fst (update k v al) =
    (if k \<in> set (map fst al) then map fst al else map fst al @ [k])"
  by (induct al) simp_all

lemma distinct_update:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (update k v al))"
  using assms by (simp add: update_keys)

lemma update_filter:
  "a \<noteq> k \<Longrightarrow> update k v [q\<leftarrow>ps. fst q \<noteq> a] = [q\<leftarrow>update k v ps. fst q \<noteq> a]"
  by (induct ps) auto

lemma update_triv: "map_of al k = Some v \<Longrightarrow> update k v al = al"
  by (induct al) auto

lemma update_nonempty [simp]: "update k v al \<noteq> []"
  by (induct al) auto

lemma update_eqD: "update k v al = update k v' al' \<Longrightarrow> v = v'"
proof (induct al arbitrary: al')
  case Nil
  then show ?case
    by (cases al') (auto split: split_if_asm)
next
  case Cons
  then show ?case
    by (cases al') (auto split: split_if_asm)
qed

lemma update_last [simp]: "update k v (update k v' al) = update k v al"
  by (induct al) auto

text {* Note that the lists are not necessarily the same:
        @{term "update k v (update k' v' []) = [(k', v'), (k, v)]"} and
        @{term "update k' v' (update k v []) = [(k, v), (k', v')]"}.*}

lemma update_swap:
  "k \<noteq> k' \<Longrightarrow>
    map_of (update k v (update k' v' al)) = map_of (update k' v' (update k v al))"
  by (simp add: update_conv' fun_eq_iff)

lemma update_Some_unfold:
  "map_of (update k v al) x = Some y \<longleftrightarrow>
    x = k \<and> v = y \<or> x \<noteq> k \<and> map_of al x = Some y"
  by (simp add: update_conv' map_upd_Some_unfold)

lemma image_update [simp]:
  "x \<notin> A \<Longrightarrow> map_of (update x y al) ` A = map_of al ` A"
  by (simp add: update_conv')

definition updates :: "'key list \<Rightarrow> 'val list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "updates ks vs = fold (case_prod update) (zip ks vs)"

lemma updates_simps [simp]:
  "updates [] vs ps = ps"
  "updates ks [] ps = ps"
  "updates (k#ks) (v#vs) ps = updates ks vs (update k v ps)"
  by (simp_all add: updates_def)

lemma updates_key_simp [simp]:
  "updates (k # ks) vs ps =
    (case vs of [] \<Rightarrow> ps | v # vs \<Rightarrow> updates ks vs (update k v ps))"
  by (cases vs) simp_all

lemma updates_conv': "map_of (updates ks vs al) = (map_of al)(ks[\<mapsto>]vs)"
proof -
  have "map_of \<circ> fold (case_prod update) (zip ks vs) =
      fold (\<lambda>(k, v) f. f(k \<mapsto> v)) (zip ks vs) \<circ> map_of"
    by (rule fold_commute) (auto simp add: fun_eq_iff update_conv')
  then show ?thesis
    by (auto simp add: updates_def fun_eq_iff map_upds_fold_map_upd foldl_conv_fold split_def)
qed

lemma updates_conv: "map_of (updates ks vs al) k = ((map_of al)(ks[\<mapsto>]vs)) k"
  by (simp add: updates_conv')

lemma distinct_updates:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (updates ks vs al))"
proof -
  have "distinct (fold
       (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k])
       (zip ks vs) (map fst al))"
    by (rule fold_invariant [of "zip ks vs" "\<lambda>_. True"]) (auto intro: assms)
  moreover have "map fst \<circ> fold (case_prod update) (zip ks vs) =
      fold (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k]) (zip ks vs) \<circ> map fst"
    by (rule fold_commute) (simp add: update_keys split_def case_prod_beta comp_def)
  ultimately show ?thesis
    by (simp add: updates_def fun_eq_iff)
qed

lemma updates_append1[simp]: "size ks < size vs \<Longrightarrow>
    updates (ks@[k]) vs al = update k (vs!size ks) (updates ks vs al)"
  by (induct ks arbitrary: vs al) (auto split: list.splits)

lemma updates_list_update_drop[simp]:
  "size ks \<le> i \<Longrightarrow> i < size vs \<Longrightarrow>
    updates ks (vs[i:=v]) al = updates ks vs al"
  by (induct ks arbitrary: al vs i) (auto split: list.splits nat.splits)

lemma update_updates_conv_if:
  "map_of (updates xs ys (update x y al)) =
    map_of
     (if x \<in> set (take (length ys) xs)
      then updates xs ys al
      else (update x y (updates xs ys al)))"
  by (simp add: updates_conv' update_conv' map_upd_upds_conv_if)

lemma updates_twist [simp]:
  "k \<notin> set ks \<Longrightarrow>
    map_of (updates ks vs (update k v al)) = map_of (update k v (updates ks vs al))"
  by (simp add: updates_conv' update_conv')

lemma updates_apply_notin [simp]:
  "k \<notin> set ks \<Longrightarrow> map_of (updates ks vs al) k = map_of al k"
  by (simp add: updates_conv)

lemma updates_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> updates (xs @ zs) ys al = updates xs ys al"
  by (induct xs arbitrary: ys al) (auto split: list.splits)

lemma updates_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> updates xs (ys @ zs) al = updates xs ys al"
  by (induct xs arbitrary: ys al) (auto split: list.splits)

subsection {* @{text delete} *}

definition delete :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where delete_eq: "delete k = filter (\<lambda>(k', _). k \<noteq> k')"

lemma delete_simps [simp]:
  "delete k [] = []"
  "delete k (p # ps) = (if fst p = k then delete k ps else p # delete k ps)"
  by (auto simp add: delete_eq)

lemma delete_conv': "map_of (delete k al) = (map_of al)(k := None)"
  by (induct al) (auto simp add: fun_eq_iff)

corollary delete_conv: "map_of (delete k al) k' = ((map_of al)(k := None)) k'"
  by (simp add: delete_conv')

lemma delete_keys: "map fst (delete k al) = removeAll k (map fst al)"
  by (simp add: delete_eq removeAll_filter_not_eq filter_map split_def comp_def)

lemma distinct_delete:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (delete k al))"
  using assms by (simp add: delete_keys distinct_removeAll)

lemma delete_id [simp]: "k \<notin> fst ` set al \<Longrightarrow> delete k al = al"
  by (auto simp add: image_iff delete_eq filter_id_conv)

lemma delete_idem: "delete k (delete k al) = delete k al"
  by (simp add: delete_eq)

lemma map_of_delete [simp]: "k' \<noteq> k \<Longrightarrow> map_of (delete k al) k' = map_of al k'"
  by (simp add: delete_conv')

lemma delete_notin_dom: "k \<notin> fst ` set (delete k al)"
  by (auto simp add: delete_eq)

lemma dom_delete_subset: "fst ` set (delete k al) \<subseteq> fst ` set al"
  by (auto simp add: delete_eq)

lemma delete_update_same: "delete k (update k v al) = delete k al"
  by (induct al) simp_all

lemma delete_update: "k \<noteq> l \<Longrightarrow> delete l (update k v al) = update k v (delete l al)"
  by (induct al) simp_all

lemma delete_twist: "delete x (delete y al) = delete y (delete x al)"
  by (simp add: delete_eq conj_commute)

lemma length_delete_le: "length (delete k al) \<le> length al"
  by (simp add: delete_eq)

subsection {* @{text restrict} *}

definition restrict :: "'key set \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where restrict_eq: "restrict A = filter (\<lambda>(k, v). k \<in> A)"

lemma restr_simps [simp]:
  "restrict A [] = []"
  "restrict A (p#ps) = (if fst p \<in> A then p # restrict A ps else restrict A ps)"
  by (auto simp add: restrict_eq)

lemma restr_conv': "map_of (restrict A al) = ((map_of al)|` A)"
proof
  fix k
  show "map_of (restrict A al) k = ((map_of al)|` A) k"
    by (induct al) (simp, cases "k \<in> A", auto)
qed

corollary restr_conv: "map_of (restrict A al) k = ((map_of al)|` A) k"
  by (simp add: restr_conv')

lemma distinct_restr:
  "distinct (map fst al) \<Longrightarrow> distinct (map fst (restrict A al))"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_empty [simp]:
  "restrict {} al = []"
  "restrict A [] = []"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_in [simp]: "x \<in> A \<Longrightarrow> map_of (restrict A al) x = map_of al x"
  by (simp add: restr_conv')

lemma restr_out [simp]: "x \<notin> A \<Longrightarrow> map_of (restrict A al) x = None"
  by (simp add: restr_conv')

lemma dom_restr [simp]: "fst ` set (restrict A al) = fst ` set al \<inter> A"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_upd_same [simp]: "restrict (-{x}) (update x y al) = restrict (-{x}) al"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_restr [simp]: "restrict A (restrict B al) = restrict (A\<inter>B) al"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_update[simp]:
 "map_of (restrict D (update x y al)) =
  map_of ((if x \<in> D then (update x y (restrict (D-{x}) al)) else restrict D al))"
  by (simp add: restr_conv' update_conv')

lemma restr_delete [simp]:
  "delete x (restrict D al) = (if x \<in> D then restrict (D - {x}) al else restrict D al)"
  apply (simp add: delete_eq restrict_eq)
  apply (auto simp add: split_def)
proof -
  have "\<And>y. y \<noteq> x \<longleftrightarrow> x \<noteq> y"
    by auto
  then show "[p \<leftarrow> al. fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al. fst p \<in> D \<and> fst p \<noteq> x]"
    by simp
  assume "x \<notin> D"
  then have "\<And>y. y \<in> D \<longleftrightarrow> y \<in> D \<and> x \<noteq> y"
    by auto
  then show "[p \<leftarrow> al . fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al . fst p \<in> D]"
    by simp
qed

lemma update_restr:
  "map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
  by (simp add: update_conv' restr_conv') (rule fun_upd_restrict)

lemma update_restr_conv [simp]:
  "x \<in> D \<Longrightarrow>
    map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
  by (simp add: update_conv' restr_conv')

lemma restr_updates [simp]:
  "length xs = length ys \<Longrightarrow> set xs \<subseteq> D \<Longrightarrow>
    map_of (restrict D (updates xs ys al)) =
      map_of (updates xs ys (restrict (D - set xs) al))"
  by (simp add: updates_conv' restr_conv')

lemma restr_delete_twist: "(restrict A (delete a ps)) = delete a (restrict A ps)"
  by (induct ps) auto

subsection {* @{text clearjunk} *}

function clearjunk  :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "clearjunk [] = []"
| "clearjunk (p#ps) = p # clearjunk (delete (fst p) ps)"
  by pat_completeness auto
termination
  by (relation "measure length") (simp_all add: less_Suc_eq_le length_delete_le)

lemma map_of_clearjunk: "map_of (clearjunk al) = map_of al"
  by (induct al rule: clearjunk.induct) (simp_all add: fun_eq_iff)

lemma clearjunk_keys_set: "set (map fst (clearjunk al)) = set (map fst al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_keys)

lemma dom_clearjunk: "fst ` set (clearjunk al) = fst ` set al"
  using clearjunk_keys_set by simp

lemma distinct_clearjunk [simp]: "distinct (map fst (clearjunk al))"
  by (induct al rule: clearjunk.induct) (simp_all del: set_map add: clearjunk_keys_set delete_keys)

lemma ran_clearjunk: "ran (map_of (clearjunk al)) = ran (map_of al)"
  by (simp add: map_of_clearjunk)

lemma ran_map_of: "ran (map_of al) = snd ` set (clearjunk al)"
proof -
  have "ran (map_of al) = ran (map_of (clearjunk al))"
    by (simp add: ran_clearjunk)
  also have "\<dots> = snd ` set (clearjunk al)"
    by (simp add: ran_distinct)
  finally show ?thesis .
qed

lemma clearjunk_update: "clearjunk (update k v al) = update k v (clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_update)

lemma clearjunk_updates: "clearjunk (updates ks vs al) = updates ks vs (clearjunk al)"
proof -
  have "clearjunk \<circ> fold (case_prod update) (zip ks vs) =
    fold (case_prod update) (zip ks vs) \<circ> clearjunk"
    by (rule fold_commute) (simp add: clearjunk_update case_prod_beta o_def)
  then show ?thesis
    by (simp add: updates_def fun_eq_iff)
qed

lemma clearjunk_delete: "clearjunk (delete x al) = delete x (clearjunk al)"
  by (induct al rule: clearjunk.induct) (auto simp add: delete_idem delete_twist)

lemma clearjunk_restrict: "clearjunk (restrict A al) = restrict A (clearjunk al)"
  by (induct al rule: clearjunk.induct) (auto simp add: restr_delete_twist)

lemma distinct_clearjunk_id [simp]: "distinct (map fst al) \<Longrightarrow> clearjunk al = al"
  by (induct al rule: clearjunk.induct) auto

lemma clearjunk_idem: "clearjunk (clearjunk al) = clearjunk al"
  by simp

lemma length_clearjunk: "length (clearjunk al) \<le> length al"
proof (induct al rule: clearjunk.induct [case_names Nil Cons])
  case Nil
  then show ?case by simp
next
  case (Cons kv al)
  moreover have "length (delete (fst kv) al) \<le> length al"
    by (fact length_delete_le)
  ultimately have "length (clearjunk (delete (fst kv) al)) \<le> length al"
    by (rule order_trans)
  then show ?case
    by simp
qed

lemma delete_map:
  assumes "\<And>kv. fst (f kv) = fst kv"
  shows "delete k (map f ps) = map f (delete k ps)"
  by (simp add: delete_eq filter_map comp_def split_def assms)

lemma clearjunk_map:
  assumes "\<And>kv. fst (f kv) = fst kv"
  shows "clearjunk (map f ps) = map f (clearjunk ps)"
  by (induct ps rule: clearjunk.induct [case_names Nil Cons])
    (simp_all add: clearjunk_delete delete_map assms)

subsection {* @{text map_ran} *}

definition map_ran :: "('key \<Rightarrow> 'val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "map_ran f = map (\<lambda>(k, v). (k, f k v))"

lemma map_ran_simps [simp]:
  "map_ran f [] = []"
  "map_ran f ((k, v) # ps) = (k, f k v) # map_ran f ps"
  by (simp_all add: map_ran_def)

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (simp add: map_ran_def image_image split_def)

lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
  by (induct al) auto

lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
  by (simp add: map_ran_def split_def comp_def)

lemma map_ran_filter: "map_ran f [p\<leftarrow>ps. fst p \<noteq> a] = [p\<leftarrow>map_ran f ps. fst p \<noteq> a]"
  by (simp add: map_ran_def filter_map split_def comp_def)

lemma clearjunk_map_ran: "clearjunk (map_ran f al) = map_ran f (clearjunk al)"
  by (simp add: map_ran_def split_def clearjunk_map)

subsection {* @{text merge} *}

definition merge :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "merge qs ps = foldr (\<lambda>(k, v). update k v) ps qs"

lemma merge_simps [simp]:
  "merge qs [] = qs"
  "merge qs (p#ps) = update (fst p) (snd p) (merge qs ps)"
  by (simp_all add: merge_def split_def)

lemma merge_updates: "merge qs ps = updates (rev (map fst ps)) (rev (map snd ps)) qs"
  by (simp add: merge_def updates_def foldr_conv_fold zip_rev zip_map_fst_snd)

lemma dom_merge: "fst ` set (merge xs ys) = fst ` set xs \<union> fst ` set ys"
  by (induct ys arbitrary: xs) (auto simp add: dom_update)

lemma distinct_merge:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (merge xs ys))"
  using assms by (simp add: merge_updates distinct_updates)

lemma clearjunk_merge: "clearjunk (merge xs ys) = merge (clearjunk xs) ys"
  by (simp add: merge_updates clearjunk_updates)

lemma merge_conv': "map_of (merge xs ys) = map_of xs ++ map_of ys"
proof -
  have "map_of \<circ> fold (case_prod update) (rev ys) =
      fold (\<lambda>(k, v) m. m(k \<mapsto> v)) (rev ys) \<circ> map_of"
    by (rule fold_commute) (simp add: update_conv' case_prod_beta split_def fun_eq_iff)
  then show ?thesis
    by (simp add: merge_def map_add_map_of_foldr foldr_conv_fold fun_eq_iff)
qed

corollary merge_conv: "map_of (merge xs ys) k = (map_of xs ++ map_of ys) k"
  by (simp add: merge_conv')

lemma merge_empty: "map_of (merge [] ys) = map_of ys"
  by (simp add: merge_conv')

lemma merge_assoc [simp]: "map_of (merge m1 (merge m2 m3)) = map_of (merge (merge m1 m2) m3)"
  by (simp add: merge_conv')

lemma merge_Some_iff:
  "map_of (merge m n) k = Some x \<longleftrightarrow>
    map_of n k = Some x \<or> map_of n k = None \<and> map_of m k = Some x"
  by (simp add: merge_conv' map_add_Some_iff)

lemmas merge_SomeD [dest!] = merge_Some_iff [THEN iffD1]

lemma merge_find_right [simp]: "map_of n k = Some v \<Longrightarrow> map_of (merge m n) k = Some v"
  by (simp add: merge_conv')

lemma merge_None [iff]:
  "(map_of (merge m n) k = None) = (map_of n k = None \<and> map_of m k = None)"
  by (simp add: merge_conv')

lemma merge_upd [simp]:
  "map_of (merge m (update k v n)) = map_of (update k v (merge m n))"
  by (simp add: update_conv' merge_conv')

lemma merge_updatess [simp]:
  "map_of (merge m (updates xs ys n)) = map_of (updates xs ys (merge m n))"
  by (simp add: updates_conv' merge_conv')

lemma merge_append: "map_of (xs @ ys) = map_of (merge ys xs)"
  by (simp add: merge_conv')

subsection {* @{text compose} *}

function compose :: "('key \<times> 'a) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('key \<times> 'b) list"
where
  "compose [] ys = []"
| "compose (x # xs) ys =
    (case map_of ys (snd x) of
      None \<Rightarrow> compose (delete (fst x) xs) ys
    | Some v \<Rightarrow> (fst x, v) # compose xs ys)"
  by pat_completeness auto
termination
  by (relation "measure (length \<circ> fst)") (simp_all add: less_Suc_eq_le length_delete_le)

lemma compose_first_None [simp]:
  assumes "map_of xs k = None"
  shows "map_of (compose xs ys) k = None"
  using assms by (induct xs ys rule: compose.induct) (auto split: option.splits split_if_asm)

lemma compose_conv: "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 have hyp: "map_of (compose (delete (fst x) xs) ys) k =
        (map_of ys \<circ>\<^sub>m map_of (delete (fst x) xs)) k"
      by simp
    show ?thesis
    proof (cases "fst x = k")
      case True
      from True delete_notin_dom [of k xs]
      have "map_of (delete (fst x) xs) k = None"
        by (simp add: map_of_eq_None_iff)
      with hyp show ?thesis
        using True None
        by simp
    next
      case False
      from False have "map_of (delete (fst x) xs) k = map_of xs k"
        by simp
      with hyp show ?thesis
        using False None by (simp add: map_comp_def)
    qed
  next
    case (Some v)
    with 2
    have "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
      by simp
    with Some show ?thesis
      by (auto simp add: map_comp_def)
  qed
qed

lemma compose_conv': "map_of (compose xs ys) = (map_of ys \<circ>\<^sub>m map_of xs)"
  by (rule ext) (rule compose_conv)

lemma compose_first_Some [simp]:
  assumes "map_of xs k = Some v"
  shows "map_of (compose xs ys) k = map_of ys v"
  using assms by (simp add: compose_conv)

lemma dom_compose: "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with "2.hyps"
    have "fst ` set (compose (delete (fst x) xs) ys) \<subseteq> fst ` set (delete (fst x) xs)"
      by simp
    also
    have "\<dots> \<subseteq> fst ` set xs"
      by (rule dom_delete_subset)
    finally show ?thesis
      using None
      by auto
  next
    case (Some v)
    with "2.hyps"
    have "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
      by simp
    with Some show ?thesis
      by auto
  qed
qed

lemma distinct_compose:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (compose xs ys))"
  using assms
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 show ?thesis by simp
  next
    case (Some v)
    with 2 dom_compose [of xs ys] show ?thesis
      by auto
  qed
qed

lemma compose_delete_twist: "compose (delete k xs) ys = delete k (compose xs ys)"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 have hyp: "compose (delete k (delete (fst x) xs)) ys =
        delete k (compose (delete (fst x) xs) ys)"
      by simp
    show ?thesis
    proof (cases "fst x = k")
      case True
      with None hyp show ?thesis
        by (simp add: delete_idem)
    next
      case False
      from None False hyp show ?thesis
        by (simp add: delete_twist)
    qed
  next
    case (Some v)
    with 2 have hyp: "compose (delete k xs) ys = delete k (compose xs ys)"
      by simp
    with Some show ?thesis
      by simp
  qed
qed

lemma compose_clearjunk: "compose xs (clearjunk ys) = compose xs ys"
  by (induct xs ys rule: compose.induct)
    (auto simp add: map_of_clearjunk split: option.splits)

lemma clearjunk_compose: "clearjunk (compose xs ys) = compose (clearjunk xs) ys"
  by (induct xs rule: clearjunk.induct)
    (auto split: option.splits simp add: clearjunk_delete delete_idem compose_delete_twist)

lemma compose_empty [simp]: "compose xs [] = []"
  by (induct xs) (auto simp add: compose_delete_twist)

lemma compose_Some_iff:
  "(map_of (compose xs ys) k = Some v) \<longleftrightarrow>
    (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = Some v)"
  by (simp add: compose_conv map_comp_Some_iff)

lemma map_comp_None_iff:
  "map_of (compose xs ys) k = None \<longleftrightarrow>
    (map_of xs k = None \<or> (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = None))"
  by (simp add: compose_conv map_comp_None_iff)

subsection {* @{text map_entry} *}

fun map_entry :: "'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "map_entry k f [] = []"
| "map_entry k f (p # ps) =
    (if fst p = k then (k, f (snd p)) # ps else p # map_entry k f ps)"

lemma map_of_map_entry:
  "map_of (map_entry k f xs) =
    (map_of xs)(k := case map_of xs k of None \<Rightarrow> None | Some v' \<Rightarrow> Some (f v'))"
  by (induct xs) auto

lemma dom_map_entry: "fst ` set (map_entry k f xs) = fst ` set xs"
  by (induct xs) auto

lemma distinct_map_entry:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (map_entry k f xs))"
  using assms by (induct xs) (auto simp add: dom_map_entry)

subsection {* @{text map_default} *}

fun map_default :: "'key \<Rightarrow> 'val \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "map_default k v f [] = [(k, v)]"
| "map_default k v f (p # ps) =
    (if fst p = k then (k, f (snd p)) # ps else p # map_default k v f ps)"

lemma map_of_map_default:
  "map_of (map_default k v f xs) =
    (map_of xs)(k := case map_of xs k of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f v'))"
  by (induct xs) auto

lemma dom_map_default: "fst ` set (map_default k v f xs) = insert k (fst ` set xs)"
  by (induct xs) auto

lemma distinct_map_default:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (map_default k v f xs))"
  using assms by (induct xs) (auto simp add: dom_map_default)

hide_const (open) update updates delete restrict clearjunk merge compose map_entry

end