header {* Implementing Graphs *}
(* Author: Peter Lammich *)
theory Digraph_Impl
imports Digraph
begin

subsection {* Directed Graphs by Successor Function *}
type_synonym 'a slg = "'a \<Rightarrow> 'a list"

definition slg_rel :: "('a\<times>'b) set \<Rightarrow> ('a slg \<times> 'b digraph) set" where
  slg_rel_def_internal: "slg_rel R \<equiv>
  (R \<rightarrow> \<langle>R\<rangle>list_set_rel) O br (\<lambda>succs. {(u,v). v\<in>succs u}) (\<lambda>_. True)"

lemma slg_rel_def: "\<langle>R\<rangle>slg_rel =
  (R \<rightarrow> \<langle>R\<rangle>list_set_rel) O br (\<lambda>succs. {(u,v). v\<in>succs u}) (\<lambda>_. True)"
  unfolding slg_rel_def_internal relAPP_def by simp

lemma slg_rel_sv[relator_props]:
  "\<lbrakk>single_valued R; Range R = UNIV\<rbrakk> \<Longrightarrow> single_valued (\<langle>R\<rangle>slg_rel)"
  unfolding slg_rel_def
  by (tagged_solver)

consts i_slg :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of slg_rel i_slg]

definition [simp]: "op_slg_succs E v \<equiv> E``{v}"

lemma [autoref_itype]: "op_slg_succs ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp

context begin interpretation autoref_syn .

lemma refine_slg_succs[autoref_rules_raw]:
  "(\<lambda>succs v. succs v,op_slg_succs)\<in>\<langle>R\<rangle>slg_rel\<rightarrow>R\<rightarrow>\<langle>R\<rangle>list_set_rel"
  apply (intro fun_relI)
  apply (auto simp add: slg_rel_def br_def dest: fun_relD)
  done

definition "E_of_succ succ \<equiv> { (u,v). v\<in>succ u }"
definition "succ_of_E E \<equiv> (\<lambda>u. {v . (u,v)\<in>E})"

lemma E_of_succ_of_E[simp]: "E_of_succ (succ_of_E E) = E"
  unfolding E_of_succ_def succ_of_E_def
  by auto

lemma succ_of_E_of_succ[simp]: "succ_of_E (E_of_succ E) = E"
  unfolding E_of_succ_def succ_of_E_def
  by auto

context begin interpretation autoref_syn .
  lemma [autoref_itype]: "E_of_succ ::\<^sub>i (I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg" by simp
  lemma [autoref_itype]: "succ_of_E ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp
end

lemma E_of_succ_refine[autoref_rules]:
  "(\<lambda>x. x, E_of_succ) \<in> (R \<rightarrow> \<langle>R\<rangle>list_set_rel) \<rightarrow> \<langle>R\<rangle>slg_rel"
  "(\<lambda>x. x, succ_of_E) \<in> \<langle>R\<rangle>slg_rel \<rightarrow> (R \<rightarrow> \<langle>R\<rangle>list_set_rel)"
  unfolding E_of_succ_def[abs_def] succ_of_E_def[abs_def] slg_rel_def br_def
  apply auto []
  apply clarsimp
  apply (blast dest: fun_relD)
  done

subsubsection {* Restricting Edges*}
definition op_graph_restrict :: "'v set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set"
  where [simp]: "op_graph_restrict Vl Vr E \<equiv> E \<inter> Vl \<times> Vr"

definition op_graph_restrict_left :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set"
  where [simp]: "op_graph_restrict_left Vl E \<equiv> E \<inter> Vl \<times> UNIV"

definition op_graph_restrict_right :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set"
  where [simp]: "op_graph_restrict_right Vr E \<equiv> E \<inter> UNIV \<times> Vr"

lemma [autoref_op_pat]:
  "E \<inter> (Vl \<times> Vr) \<equiv> op_graph_restrict Vl Vr E"
  "E \<inter> (Vl \<times> UNIV) \<equiv> op_graph_restrict_left Vl E"
  "E \<inter> (UNIV \<times> Vr) \<equiv> op_graph_restrict_right Vr E"
  by simp_all

lemma graph_restrict_aimpl: "op_graph_restrict Vl Vr E =
  E_of_succ (\<lambda>v. if v\<in>Vl then {x \<in> E``{v}. x\<in>Vr} else {})"
  by (auto simp: E_of_succ_def succ_of_E_def split: split_if_asm)
lemma graph_restrict_left_aimpl: "op_graph_restrict_left Vl E =
  E_of_succ (\<lambda>v. if v\<in>Vl then E``{v} else {})"
  by (auto simp: E_of_succ_def succ_of_E_def split: split_if_asm)
lemma graph_restrict_right_aimpl: "op_graph_restrict_right Vr E =
  E_of_succ (\<lambda>v. {x \<in> E``{v}. x\<in>Vr})"
  by (auto simp: E_of_succ_def succ_of_E_def split: split_if_asm)

schematic_lemma graph_restrict_impl_aux:
  fixes Rsl Rsr
  notes [autoref_rel_intf] = REL_INTFI[of Rsl i_set] REL_INTFI[of Rsr i_set]
  assumes [autoref_rules]: "(meml, op \<in>) \<in> R \<rightarrow> \<langle>R\<rangle>Rsl \<rightarrow> bool_rel"
  assumes [autoref_rules]: "(memr, op \<in>) \<in> R \<rightarrow> \<langle>R\<rangle>Rsr \<rightarrow> bool_rel"
  shows "(?c, op_graph_restrict) \<in> \<langle>R\<rangle>Rsl \<rightarrow> \<langle>R\<rangle>Rsr \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  unfolding graph_restrict_aimpl[abs_def]
  apply (autoref (keep_goal))
  done

schematic_lemma graph_restrict_left_impl_aux:
  fixes Rsl Rsr
  notes [autoref_rel_intf] = REL_INTFI[of Rsl i_set] REL_INTFI[of Rsr i_set]
  assumes [autoref_rules]: "(meml, op \<in>) \<in> R \<rightarrow> \<langle>R\<rangle>Rsl \<rightarrow> bool_rel"
  shows "(?c, op_graph_restrict_left) \<in> \<langle>R\<rangle>Rsl \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  unfolding graph_restrict_left_aimpl[abs_def]
  apply (autoref (keep_goal, trace))
  done

schematic_lemma graph_restrict_right_impl_aux:
  fixes Rsl Rsr
  notes [autoref_rel_intf] = REL_INTFI[of Rsl i_set] REL_INTFI[of Rsr i_set]
  assumes [autoref_rules]: "(memr, op \<in>) \<in> R \<rightarrow> \<langle>R\<rangle>Rsr \<rightarrow> bool_rel"
  shows "(?c, op_graph_restrict_right) \<in> \<langle>R\<rangle>Rsr \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  unfolding graph_restrict_right_aimpl[abs_def]
  apply (autoref (keep_goal, trace))
  done

concrete_definition graph_restrict_impl uses graph_restrict_impl_aux
concrete_definition graph_restrict_left_impl uses graph_restrict_left_impl_aux
concrete_definition graph_restrict_right_impl uses graph_restrict_right_impl_aux

context begin interpretation autoref_syn .
  lemma [autoref_itype]:
    "op_graph_restrict ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
    "op_graph_restrict_right ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
    "op_graph_restrict_left ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
    by auto
end

lemmas [autoref_rules_raw] =
  graph_restrict_impl.refine[OF GEN_OP_D GEN_OP_D]
  graph_restrict_left_impl.refine[OF GEN_OP_D]
  graph_restrict_right_impl.refine[OF GEN_OP_D]

schematic_lemma "(?c::?'c, \<lambda>(E::nat digraph) x. E``{x}) \<in> ?R"
  apply (autoref (keep_goal))
  done

subsection {* Rooted Graphs *}

subsubsection {* Operation Identification Setup *}

consts
  i_frg_ext :: "interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_frg \<equiv> \<langle>i_unit\<rangle>\<^sub>ii_frg_ext"

context begin interpretation autoref_syn .

lemma frg_type[autoref_itype]:
  "frg_V ::\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_frg_ext \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "frg_E ::\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_frg_ext \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
  "frg_V0 ::\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_frg_ext \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "fr_graph_rec_ext
    ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i iE \<rightarrow>\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_frg_ext"
  by simp_all

end

subsubsection {* Generic Implementation *}
record ('vi,'ei,'v0i) gen_frg_impl =
  frgi_V :: 'vi
  frgi_E :: 'ei
  frgi_V0 :: 'v0i

definition gen_frg_impl_rel_ext_internal_def: "gen_frg_impl_rel_ext Rm Rv Re Rv0
  \<equiv> { (gen_frg_impl_ext Vi Ei V0i mi, fr_graph_rec_ext V E V0 m)
      | Vi Ei V0i mi V E V0 m.
        (Vi,V)\<in>Rv \<and> (Ei,E)\<in>Re \<and> (V0i,V0)\<in>Rv0 \<and> (mi,m)\<in>Rm
    }"

lemma gen_frg_impl_rel_ext_def: "\<langle>Rm,Rv,Re,Rv0\<rangle>gen_frg_impl_rel_ext
  \<equiv> { (gen_frg_impl_ext Vi Ei V0i mi, fr_graph_rec_ext V E V0 m)
      | Vi Ei V0i mi V E V0 m.
        (Vi,V)\<in>Rv \<and> (Ei,E)\<in>Re \<and> (V0i,V0)\<in>Rv0 \<and> (mi,m)\<in>Rm
    }"
  unfolding gen_frg_impl_rel_ext_internal_def relAPP_def by simp

lemma gen_frg_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rv; single_valued Re; single_valued Rv0; single_valued Rm \<rbrakk> \<Longrightarrow>
  single_valued (\<langle>Rm,Rv,Re,Rv0\<rangle>gen_frg_impl_rel_ext)"
  unfolding gen_frg_impl_rel_ext_def
  apply (auto
    intro!: single_valuedI
    dest: single_valuedD slg_rel_sv list_set_rel_sv)
  done

lemma gen_frg_refine:
  "(frgi_V,frg_V) \<in> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_frg_impl_rel_ext \<rightarrow> Rv"
  "(frgi_E,frg_E) \<in> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_frg_impl_rel_ext \<rightarrow> Re"
  "(frgi_V0,frg_V0) \<in> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_frg_impl_rel_ext \<rightarrow> Rv0"
  "(gen_frg_impl_ext, fr_graph_rec_ext)
    \<in> Rv \<rightarrow> Re \<rightarrow> Rv0 \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_frg_impl_rel_ext"
  unfolding gen_frg_impl_rel_ext_def
  by auto

subsubsection {* Implementation with list-set for Nodes *}
type_synonym ('v,'m) frgv_impl_scheme =
  "('v list, 'v \<Rightarrow> 'v list, 'v list, 'm) gen_frg_impl_scheme"

definition frgv_impl_rel_ext_internal_def:
  "frgv_impl_rel_ext Rm Rv
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>list_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_frg_impl_rel_ext"

lemma frgv_impl_rel_ext_def: "\<langle>Rm,Rv\<rangle>frgv_impl_rel_ext
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>list_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_frg_impl_rel_ext"
  unfolding frgv_impl_rel_ext_internal_def relAPP_def by simp

lemma [autoref_rel_intf]: "REL_INTF frgv_impl_rel_ext i_frg_ext"
  by (rule REL_INTFI)

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rv; Range Rv = UNIV; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>frgv_impl_rel_ext)"
  unfolding frgv_impl_rel_ext_def by tagged_solver

lemmas [autoref_rules] = gen_frg_refine[where
  Rv = "\<langle>Rv\<rangle>list_set_rel" and Re = "\<langle>Rv\<rangle>slg_rel" and ?Rv0.0 = "\<langle>Rv\<rangle>list_set_rel"
  for Rv, folded frgv_impl_rel_ext_def]

subsubsection {* Implementation with Cfun for Nodes *}
text {* This implementation allows for the universal node set. *}
type_synonym ('v,'m) frg_impl_scheme =
  "('v \<Rightarrow> bool, 'v \<Rightarrow> 'v list, 'v list, 'm) gen_frg_impl_scheme"

definition frg_impl_rel_ext_internal_def:
  "frg_impl_rel_ext Rm Rv
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>fun_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_frg_impl_rel_ext"

lemma frg_impl_rel_ext_def: "\<langle>Rm,Rv\<rangle>frg_impl_rel_ext
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>fun_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_frg_impl_rel_ext"
  unfolding frg_impl_rel_ext_internal_def relAPP_def by simp

lemma [autoref_rel_intf]: "REL_INTF frg_impl_rel_ext i_frg_ext"
  by (rule REL_INTFI)

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rv; Range Rv = UNIV; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>frg_impl_rel_ext)"
  unfolding frg_impl_rel_ext_def by tagged_solver

lemmas [autoref_rules] = gen_frg_refine[where
  Rv = "\<langle>Rv\<rangle>fun_set_rel"
  and Re = "\<langle>Rv\<rangle>slg_rel"
  and ?Rv0.0 = "\<langle>Rv\<rangle>list_set_rel"
  for Rv, folded frg_impl_rel_ext_def]

(* HACK: The homgeneity rule heuristics erronously creates a homogeneity rule that
    equalizes Rv and Rv0, out of the frv-implementation, which happens to be the
    first. This declaration counters the undesired effects caused by this. *)
lemma [autoref_hom]:
  "CONSTRAINT fr_graph_rec_ext (\<langle>Rv\<rangle>Rvs \<rightarrow> \<langle>Rv\<rangle>Res \<rightarrow> \<langle>Rv\<rangle>Rv0s \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rv\<rangle>Rg)"
  by simp

schematic_lemma "(?c::?'c, \<lambda>G x. frg_E G `` {x})\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "\<lbrakk>single_valued R; Range R = UNIV\<rbrakk> \<Longrightarrow> (?c,\<lambda>V0 E.
   \<lparr> frg_V = UNIV, frg_E = E, frg_V0 = V0 \<rparr>  )
  \<in>\<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>unit_rel,R\<rangle>frg_impl_rel_ext"
  apply (autoref (keep_goal))
  done

schematic_lemma "\<lbrakk>single_valued R; Range R = UNIV\<rbrakk> \<Longrightarrow> (?c,\<lambda>V V0 E.
   \<lparr> frg_V = V, frg_E = E, frg_V0 = V0 \<rparr>  )
  \<in>\<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>unit_rel,R\<rangle>frgv_impl_rel_ext"
  apply (autoref (keep_goal))
  done

subsubsection {* Renaming *}

definition "the_inv_into_map V f x
  = (if x \<in> f`V then Some (the_inv_into V f x) else None)"

lemma the_inv_into_map_None[simp]:
  "the_inv_into_map V f x = None \<longleftrightarrow> x \<notin> f`V"
  unfolding the_inv_into_map_def by auto

lemma the_inv_into_map_Some':
  "the_inv_into_map V f x = Some y \<longleftrightarrow> x \<in> f`V \<and> y=the_inv_into V f x"
  unfolding the_inv_into_map_def by auto

lemma the_inv_into_map_Some[simp]:
  "inj_on f V \<Longrightarrow> the_inv_into_map V f x = Some y \<longleftrightarrow> y\<in>V \<and> x=f y"
  by (auto simp: the_inv_into_map_Some' the_inv_into_f_f)

definition "the_inv_into_map_impl V f =
  FOREACH V (\<lambda>x m. RETURN (m(f x \<mapsto> x))) Map.empty"

lemma the_inv_into_map_impl_correct:
  assumes [simp]: "finite V"
  assumes INJ: "inj_on f V"
  shows "the_inv_into_map_impl V f \<le> SPEC (\<lambda>r. r = the_inv_into_map V f)"
  unfolding the_inv_into_map_impl_def
  apply (refine_rcg
    FOREACH_rule[where I="\<lambda>it m. m=the_inv_into_map (V - it) f"]
    refine_vcg
  )

  apply (vc_solve
    simp: the_inv_into_map_def[abs_def] it_step_insert_iff
    intro!: ext)

  apply (intro allI impI conjI)

  apply (subst the_inv_into_f_f[OF subset_inj_on[OF INJ]], auto) []

  apply (subst the_inv_into_f_f[OF subset_inj_on[OF INJ]], auto) []

  apply safe []
  apply (subst the_inv_into_f_f[OF subset_inj_on[OF INJ]], (auto) [2])+
  apply simp
  done

schematic_lemma the_inv_into_map_code_aux:
  fixes Rv' :: "('vti \<times> 'vt) set"
  assumes [relator_props]: "single_valued Rv"
  assumes [relator_props]: "single_valued Rv'"
  assumes [autoref_ga_rules]: "is_bounded_hashcode Rv' eq bhc"
  assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('vti) (def_size)"
  assumes [autoref_rules]: "(Vi,V)\<in>\<langle>Rv\<rangle>list_set_rel"
  assumes [autoref_rules]: "(fi,f)\<in>Rv\<rightarrow>Rv'"
  shows "(RETURN ?c, the_inv_into_map_impl V f) \<in> \<langle>\<langle>Rv',Rv\<rangle>ahm_rel bhc\<rangle>nres_rel"
  unfolding the_inv_into_map_impl_def[abs_def]
  apply (autoref_monadic (plain))
  done

concrete_definition the_inv_into_map_code uses the_inv_into_map_code_aux
export_code the_inv_into_map_code checking SML

thm the_inv_into_map_code.refine

context begin interpretation autoref_syn .
lemma autoref_the_inv_into_map[autoref_rules]:
  fixes Rv' :: "('vti \<times> 'vt) set"
  assumes "PREFER single_valued Rv"
  assumes "PREFER single_valued Rv'"
  assumes "SIDE_GEN_ALGO (is_bounded_hashcode Rv' eq bhc)"
  assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('vti) def_size)"
  assumes INJ: "SIDE_PRECOND (inj_on f V)"
  assumes V: "(Vi,V)\<in>\<langle>Rv\<rangle>list_set_rel"
  assumes F: "(fi,f)\<in>Rv\<rightarrow>Rv'"
  shows "(the_inv_into_map_code eq bhc def_size Vi fi,
    (OP the_inv_into_map
      ::: \<langle>Rv\<rangle>list_set_rel \<rightarrow> (Rv\<rightarrow>Rv') \<rightarrow> \<langle>Rv', Rv\<rangle>Impl_Array_Hash_Map.ahm_rel bhc)
    $V$f) \<in> \<langle>Rv', Rv\<rangle>Impl_Array_Hash_Map.ahm_rel bhc"
proof simp

  from V have FIN: "finite V" using list_set_rel_range by auto

  note the_inv_into_map_code.refine[
    OF assms(1-4,6-7)[unfolded autoref_tag_defs], THEN nres_relD
  ]
  also note the_inv_into_map_impl_correct[OF FIN INJ[unfolded autoref_tag_defs]]
  finally show "(the_inv_into_map_code eq bhc def_size Vi fi, the_inv_into_map V f)
    \<in> \<langle>Rv', Rv\<rangle>Impl_Array_Hash_Map.ahm_rel bhc"
    by (simp add: refine_pw_simps pw_le_iff)
qed

end

schematic_lemma "(?c::?'c, do {
  let s = {1,2,3::nat};
  (*ASSERT (inj_on Suc s); *)
  RETURN (the_inv_into_map s Suc) }) \<in> ?R"
  apply (autoref (keep_goal))
  done

definition "fr_rename_ext_aimpl ecnv f G \<equiv> do {
    ASSERT (inj_on f (frg_V G));
    ASSERT (inj_on f (frg_V0 G));
    let fi_map = the_inv_into_map (frg_V G) f;
    e \<leftarrow> ecnv fi_map G;
    RETURN \<lparr>
      frg_V = f`(frg_V G),
      frg_E = (E_of_succ (\<lambda>v. case fi_map v of
          Some u \<Rightarrow> f ` (succ_of_E (frg_E G) u) | None \<Rightarrow> {})),
      frg_V0 = (f`frg_V0 G),
      \<dots> = e
    \<rparr>
  }"

context fr_rename_precond begin

  definition "fi_map x = (if x \<in> f`V then Some (fi x) else None)"
  lemma fi_map_alt: "fi_map = the_inv_into_map V f"
    apply (rule ext)
    unfolding fi_map_def the_inv_into_map_def fi_def
    by simp

  lemma fi_map_Some: "(fi_map u = Some v) \<longleftrightarrow> u\<in>f`V \<and> fi u = v"
    unfolding fi_map_def by (auto split: split_if_asm)

  lemma fi_map_None: "(fi_map u = None) \<longleftrightarrow> u\<notin>f`V"
    unfolding fi_map_def by (auto split: split_if_asm)

  lemma rename_E_aimpl_alt: "rename_E f E = E_of_succ (\<lambda>v. case fi_map v of
    Some u \<Rightarrow> f ` (succ_of_E E u) | None \<Rightarrow> {})"
    unfolding E_of_succ_def succ_of_E_def
    using E_ss
    by (force
      simp: fi_f f_fi fi_map_Some fi_map_None
      split: split_if_asm option.splits)

  lemma frv_rename_ext_aimpl_alt:
    assumes ECNV: "ecnv' fi_map G \<le> SPEC (\<lambda>r. r = ecnv G)"
    shows "fr_rename_ext_aimpl ecnv' f G
      \<le> SPEC (\<lambda>r. r = fr_rename_ext ecnv f G)"
  proof -
    (*have [simp]: "\<lparr> frg_E =
             E_of_succ
              (\<lambda>v. case the_inv_into_map V f v of None \<Rightarrow> {}
                 | Some u \<Rightarrow> f ` succ_of_E (frg_E G) u),
            frg_V0 = f ` frg_V0 G, \<dots> = ecnv Gv\<rparr>
      = frv_G (frv_rename_ext ecnv f Gv)"
      unfolding frv_rename_ext_def
      by (auto simp: rename_E_aimpl_alt fi_map_alt)

    have [simp]: "\<lparr>frv_V = f ` V, frv_G = frv_G Gv'\<rparr> = Gv'"
      unfolding frv_rename_ext_def
      by simp*)

    show ?thesis
      unfolding fr_rename_ext_def fr_rename_ext_aimpl_def
      apply (refine_rcg
        order_trans[OF ECNV[unfolded fi_map_alt]]
        refine_vcg)
      using subset_inj_on[OF _ V0_ss]
      apply (auto intro: INJ simp: rename_E_aimpl_alt fi_map_alt)
      done
  qed
end

term frv_rename_ext_aimpl
schematic_lemma fr_rename_ext_impl_aux:
  fixes Rv' :: "('vti \<times> 'vt) set"
  assumes [relator_props]: "single_valued Rv"
  assumes [relator_props]: "single_valued Rv'"
  assumes [relator_props]: "single_valued Re'"
  assumes [relator_props]: "Range Rv' = UNIV"
  assumes [autoref_rules]: "(eq, op =) \<in> Rv' \<rightarrow> Rv' \<rightarrow> bool_rel"
  assumes [autoref_ga_rules]: "is_bounded_hashcode Rv' eq bhc"
  assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('vti) def_size"
  shows "(?c,fr_rename_ext_aimpl) \<in>
    ((\<langle>Rv',Rv\<rangle>ahm_rel bhc) \<rightarrow> \<langle>Re,Rv\<rangle>frgv_impl_rel_ext \<rightarrow> \<langle>Re'\<rangle>nres_rel) \<rightarrow>
    (Rv\<rightarrow>Rv') \<rightarrow>
    \<langle>Re,Rv\<rangle>frgv_impl_rel_ext \<rightarrow>
    \<langle>\<langle>Re',Rv'\<rangle>frgv_impl_rel_ext\<rangle>nres_rel"
  unfolding fr_rename_ext_aimpl_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition fr_rename_ext_impl uses fr_rename_ext_impl_aux

thm fr_rename_ext_impl.refine[OF
  PREFER_sv_D PREFER_sv_D PREFER_sv_D PREFER_RUNIV_D
  GEN_OP_D SIDE_GEN_ALGO_D SIDE_GEN_ALGO_D]

subsection {* Graphs from Lists *}

definition succ_of_list :: "(nat\<times>nat) list \<Rightarrow> nat \<Rightarrow> nat set"
  where
  "succ_of_list l \<equiv> let
    m = fold (\<lambda>(u,v) g.
          case g u of
            None \<Rightarrow> g(u\<mapsto>{v})
          | Some s \<Rightarrow> g(u\<mapsto>insert v s)
        ) l Map.empty
  in
    (\<lambda>u. case m u of None \<Rightarrow> {} | Some s \<Rightarrow> s)"

lemma succ_of_list_correct_aux:
  "(succ_of_list l, set l) \<in> br (\<lambda>succs. {(u,v). v\<in>succs u}) (\<lambda>_. True)"
proof -

  term the_default

  { fix m
    have "fold (\<lambda>(u,v) g.
            case g u of
              None \<Rightarrow> g(u\<mapsto>{v})
            | Some s \<Rightarrow> g(u\<mapsto>insert v s)
          ) l m
      = (\<lambda>u. let s=set l `` {u} in
          if s={} then m u else Some (the_default {} (m u) \<union> s))"
      apply (induction l arbitrary: m)
      apply (auto
        split: option.split split_if
        simp: Let_def Image_def
        intro!: ext)
      done
  } note aux=this

  show ?thesis
    unfolding succ_of_list_def aux
    by (auto simp: br_def Let_def split: option.splits split_if_asm)
qed

schematic_lemma succ_of_list_impl:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat\<rightharpoonup>nat set" and R="\<langle>nat_rel,R\<rangle>iam_map_rel" for R]
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>list_set_rel"]

  shows "(?f::?'c,succ_of_list) \<in> ?R"
  unfolding succ_of_list_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition succ_of_list_impl uses succ_of_list_impl
export_code succ_of_list_impl in SML

lemma succ_of_list_impl_correct: "(succ_of_list_impl,set) \<in> Id \<rightarrow> \<langle>Id\<rangle>slg_rel"
  apply rule
  unfolding slg_rel_def
  apply rule
  apply (rule succ_of_list_impl.refine[THEN fun_relD])
  apply simp
  apply (rule succ_of_list_correct_aux)
  done

end


(*  Title:      ZF/Constructible/Formula.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>First-Order Formulas and the Definition of the Class L\<close>

theory Formula imports ZF begin

subsection\<open>Internalized formulas of FOL\<close>

text\<open>De Bruijn representation.
  Unbound variables get their denotations from an environment.\<close>

consts   formula :: i
datatype
  "formula" = Member ("x \<in> nat", "y \<in> nat")
            | Equal  ("x \<in> nat", "y \<in> nat")
            | Nand ("p \<in> formula", "q \<in> formula")
            | Forall ("p \<in> formula")

declare formula.intros [TC]

definition
  Neg :: "i=>i" where
  "Neg(p) == Nand(p,p)"

definition
  And :: "[i,i]=>i" where
  "And(p,q) == Neg(Nand(p,q))"

definition
  Or :: "[i,i]=>i" where
  "Or(p,q) == Nand(Neg(p),Neg(q))"

definition
  Implies :: "[i,i]=>i" where
  "Implies(p,q) == Nand(p,Neg(q))"

definition
  Iff :: "[i,i]=>i" where
  "Iff(p,q) == And(Implies(p,q), Implies(q,p))"

definition
  Exists :: "i=>i" where
  "Exists(p) == Neg(Forall(Neg(p)))"

lemma Neg_type [TC]: "p \<in> formula ==> Neg(p) \<in> formula"
by (simp add: Neg_def)

lemma And_type [TC]: "[| p \<in> formula; q \<in> formula |] ==> And(p,q) \<in> formula"
by (simp add: And_def)

lemma Or_type [TC]: "[| p \<in> formula; q \<in> formula |] ==> Or(p,q) \<in> formula"
by (simp add: Or_def)

lemma Implies_type [TC]:
     "[| p \<in> formula; q \<in> formula |] ==> Implies(p,q) \<in> formula"
by (simp add: Implies_def)

lemma Iff_type [TC]:
     "[| p \<in> formula; q \<in> formula |] ==> Iff(p,q) \<in> formula"
by (simp add: Iff_def)

lemma Exists_type [TC]: "p \<in> formula ==> Exists(p) \<in> formula"
by (simp add: Exists_def)

consts   satisfies :: "[i,i]=>i"
primrec (*explicit lambda is required because the environment varies*)
  "satisfies(A,Member(x,y)) =
      (\<lambda>env \<in> list(A). bool_of_o (nth(x,env) \<in> nth(y,env)))"

  "satisfies(A,Equal(x,y)) =
      (\<lambda>env \<in> list(A). bool_of_o (nth(x,env) = nth(y,env)))"

  "satisfies(A,Nand(p,q)) =
      (\<lambda>env \<in> list(A). not ((satisfies(A,p)`env) and (satisfies(A,q)`env)))"

  "satisfies(A,Forall(p)) =
      (\<lambda>env \<in> list(A). bool_of_o (\<forall>x\<in>A. satisfies(A,p) ` (Cons(x,env)) = 1))"

lemma "p \<in> formula ==> satisfies(A,p) \<in> list(A) -> bool"
by (induct set: formula) simp_all

abbreviation
  sats :: "[i,i,i] => o" where
  "sats(A,p,env) == satisfies(A,p)`env = 1"

lemma [simp]:
  "env \<in> list(A)
   ==> sats(A, Equal(x,y), env) \<longleftrightarrow> nth(x,env) = nth(y,env)"
by simp

lemma sats_Nand_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Nand(p,q), env)) \<longleftrightarrow> ~ (sats(A,p,env) & sats(A,q,env))"
by (simp add: Bool.and_def Bool.not_def cond_def)

lemma sats_Forall_iff [simp]:
  "env \<in> list(A)
   ==> sats(A, Forall(p), env) \<longleftrightarrow> (\<forall>x\<in>A. sats(A, p, Cons(x,env)))"
by simp

declare satisfies.simps [simp del]

subsection\<open>Dividing line between primitive and derived connectives\<close>

lemma sats_Neg_iff [simp]:
  "env \<in> list(A)
   ==> sats(A, Neg(p), env) \<longleftrightarrow> ~ sats(A,p,env)"
by (simp add: Neg_def)

lemma sats_And_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, And(p,q), env)) \<longleftrightarrow> sats(A,p,env) & sats(A,q,env)"
by (simp add: And_def)

lemma sats_Or_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Or(p,q), env)) \<longleftrightarrow> sats(A,p,env) | sats(A,q,env)"
by (simp add: Or_def)

lemma sats_Implies_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Implies(p,q), env)) \<longleftrightarrow> (sats(A,p,env) \<longrightarrow> sats(A,q,env))"
by (simp add: Implies_def, blast)

lemma sats_Iff_iff [simp]:
  "env \<in> list(A)
   ==> (sats(A, Iff(p,q), env)) \<longleftrightarrow> (sats(A,p,env) \<longleftrightarrow> sats(A,q,env))"
by (simp add: Iff_def, blast)

lemma sats_Exists_iff [simp]:
  "env \<in> list(A)
   ==> sats(A, Exists(p), env) \<longleftrightarrow> (\<exists>x\<in>A. sats(A, p, Cons(x,env)))"
by (simp add: Exists_def)

subsubsection\<open>Derived rules to help build up formulas\<close>

lemma mem_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; env \<in> list(A)|]
       ==> (x\<in>y) \<longleftrightarrow> sats(A, Member(i,j), env)"
by (simp add: satisfies.simps)

lemma equal_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; env \<in> list(A)|]
       ==> (x=y) \<longleftrightarrow> sats(A, Equal(i,j), env)"
by (simp add: satisfies.simps)

lemma not_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); env \<in> list(A)|]
       ==> (~P) \<longleftrightarrow> sats(A, Neg(p), env)"
by simp

lemma conj_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P & Q) \<longleftrightarrow> sats(A, And(p,q), env)"
by (simp add: sats_And_iff)

lemma disj_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P | Q) \<longleftrightarrow> sats(A, Or(p,q), env)"
by (simp add: sats_Or_iff)

lemma iff_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P \<longleftrightarrow> Q) \<longleftrightarrow> sats(A, Iff(p,q), env)"
by (simp add: sats_Forall_iff)

lemma imp_iff_sats:
      "[| P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)|]
       ==> (P \<longrightarrow> Q) \<longleftrightarrow> sats(A, Implies(p,q), env)"
by (simp add: sats_Forall_iff)

lemma ball_iff_sats:
      "[| !!x. x\<in>A ==> P(x) \<longleftrightarrow> sats(A, p, Cons(x, env)); env \<in> list(A)|]
       ==> (\<forall>x\<in>A. P(x)) \<longleftrightarrow> sats(A, Forall(p), env)"
by (simp add: sats_Forall_iff)

lemma bex_iff_sats:
      "[| !!x. x\<in>A ==> P(x) \<longleftrightarrow> sats(A, p, Cons(x, env)); env \<in> list(A)|]
       ==> (\<exists>x\<in>A. P(x)) \<longleftrightarrow> sats(A, Exists(p), env)"
by (simp add: sats_Exists_iff)

lemmas FOL_iff_sats =
        mem_iff_sats equal_iff_sats not_iff_sats conj_iff_sats
        disj_iff_sats imp_iff_sats iff_iff_sats imp_iff_sats ball_iff_sats
        bex_iff_sats

subsection\<open>Arity of a Formula: Maximum Free de Bruijn Index\<close>

consts   arity :: "i=>i"
primrec
  "arity(Member(x,y)) = succ(x) \<union> succ(y)"

  "arity(Equal(x,y)) = succ(x) \<union> succ(y)"

  "arity(Nand(p,q)) = arity(p) \<union> arity(q)"

  "arity(Forall(p)) = Arith.pred(arity(p))"

lemma arity_type [TC]: "p \<in> formula ==> arity(p) \<in> nat"
by (induct_tac p, simp_all)

lemma arity_Neg [simp]: "arity(Neg(p)) = arity(p)"
by (simp add: Neg_def)

lemma arity_And [simp]: "arity(And(p,q)) = arity(p) \<union> arity(q)"
by (simp add: And_def)

lemma arity_Or [simp]: "arity(Or(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Or_def)

lemma arity_Implies [simp]: "arity(Implies(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Implies_def)

lemma arity_Iff [simp]: "arity(Iff(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Iff_def, blast)

lemma arity_Exists [simp]: "arity(Exists(p)) = Arith.pred(arity(p))"
by (simp add: Exists_def)

lemma arity_sats_iff [rule_format]:
  "[| p \<in> formula; extra \<in> list(A) |]
   ==> \<forall>env \<in> list(A).
           arity(p) \<le> length(env) \<longrightarrow>
           sats(A, p, env @ extra) \<longleftrightarrow> sats(A, p, env)"
apply (induct_tac p)
apply (simp_all add: Arith.pred_def nth_append Un_least_lt_iff nat_imp_quasinat
                split: split_nat_case, auto)
done

lemma arity_sats1_iff:
  "[| arity(p) \<le> succ(length(env)); p \<in> formula; x \<in> A; env \<in> list(A);
      extra \<in> list(A) |]
   ==> sats(A, p, Cons(x, env @ extra)) \<longleftrightarrow> sats(A, p, Cons(x, env))"
apply (insert arity_sats_iff [of p extra A "Cons(x,env)"])
apply simp
done

subsection\<open>Renaming Some de Bruijn Variables\<close>

definition
  incr_var :: "[i,i]=>i" where
  "incr_var(x,nq) == if x<nq then x else succ(x)"

lemma incr_var_lt: "x<nq ==> incr_var(x,nq) = x"
by (simp add: incr_var_def)

lemma incr_var_le: "nq\<le>x ==> incr_var(x,nq) = succ(x)"
apply (simp add: incr_var_def)
apply (blast dest: lt_trans1)
done

consts   incr_bv :: "i=>i"
primrec
  "incr_bv(Member(x,y)) =
      (\<lambda>nq \<in> nat. Member (incr_var(x,nq), incr_var(y,nq)))"

  "incr_bv(Equal(x,y)) =
      (\<lambda>nq \<in> nat. Equal (incr_var(x,nq), incr_var(y,nq)))"

  "incr_bv(Nand(p,q)) =
      (\<lambda>nq \<in> nat. Nand (incr_bv(p)`nq, incr_bv(q)`nq))"

  "incr_bv(Forall(p)) =
      (\<lambda>nq \<in> nat. Forall (incr_bv(p) ` succ(nq)))"

lemma [TC]: "x \<in> nat ==> incr_var(x,nq) \<in> nat"
by (simp add: incr_var_def)

lemma incr_bv_type [TC]: "p \<in> formula ==> incr_bv(p) \<in> nat -> formula"
by (induct_tac p, simp_all)

text\<open>Obviously, @{term DPow} is closed under complements and finite
intersections and unions.  Needs an inductive lemma to allow two lists of
parameters to be combined.\<close>

lemma sats_incr_bv_iff [rule_format]:
  "[| p \<in> formula; env \<in> list(A); x \<in> A |]
   ==> \<forall>bvs \<in> list(A).
           sats(A, incr_bv(p) ` length(bvs), bvs @ Cons(x,env)) \<longleftrightarrow>
           sats(A, p, bvs@env)"
apply (induct_tac p)
apply (simp_all add: incr_var_def nth_append succ_lt_iff length_type)
apply (auto simp add: diff_succ not_lt_iff_le)
done

(*the following two lemmas prevent huge case splits in arity_incr_bv_lemma*)
lemma incr_var_lemma:
     "[| x \<in> nat; y \<in> nat; nq \<le> x |]
      ==> succ(x) \<union> incr_var(y,nq) = succ(x \<union> y)"
apply (simp add: incr_var_def Ord_Un_if, auto)
  apply (blast intro: leI)
 apply (simp add: not_lt_iff_le)
 apply (blast intro: le_anti_sym)
apply (blast dest: lt_trans2)
done

lemma incr_And_lemma:
     "y < x ==> y \<union> succ(x) = succ(x \<union> y)"
apply (simp add: Ord_Un_if lt_Ord lt_Ord2 succ_lt_iff)
apply (blast dest: lt_asym)
done

lemma arity_incr_bv_lemma [rule_format]:
  "p \<in> formula
   ==> \<forall>n \<in> nat. arity (incr_bv(p) ` n) =
                 (if n < arity(p) then succ(arity(p)) else arity(p))"
apply (induct_tac p)
apply (simp_all add: imp_disj not_lt_iff_le Un_least_lt_iff lt_Un_iff le_Un_iff
                     succ_Un_distrib [symmetric] incr_var_lt incr_var_le
                     Un_commute incr_var_lemma Arith.pred_def nat_imp_quasinat
            split: split_nat_case)
 txt\<open>the Forall case reduces to linear arithmetic\<close>
 prefer 2
 apply clarify
 apply (blast dest: lt_trans1)
txt\<open>left with the And case\<close>
apply safe
 apply (blast intro: incr_And_lemma lt_trans1)
apply (subst incr_And_lemma)
 apply (blast intro: lt_trans1)
apply (simp add: Un_commute)
done

subsection\<open>Renaming all but the First de Bruijn Variable\<close>

definition
  incr_bv1 :: "i => i" where
  "incr_bv1(p) == incr_bv(p)`1"

lemma incr_bv1_type [TC]: "p \<in> formula ==> incr_bv1(p) \<in> formula"
by (simp add: incr_bv1_def)

(*For renaming all but the bound variable at level 0*)
lemma sats_incr_bv1_iff:
  "[| p \<in> formula; env \<in> list(A); x \<in> A; y \<in> A |]
   ==> sats(A, incr_bv1(p), Cons(x, Cons(y, env))) \<longleftrightarrow>
       sats(A, p, Cons(x,env))"
apply (insert sats_incr_bv_iff [of p env A y "Cons(x,Nil)"])
apply (simp add: incr_bv1_def)
done

lemma formula_add_params1 [rule_format]:
  "[| p \<in> formula; n \<in> nat; x \<in> A |]
   ==> \<forall>bvs \<in> list(A). \<forall>env \<in> list(A).
          length(bvs) = n \<longrightarrow>
          sats(A, iterates(incr_bv1, n, p), Cons(x, bvs@env)) \<longleftrightarrow>
          sats(A, p, Cons(x,env))"
apply (induct_tac n, simp, clarify)
apply (erule list.cases)
apply (simp_all add: sats_incr_bv1_iff)
done

lemma arity_incr_bv1_eq:
  "p \<in> formula
   ==> arity(incr_bv1(p)) =
        (if 1 < arity(p) then succ(arity(p)) else arity(p))"
apply (insert arity_incr_bv_lemma [of p 1])
apply (simp add: incr_bv1_def)
done

lemma arity_iterates_incr_bv1_eq:
  "[| p \<in> formula; n \<in> nat |]
   ==> arity(incr_bv1^n(p)) =
         (if 1 < arity(p) then n #+ arity(p) else arity(p))"
apply (induct_tac n)
apply (simp_all add: arity_incr_bv1_eq)
apply (simp add: not_lt_iff_le)
apply (blast intro: le_trans add_le_self2 arity_type)
done

subsection\<open>Definable Powerset\<close>

text\<open>The definable powerset operation: Kunen's definition VI 1.1, page 165.\<close>
definition
  DPow :: "i => i" where
  "DPow(A) == {X \<in> Pow(A).
               \<exists>env \<in> list(A). \<exists>p \<in> formula.
                 arity(p) \<le> succ(length(env)) &
                 X = {x\<in>A. sats(A, p, Cons(x,env))}}"

lemma DPowI:
  "[|env \<in> list(A);  p \<in> formula;  arity(p) \<le> succ(length(env))|]
   ==> {x\<in>A. sats(A, p, Cons(x,env))} \<in> DPow(A)"
by (simp add: DPow_def, blast)

text\<open>With this rule we can specify @{term p} later.\<close>
lemma DPowI2 [rule_format]:
  "[|\<forall>x\<in>A. P(x) \<longleftrightarrow> sats(A, p, Cons(x,env));
     env \<in> list(A);  p \<in> formula;  arity(p) \<le> succ(length(env))|]
   ==> {x\<in>A. P(x)} \<in> DPow(A)"
by (simp add: DPow_def, blast)

lemma DPowD:
  "X \<in> DPow(A)
   ==> X \<subseteq> A &
       (\<exists>env \<in> list(A).
        \<exists>p \<in> formula. arity(p) \<le> succ(length(env)) &
                      X = {x\<in>A. sats(A, p, Cons(x,env))})"
by (simp add: DPow_def)

lemmas DPow_imp_subset = DPowD [THEN conjunct1]

(*Kunen's Lemma VI 1.2*)
lemma "[| p \<in> formula; env \<in> list(A); arity(p) \<le> succ(length(env)) |]
       ==> {x\<in>A. sats(A, p, Cons(x,env))} \<in> DPow(A)"
by (blast intro: DPowI)

lemma DPow_subset_Pow: "DPow(A) \<subseteq> Pow(A)"
by (simp add: DPow_def, blast)

lemma empty_in_DPow: "0 \<in> DPow(A)"
apply (simp add: DPow_def)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="Neg(Equal(0,0))" in bexI)
  apply (auto simp add: Un_least_lt_iff)
done

lemma Compl_in_DPow: "X \<in> DPow(A) ==> (A-X) \<in> DPow(A)"
apply (simp add: DPow_def, clarify, auto)
apply (rule bexI)
 apply (rule_tac x="Neg(p)" in bexI)
  apply auto
done

lemma Int_in_DPow: "[| X \<in> DPow(A); Y \<in> DPow(A) |] ==> X \<inter> Y \<in> DPow(A)"
apply (simp add: DPow_def, auto)
apply (rename_tac envp p envq q)
apply (rule_tac x="envp@envq" in bexI)
 apply (rule_tac x="And(p, iterates(incr_bv1,length(envp),q))" in bexI)
  apply typecheck
apply (rule conjI)
(*finally check the arity!*)
 apply (simp add: arity_iterates_incr_bv1_eq length_app Un_least_lt_iff)
 apply (force intro: add_le_self le_trans)
apply (simp add: arity_sats1_iff formula_add_params1, blast)
done

lemma Un_in_DPow: "[| X \<in> DPow(A); Y \<in> DPow(A) |] ==> X \<union> Y \<in> DPow(A)"
apply (subgoal_tac "X \<union> Y = A - ((A-X) \<inter> (A-Y))")
apply (simp add: Int_in_DPow Compl_in_DPow)
apply (simp add: DPow_def, blast)
done

lemma singleton_in_DPow: "a \<in> A ==> {a} \<in> DPow(A)"
apply (simp add: DPow_def)
apply (rule_tac x="Cons(a,Nil)" in bexI)
 apply (rule_tac x="Equal(0,1)" in bexI)
  apply typecheck
apply (force simp add: succ_Un_distrib [symmetric])
done

lemma cons_in_DPow: "[| a \<in> A; X \<in> DPow(A) |] ==> cons(a,X) \<in> DPow(A)"
apply (rule cons_eq [THEN subst])
apply (blast intro: singleton_in_DPow Un_in_DPow)
done

(*Part of Lemma 1.3*)
lemma Fin_into_DPow: "X \<in> Fin(A) ==> X \<in> DPow(A)"
apply (erule Fin.induct)
 apply (rule empty_in_DPow)
apply (blast intro: cons_in_DPow)
done

text\<open>@{term DPow} is not monotonic.  For example, let @{term A} be some
non-constructible set of natural numbers, and let @{term B} be @{term nat}.
Then @{term "A<=B"} and obviously @{term "A \<in> DPow(A)"} but @{term "A \<notin>
DPow(B)"}.\<close>

(*This may be true but the proof looks difficult, requiring relativization
lemma DPow_insert: "DPow (cons(a,A)) = DPow(A) \<union> {cons(a,X) . X \<in> DPow(A)}"
apply (rule equalityI, safe)
oops
*)

lemma Finite_Pow_subset_Pow: "Finite(A) ==> Pow(A) \<subseteq> DPow(A)"
by (blast intro: Fin_into_DPow Finite_into_Fin Fin_subset)

lemma Finite_DPow_eq_Pow: "Finite(A) ==> DPow(A) = Pow(A)"
apply (rule equalityI)
apply (rule DPow_subset_Pow)
apply (erule Finite_Pow_subset_Pow)
done

subsection\<open>Internalized Formulas for the Ordinals\<close>

text\<open>The \<open>sats\<close> theorems below differ from the usual form in that they
include an element of absoluteness.  That is, they relate internalized
formulas to real concepts such as the subset relation, rather than to the
relativized concepts defined in theory \<open>Relative\<close>.  This lets us prove
the theorem as \<open>Ords_in_DPow\<close> without first having to instantiate the
locale \<open>M_trivial\<close>.  Note that the present theory does not even take
\<open>Relative\<close> as a parent.\<close>

subsubsection\<open>The subset relation\<close>

definition
  subset_fm :: "[i,i]=>i" where
  "subset_fm(x,y) == Forall(Implies(Member(0,succ(x)), Member(0,succ(y))))"

lemma subset_type [TC]: "[| x \<in> nat; y \<in> nat |] ==> subset_fm(x,y) \<in> formula"
by (simp add: subset_fm_def)

lemma arity_subset_fm [simp]:
     "[| x \<in> nat; y \<in> nat |] ==> arity(subset_fm(x,y)) = succ(x) \<union> succ(y)"
by (simp add: subset_fm_def succ_Un_distrib [symmetric])

lemma sats_subset_fm [simp]:
   "[|x < length(env); y \<in> nat; env \<in> list(A); Transset(A)|]
    ==> sats(A, subset_fm(x,y), env) \<longleftrightarrow> nth(x,env) \<subseteq> nth(y,env)"
apply (frule lt_length_in_nat, assumption)
apply (simp add: subset_fm_def Transset_def)
apply (blast intro: nth_type)
done

subsubsection\<open>Transitive sets\<close>

definition
  transset_fm :: "i=>i" where
  "transset_fm(x) == Forall(Implies(Member(0,succ(x)), subset_fm(0,succ(x))))"

lemma transset_type [TC]: "x \<in> nat ==> transset_fm(x) \<in> formula"
by (simp add: transset_fm_def)

lemma arity_transset_fm [simp]:
     "x \<in> nat ==> arity(transset_fm(x)) = succ(x)"
by (simp add: transset_fm_def succ_Un_distrib [symmetric])

lemma sats_transset_fm [simp]:
   "[|x < length(env); env \<in> list(A); Transset(A)|]
    ==> sats(A, transset_fm(x), env) \<longleftrightarrow> Transset(nth(x,env))"
apply (frule lt_nat_in_nat, erule length_type)
apply (simp add: transset_fm_def Transset_def)
apply (blast intro: nth_type)
done

subsubsection\<open>Ordinals\<close>

definition
  ordinal_fm :: "i=>i" where
  "ordinal_fm(x) ==
    And(transset_fm(x), Forall(Implies(Member(0,succ(x)), transset_fm(0))))"

lemma ordinal_type [TC]: "x \<in> nat ==> ordinal_fm(x) \<in> formula"
by (simp add: ordinal_fm_def)

lemma arity_ordinal_fm [simp]:
     "x \<in> nat ==> arity(ordinal_fm(x)) = succ(x)"
by (simp add: ordinal_fm_def succ_Un_distrib [symmetric])

lemma sats_ordinal_fm:
   "[|x < length(env); env \<in> list(A); Transset(A)|]
    ==> sats(A, ordinal_fm(x), env) \<longleftrightarrow> Ord(nth(x,env))"
apply (frule lt_nat_in_nat, erule length_type)
apply (simp add: ordinal_fm_def Ord_def Transset_def)
apply (blast intro: nth_type)
done

text\<open>The subset consisting of the ordinals is definable.  Essential lemma for
\<open>Ord_in_Lset\<close>.  This result is the objective of the present subsection.\<close>
theorem Ords_in_DPow: "Transset(A) ==> {x \<in> A. Ord(x)} \<in> DPow(A)"
apply (simp add: DPow_def Collect_subset)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="ordinal_fm(0)" in bexI)
apply (simp_all add: sats_ordinal_fm)
done

subsection\<open>Constant Lset: Levels of the Constructible Universe\<close>

definition
  Lset :: "i=>i" where
  "Lset(i) == transrec(i, %x f. \<Union>y\<in>x. DPow(f`y))"

definition
  L :: "i=>o" where \<comment>\<open>Kunen's definition VI 1.5, page 167\<close>
  "L(x) == \<exists>i. Ord(i) & x \<in> Lset(i)"

text\<open>NOT SUITABLE FOR REWRITING -- RECURSIVE!\<close>
lemma Lset: "Lset(i) = (\<Union>j\<in>i. DPow(Lset(j)))"
by (subst Lset_def [THEN def_transrec], simp)

lemma LsetI: "[|y\<in>x; A \<in> DPow(Lset(y))|] ==> A \<in> Lset(x)"
by (subst Lset, blast)

lemma LsetD: "A \<in> Lset(x) ==> \<exists>y\<in>x. A \<in> DPow(Lset(y))"
apply (insert Lset [of x])
apply (blast intro: elim: equalityE)
done

subsubsection\<open>Transitivity\<close>

lemma elem_subset_in_DPow: "[|X \<in> A; X \<subseteq> A|] ==> X \<in> DPow(A)"
apply (simp add: Transset_def DPow_def)
apply (rule_tac x="[X]" in bexI)
 apply (rule_tac x="Member(0,1)" in bexI)
  apply (auto simp add: Un_least_lt_iff)
done

lemma Transset_subset_DPow: "Transset(A) ==> A \<subseteq> DPow(A)"
apply clarify
apply (simp add: Transset_def)
apply (blast intro: elem_subset_in_DPow)
done

lemma Transset_DPow: "Transset(A) ==> Transset(DPow(A))"
apply (simp add: Transset_def)
apply (blast intro: elem_subset_in_DPow dest: DPowD)
done

text\<open>Kunen's VI 1.6 (a)\<close>
lemma Transset_Lset: "Transset(Lset(i))"
apply (rule_tac a=i in eps_induct)
apply (subst Lset)
apply (blast intro!: Transset_Union_family Transset_Un Transset_DPow)
done

lemma mem_Lset_imp_subset_Lset: "a \<in> Lset(i) ==> a \<subseteq> Lset(i)"
apply (insert Transset_Lset)
apply (simp add: Transset_def)
done

subsubsection\<open>Monotonicity\<close>

text\<open>Kunen's VI 1.6 (b)\<close>
lemma Lset_mono [rule_format]:
     "\<forall>j. i<=j \<longrightarrow> Lset(i) \<subseteq> Lset(j)"
proof (induct i rule: eps_induct, intro allI impI)
  fix x j
  assume "\<forall>y\<in>x. \<forall>j. y \<subseteq> j \<longrightarrow> Lset(y) \<subseteq> Lset(j)"
     and "x \<subseteq> j"
  thus "Lset(x) \<subseteq> Lset(j)"
    by (force simp add: Lset [of x] Lset [of j])
qed

text\<open>This version lets us remove the premise @{term "Ord(i)"} sometimes.\<close>
lemma Lset_mono_mem [rule_format]:
     "\<forall>j. i \<in> j \<longrightarrow> Lset(i) \<subseteq> Lset(j)"
proof (induct i rule: eps_induct, intro allI impI)
  fix x j
  assume "\<forall>y\<in>x. \<forall>j. y \<in> j \<longrightarrow> Lset(y) \<subseteq> Lset(j)"
     and "x \<in> j"
  thus "Lset(x) \<subseteq> Lset(j)"
    by (force simp add: Lset [of j]
              intro!: bexI intro: elem_subset_in_DPow dest: LsetD DPowD)
qed

text\<open>Useful with Reflection to bump up the ordinal\<close>
lemma subset_Lset_ltD: "[|A \<subseteq> Lset(i); i < j|] ==> A \<subseteq> Lset(j)"
by (blast dest: ltD [THEN Lset_mono_mem])

subsubsection\<open>0, successor and limit equations for Lset\<close>

lemma Lset_0 [simp]: "Lset(0) = 0"
by (subst Lset, blast)

lemma Lset_succ_subset1: "DPow(Lset(i)) \<subseteq> Lset(succ(i))"
by (subst Lset, rule succI1 [THEN RepFunI, THEN Union_upper])

lemma Lset_succ_subset2: "Lset(succ(i)) \<subseteq> DPow(Lset(i))"
apply (subst Lset, rule UN_least)
apply (erule succE)
 apply blast
apply clarify
apply (rule elem_subset_in_DPow)
 apply (subst Lset)
 apply blast
apply (blast intro: dest: DPowD Lset_mono_mem)
done

lemma Lset_succ: "Lset(succ(i)) = DPow(Lset(i))"
by (intro equalityI Lset_succ_subset1 Lset_succ_subset2)

lemma Lset_Union [simp]: "Lset(\<Union>(X)) = (\<Union>y\<in>X. Lset(y))"
apply (subst Lset)
apply (rule equalityI)
 txt\<open>first inclusion\<close>
 apply (rule UN_least)
 apply (erule UnionE)
 apply (rule subset_trans)
  apply (erule_tac [2] UN_upper, subst Lset, erule UN_upper)
txt\<open>opposite inclusion\<close>
apply (rule UN_least)
apply (subst Lset, blast)
done

subsubsection\<open>Lset applied to Limit ordinals\<close>

lemma Limit_Lset_eq:
    "Limit(i) ==> Lset(i) = (\<Union>y\<in>i. Lset(y))"
by (simp add: Lset_Union [symmetric] Limit_Union_eq)

lemma lt_LsetI: "[| a \<in> Lset(j);  j<i |] ==> a \<in> Lset(i)"
by (blast dest: Lset_mono [OF le_imp_subset [OF leI]])

lemma Limit_LsetE:
    "[| a \<in> Lset(i);  ~R ==> Limit(i);
        !!x. [| x<i;  a \<in> Lset(x) |] ==> R
     |] ==> R"
apply (rule classical)
apply (rule Limit_Lset_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI  Limit_is_Ord)
done

subsubsection\<open>Basic closure properties\<close>

lemma zero_in_Lset: "y \<in> x ==> 0 \<in> Lset(x)"
by (subst Lset, blast intro: empty_in_DPow)

lemma notin_Lset: "x \<notin> Lset(x)"
apply (rule_tac a=x in eps_induct)
apply (subst Lset)
apply (blast dest: DPowD)
done

subsection\<open>Constructible Ordinals: Kunen's VI 1.9 (b)\<close>

lemma Ords_of_Lset_eq: "Ord(i) ==> {x\<in>Lset(i). Ord(x)} = i"
apply (erule trans_induct3)
  apply (simp_all add: Lset_succ Limit_Lset_eq Limit_Union_eq)
txt\<open>The successor case remains.\<close>
apply (rule equalityI)
txt\<open>First inclusion\<close>
 apply clarify
 apply (erule Ord_linear_lt, assumption)
   apply (blast dest: DPow_imp_subset ltD notE [OF notin_Lset])
  apply blast
 apply (blast dest: ltD)
txt\<open>Opposite inclusion, @{term "succ(x) \<subseteq> DPow(Lset(x)) \<inter> ON"}\<close>
apply auto
txt\<open>Key case:\<close>
  apply (erule subst, rule Ords_in_DPow [OF Transset_Lset])
 apply (blast intro: elem_subset_in_DPow dest: OrdmemD elim: equalityE)
apply (blast intro: Ord_in_Ord)
done

lemma Ord_subset_Lset: "Ord(i) ==> i \<subseteq> Lset(i)"
by (subst Ords_of_Lset_eq [symmetric], assumption, fast)

lemma Ord_in_Lset: "Ord(i) ==> i \<in> Lset(succ(i))"
apply (simp add: Lset_succ)
apply (subst Ords_of_Lset_eq [symmetric], assumption,
       rule Ords_in_DPow [OF Transset_Lset])
done

lemma Ord_in_L: "Ord(i) ==> L(i)"
by (simp add: L_def, blast intro: Ord_in_Lset)

subsubsection\<open>Unions\<close>

lemma Union_in_Lset:
     "X \<in> Lset(i) ==> \<Union>(X) \<in> Lset(succ(i))"
apply (insert Transset_Lset)
apply (rule LsetI [OF succI1])
apply (simp add: Transset_def DPow_def)
apply (intro conjI, blast)
txt\<open>Now to create the formula @{term "\<exists>y. y \<in> X \<and> x \<in> y"}\<close>
apply (rule_tac x="Cons(X,Nil)" in bexI)
 apply (rule_tac x="Exists(And(Member(0,2), Member(1,0)))" in bexI)
  apply typecheck
apply (simp add: succ_Un_distrib [symmetric], blast)
done

theorem Union_in_L: "L(X) ==> L(\<Union>(X))"
by (simp add: L_def, blast dest: Union_in_Lset)

subsubsection\<open>Finite sets and ordered pairs\<close>

lemma singleton_in_Lset: "a \<in> Lset(i) ==> {a} \<in> Lset(succ(i))"
by (simp add: Lset_succ singleton_in_DPow)

lemma doubleton_in_Lset:
     "[| a \<in> Lset(i);  b \<in> Lset(i) |] ==> {a,b} \<in> Lset(succ(i))"
by (simp add: Lset_succ empty_in_DPow cons_in_DPow)

lemma Pair_in_Lset:
    "[| a \<in> Lset(i);  b \<in> Lset(i); Ord(i) |] ==> <a,b> \<in> Lset(succ(succ(i)))"
apply (unfold Pair_def)
apply (blast intro: doubleton_in_Lset)
done

lemmas Lset_UnI1 = Un_upper1 [THEN Lset_mono [THEN subsetD]]
lemmas Lset_UnI2 = Un_upper2 [THEN Lset_mono [THEN subsetD]]

text\<open>Hard work is finding a single @{term"j \<in> i"} such that @{term"{a,b} \<subseteq> Lset(j)"}\<close>
lemma doubleton_in_LLimit:
    "[| a \<in> Lset(i);  b \<in> Lset(i);  Limit(i) |] ==> {a,b} \<in> Lset(i)"
apply (erule Limit_LsetE, assumption)
apply (erule Limit_LsetE, assumption)
apply (blast intro: lt_LsetI [OF doubleton_in_Lset]
                    Lset_UnI1 Lset_UnI2 Limit_has_succ Un_least_lt)
done

theorem doubleton_in_L: "[| L(a); L(b) |] ==> L({a, b})"
apply (simp add: L_def, clarify)
apply (drule Ord2_imp_greater_Limit, assumption)
apply (blast intro: lt_LsetI doubleton_in_LLimit Limit_is_Ord)
done

lemma Pair_in_LLimit:
    "[| a \<in> Lset(i);  b \<in> Lset(i);  Limit(i) |] ==> <a,b> \<in> Lset(i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_LsetE, assumption)
apply (erule Limit_LsetE, assumption)
txt\<open>Infer that @{term"succ(succ(x \<union> xa)) < i"}\<close>
apply (blast intro: lt_Ord lt_LsetI [OF Pair_in_Lset]
                    Lset_UnI1 Lset_UnI2 Limit_has_succ Un_least_lt)
done

text\<open>The rank function for the constructible universe\<close>
definition
  lrank :: "i=>i" where \<comment>\<open>Kunen's definition VI 1.7\<close>
  "lrank(x) == \<mu> i. x \<in> Lset(succ(i))"

lemma L_I: "[|x \<in> Lset(i); Ord(i)|] ==> L(x)"
by (simp add: L_def, blast)

lemma L_D: "L(x) ==> \<exists>i. Ord(i) & x \<in> Lset(i)"
by (simp add: L_def)

lemma Ord_lrank [simp]: "Ord(lrank(a))"
by (simp add: lrank_def)

lemma Lset_lrank_lt [rule_format]: "Ord(i) ==> x \<in> Lset(i) \<longrightarrow> lrank(x) < i"
apply (erule trans_induct3)
  apply simp
 apply (simp only: lrank_def)
 apply (blast intro: Least_le)
apply (simp_all add: Limit_Lset_eq)
apply (blast intro: ltI Limit_is_Ord lt_trans)
done

text\<open>Kunen's VI 1.8.  The proof is much harder than the text would
suggest.  For a start, it needs the previous lemma, which is proved by
induction.\<close>
lemma Lset_iff_lrank_lt: "Ord(i) ==> x \<in> Lset(i) \<longleftrightarrow> L(x) & lrank(x) < i"
apply (simp add: L_def, auto)
 apply (blast intro: Lset_lrank_lt)
 apply (unfold lrank_def)
apply (drule succI1 [THEN Lset_mono_mem, THEN subsetD])
apply (drule_tac P="\<lambda>i. x \<in> Lset(succ(i))" in LeastI, assumption)
apply (blast intro!: le_imp_subset Lset_mono [THEN subsetD])
done

lemma Lset_succ_lrank_iff [simp]: "x \<in> Lset(succ(lrank(x))) \<longleftrightarrow> L(x)"
by (simp add: Lset_iff_lrank_lt)

text\<open>Kunen's VI 1.9 (a)\<close>
lemma lrank_of_Ord: "Ord(i) ==> lrank(i) = i"
apply (unfold lrank_def)
apply (rule Least_equality)
  apply (erule Ord_in_Lset)
 apply assumption
apply (insert notin_Lset [of i])
apply (blast intro!: le_imp_subset Lset_mono [THEN subsetD])
done

text\<open>This is lrank(lrank(a)) = lrank(a)\<close>
declare Ord_lrank [THEN lrank_of_Ord, simp]

text\<open>Kunen's VI 1.10\<close>
lemma Lset_in_Lset_succ: "Lset(i) \<in> Lset(succ(i))"
apply (simp add: Lset_succ DPow_def)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="Equal(0,0)" in bexI)
apply auto
done

lemma lrank_Lset: "Ord(i) ==> lrank(Lset(i)) = i"
apply (unfold lrank_def)
apply (rule Least_equality)
  apply (rule Lset_in_Lset_succ)
 apply assumption
apply clarify
apply (subgoal_tac "Lset(succ(ia)) \<subseteq> Lset(i)")
 apply (blast dest: mem_irrefl)
apply (blast intro!: le_imp_subset Lset_mono)
done

text\<open>Kunen's VI 1.11\<close>
lemma Lset_subset_Vset: "Ord(i) ==> Lset(i) \<subseteq> Vset(i)"
apply (erule trans_induct)
apply (subst Lset)
apply (subst Vset)
apply (rule UN_mono [OF subset_refl])
apply (rule subset_trans [OF DPow_subset_Pow])
apply (rule Pow_mono, blast)
done

text\<open>Kunen's VI 1.12\<close>
lemma Lset_subset_Vset': "i \<in> nat ==> Lset(i) = Vset(i)"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Lset_succ Vset_succ Finite_Vset Finite_DPow_eq_Pow)
done

text\<open>Every set of constructible sets is included in some @{term Lset}\<close>
lemma subset_Lset:
     "(\<forall>x\<in>A. L(x)) ==> \<exists>i. Ord(i) & A \<subseteq> Lset(i)"
by (rule_tac x = "\<Union>x\<in>A. succ(lrank(x))" in exI, force)

lemma subset_LsetE:
     "[|\<forall>x\<in>A. L(x);
        !!i. [|Ord(i); A \<subseteq> Lset(i)|] ==> P|]
      ==> P"
by (blast dest: subset_Lset)

subsubsection\<open>For L to satisfy the Powerset axiom\<close>

lemma LPow_env_typing:
    "[| y \<in> Lset(i); Ord(i); y \<subseteq> X |]
     ==> \<exists>z \<in> Pow(X). y \<in> Lset(succ(lrank(z)))"
by (auto intro: L_I iff: Lset_succ_lrank_iff)

lemma LPow_in_Lset:
     "[|X \<in> Lset(i); Ord(i)|] ==> \<exists>j. Ord(j) & {y \<in> Pow(X). L(y)} \<in> Lset(j)"
apply (rule_tac x="succ(\<Union>y \<in> Pow(X). succ(lrank(y)))" in exI)
apply simp
apply (rule LsetI [OF succI1])
apply (simp add: DPow_def)
apply (intro conjI, clarify)
 apply (rule_tac a=x in UN_I, simp+)
txt\<open>Now to create the formula @{term "y \<subseteq> X"}\<close>
apply (rule_tac x="Cons(X,Nil)" in bexI)
 apply (rule_tac x="subset_fm(0,1)" in bexI)
  apply typecheck
 apply (rule conjI)
apply (simp add: succ_Un_distrib [symmetric])
apply (rule equality_iffI)
apply (simp add: Transset_UN [OF Transset_Lset] LPow_env_typing)
apply (auto intro: L_I iff: Lset_succ_lrank_iff)
done

theorem LPow_in_L: "L(X) ==> L({y \<in> Pow(X). L(y)})"
by (blast intro: L_I dest: L_D LPow_in_Lset)

subsection\<open>Eliminating @{term arity} from the Definition of @{term Lset}\<close>

lemma nth_zero_eq_0: "n \<in> nat ==> nth(n,[0]) = 0"
by (induct_tac n, auto)

lemma sats_app_0_iff [rule_format]:
  "[| p \<in> formula; 0 \<in> A |]
   ==> \<forall>env \<in> list(A). sats(A,p, env@[0]) \<longleftrightarrow> sats(A,p,env)"
apply (induct_tac p)
apply (simp_all del: app_Cons add: app_Cons [symmetric]
                add: nth_zero_eq_0 nth_append not_lt_iff_le nth_eq_0)
done

lemma sats_app_zeroes_iff:
  "[| p \<in> formula; 0 \<in> A; env \<in> list(A); n \<in> nat |]
   ==> sats(A,p,env @ repeat(0,n)) \<longleftrightarrow> sats(A,p,env)"
apply (induct_tac n, simp)
apply (simp del: repeat.simps
            add: repeat_succ_app sats_app_0_iff app_assoc [symmetric])
done

lemma exists_bigger_env:
  "[| p \<in> formula; 0 \<in> A; env \<in> list(A) |]
   ==> \<exists>env' \<in> list(A). arity(p) \<le> succ(length(env')) &
              (\<forall>a\<in>A. sats(A,p,Cons(a,env')) \<longleftrightarrow> sats(A,p,Cons(a,env)))"
apply (rule_tac x="env @ repeat(0,arity(p))" in bexI)
apply (simp del: app_Cons add: app_Cons [symmetric]
            add: length_repeat sats_app_zeroes_iff, typecheck)
done

text\<open>A simpler version of @{term DPow}: no arity check!\<close>
definition
  DPow' :: "i => i" where
  "DPow'(A) == {X \<in> Pow(A).
                \<exists>env \<in> list(A). \<exists>p \<in> formula.
                    X = {x\<in>A. sats(A, p, Cons(x,env))}}"

lemma DPow_subset_DPow': "DPow(A) \<subseteq> DPow'(A)"
by (simp add: DPow_def DPow'_def, blast)

lemma DPow'_0: "DPow'(0) = {0}"
by (auto simp add: DPow'_def)

lemma DPow'_subset_DPow: "0 \<in> A ==> DPow'(A) \<subseteq> DPow(A)"
apply (auto simp add: DPow'_def DPow_def)
apply (frule exists_bigger_env, assumption+, force)
done

lemma DPow_eq_DPow': "Transset(A) ==> DPow(A) = DPow'(A)"
apply (drule Transset_0_disj)
apply (erule disjE)
 apply (simp add: DPow'_0 Finite_DPow_eq_Pow)
apply (rule equalityI)
 apply (rule DPow_subset_DPow')
apply (erule DPow'_subset_DPow)
done

text\<open>And thus we can relativize @{term Lset} without bothering with
      @{term arity} and @{term length}\<close>
lemma Lset_eq_transrec_DPow': "Lset(i) = transrec(i, %x f. \<Union>y\<in>x. DPow'(f`y))"
apply (rule_tac a=i in eps_induct)
apply (subst Lset)
apply (subst transrec)
apply (simp only: DPow_eq_DPow' [OF Transset_Lset], simp)
done

text\<open>With this rule we can specify @{term p} later and don't worry about
      arities at all!\<close>
lemma DPow_LsetI [rule_format]:
  "[|\<forall>x\<in>Lset(i). P(x) \<longleftrightarrow> sats(Lset(i), p, Cons(x,env));
     env \<in> list(Lset(i));  p \<in> formula|]
   ==> {x\<in>Lset(i). P(x)} \<in> DPow(Lset(i))"
by (simp add: DPow_eq_DPow' [OF Transset_Lset] DPow'_def, blast)

end


(*  Title:       More about Multisets
    Author:      Mathias Fleury <mathias.fleury at mpi-inf.mpg.de>, 2015
    Author:      Jasmin Blanchette <blanchette at in.tum.de>, 2014, 2015
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Author:      Dmitriy Traytel <traytel at in.tum.de>, 2014
    Maintainer:  Mathias Fleury <mathias.fleury at mpi-inf.mpg.de>
*)

section \<open>More about Multisets\<close>

theory Multiset_More
imports "HOL-Library.Multiset_Order"
begin

text \<open>
Isabelle's theory of finite multisets is not as developed as other areas, such as lists and sets.
The present theory introduces some missing concepts and lemmas. Some of it is expected to move to
Isabelle's library.
\<close>

subsection \<open>Basic Setup\<close>

declare
  diff_single_trivial [simp]
  in_image_mset [iff]
  image_mset.compositionality [simp]

  (*To have the same rules as the set counter-part*)
  mset_subset_eqD[dest, intro?] (*@{thm subsetD}*)

  Multiset.in_multiset_in_set[simp]
  inter_add_left1[simp]
  inter_add_left2[simp]
  inter_add_right1[simp]
  inter_add_right2[simp]

  sum_mset_sum_list[simp]

subsection \<open>Lemmas about Intersection, Union and Pointwise Inclusion\<close>

lemma subset_add_mset_notin_subset_mset: \<open>A \<subseteq># add_mset b B \<Longrightarrow> b \<notin># A \<Longrightarrow> A \<subseteq># B\<close>
  by (simp add: subset_mset.le_iff_sup)

lemma subset_msetE: "\<lbrakk>A \<subset># B; \<lbrakk>A \<subseteq># B; \<not> B \<subseteq># A\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (simp add: subset_mset.less_le_not_le)

lemma Diff_triv_mset: "M \<inter># N = {#} \<Longrightarrow> M - N = M"
  by (metis diff_intersect_left_idem diff_zero)

lemma diff_intersect_sym_diff: "(A - B) \<inter># (B - A) = {#}"
  unfolding multiset_inter_def
proof -
  have "A - (B - (B - A)) = A - B"
    by (metis diff_intersect_right_idem multiset_inter_def)
  then show "A - B - (A - B - (B - A)) = {#}"
    by (metis diff_add diff_cancel diff_subset_eq_self subset_mset.diff_add)
qed

declare subset_msetE [elim!]

subsection \<open>Lemmas about Filter and Image\<close>

lemma count_image_mset_ge_count: "count (image_mset f A) (f b) \<ge> count A b"
  by (induction A) auto

lemma count_image_mset_inj:
  assumes \<open>inj f\<close>
  shows \<open>count (image_mset f M) (f x) = count M x\<close>
  by (induct M) (use assms in \<open>auto simp: inj_on_def\<close>)

lemma count_image_mset_le_count_inj_on:
  "inj_on f (set_mset M) \<Longrightarrow> count (image_mset f M) y \<le> count M (inv_into (set_mset M) f y)"
proof (induct M)
  case (add x M)
  note ih = this(1) and inj_xM = this(2)

  have inj_M: "inj_on f (set_mset M)"
    using inj_xM by simp

  show ?case
  proof (cases "x \<in># M")
    case x_in_M: True
    show ?thesis
    proof (cases "y = f x")
      case y_eq_fx: True
      show ?thesis
        using x_in_M ih[OF inj_M] unfolding y_eq_fx by (simp add: inj_M insert_absorb)
    next
      case y_ne_fx: False
      show ?thesis
        using x_in_M ih[OF inj_M] y_ne_fx insert_absorb by fastforce
    qed
  next
    case x_ni_M: False
    show ?thesis
    proof (cases "y = f x")
      case y_eq_fx: True
      have "f x \<notin># image_mset f M"
        using x_ni_M inj_xM by force
      thus ?thesis
        unfolding y_eq_fx
        by (metis (no_types) inj_xM count_add_mset count_greater_eq_Suc_zero_iff count_inI
          image_mset_add_mset inv_into_f_f union_single_eq_member)
    next
      case y_ne_fx: False
      show ?thesis
      proof (rule ccontr)
        assume neg_conj: "\<not> count (image_mset f (add_mset x M)) y
          \<le> count (add_mset x M) (inv_into (set_mset (add_mset x M)) f y)"

        have cnt_y: "count (add_mset (f x) (image_mset f M)) y = count (image_mset f M) y"
          using y_ne_fx by simp

        have "inv_into (set_mset M) f y \<in># add_mset x M \<Longrightarrow>
          inv_into (set_mset (add_mset x M)) f (f (inv_into (set_mset M) f y)) =
          inv_into (set_mset M) f y"
          by (meson inj_xM inv_into_f_f)
        hence "0 < count (image_mset f (add_mset x M)) y \<Longrightarrow>
          count M (inv_into (set_mset M) f y) = 0 \<or> x = inv_into (set_mset M) f y"
          using neg_conj cnt_y ih[OF inj_M]
          by (metis (no_types) count_add_mset count_greater_zero_iff count_inI f_inv_into_f
            image_mset_add_mset set_image_mset)
        thus False
          using neg_conj cnt_y x_ni_M ih[OF inj_M]
          by (metis (no_types) count_greater_zero_iff count_inI eq_iff image_mset_add_mset
            less_imp_le)
      qed
    qed
  qed
qed simp

lemma mset_filter_compl: "mset (filter p xs) + mset (filter (Not \<circ> p) xs) = mset xs"
  by (induction xs) (auto simp: mset_filter ac_simps)

text \<open>Near duplicate of @{thm [source] filter_eq_replicate_mset}: @{thm filter_eq_replicate_mset}.\<close>

lemma filter_mset_eq: "filter_mset ((=) L) A = replicate_mset (count A L) L"
  by (auto simp: multiset_eq_iff)

lemma filter_mset_cong[fundef_cong]:
  assumes "M = M'" "\<And>a. a \<in># M \<Longrightarrow> P a = Q a"
  shows "filter_mset P M = filter_mset Q M"
proof -
  have "M - filter_mset Q M = filter_mset (\<lambda>a. \<not>Q a) M"
    by (metis multiset_partition add_diff_cancel_left')
  then show ?thesis
    by (auto simp: filter_mset_eq_conv assms)
qed

lemma image_mset_filter_swap: "image_mset f {# x \<in># M. P (f x)#} = {# x \<in># image_mset f M. P x#}"
  by (induction M) auto

lemma image_mset_cong2:
  "(\<And>x. x \<in># M \<Longrightarrow> f x = g x) \<Longrightarrow> M = N \<Longrightarrow> image_mset f M = image_mset g N"
  by (hypsubst, rule image_mset_cong)

lemma filter_mset_empty_conv: \<open>(filter_mset P M = {#}) = (\<forall>L\<in>#M. \<not> P L)\<close>
  by (induction M) auto

lemma multiset_filter_mono2: \<open>filter_mset P A \<subseteq># filter_mset Q A \<longleftrightarrow> (\<forall>a\<in>#A. P a \<longrightarrow> Q a)\<close>
  by (induction A) (auto intro: subset_mset.order.trans)

lemma image_filter_cong:
  assumes \<open>\<And>C. C \<in># M \<Longrightarrow> P C \<Longrightarrow> f C = g C\<close>
  shows \<open>{#f C. C \<in># {#C \<in># M. P C#}#} = {#g C | C\<in># M. P C#}\<close>
  using assms by (induction M) auto

lemma image_mset_filter_swap2: \<open>{#C \<in># {#P x. x \<in># D#}. Q C #} = {#P x. x \<in># {#C| C \<in># D. Q (P C)#}#}\<close>
  by (simp add: image_mset_filter_swap)

declare image_mset_cong2 [cong]

subsection \<open>Lemmas about Sum\<close>

lemma sum_image_mset_sum_map[simp]: "sum_mset (image_mset f (mset xs)) = sum_list (map f xs)"
  by (metis mset_map sum_mset_sum_list)

lemma sum_image_mset_mono:
  fixes f :: "'a \<Rightarrow> 'b::canonically_ordered_monoid_add"
  assumes sub: "A \<subseteq># B"
  shows "(\<Sum>m \<in># A. f m) \<le> (\<Sum>m \<in># B. f m)"
  by (metis image_mset_union le_iff_add sub subset_mset.add_diff_inverse sum_mset.union)

lemma sum_image_mset_mono_mem:
  "n \<in># M \<Longrightarrow> f n \<le> (\<Sum>m \<in># M. f m)" for f :: "'a \<Rightarrow> 'b::canonically_ordered_monoid_add"
  using le_iff_add multi_member_split by fastforce

lemma count_sum_mset_if_1_0: \<open>count M a = (\<Sum>x\<in>#M. if x = a then 1 else 0)\<close>
  by (induction M) auto

lemma sum_mset_dvd:
  fixes k :: "'a::comm_semiring_1_cancel"
  assumes "\<forall>m \<in># M. k dvd f m"
  shows "k dvd (\<Sum>m \<in># M. f m)"
  using assms by (induct M) auto

subsection \<open>Lemmas about Remove\<close>

lemma set_mset_minus_replicate_mset[simp]:
  "n \<ge> count A a \<Longrightarrow> set_mset (A - replicate_mset n a) = set_mset A - {a}"
  "n < count A a \<Longrightarrow> set_mset (A - replicate_mset n a) = set_mset A"
  unfolding set_mset_def by (auto split: if_split simp: not_in_iff)

abbreviation removeAll_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "removeAll_mset C M \<equiv> M - replicate_mset (count M C) C"

lemma mset_removeAll[simp, code]: "removeAll_mset C (mset L) = mset (removeAll C L)"
  by (induction L) (auto simp: ac_simps multiset_eq_iff split: if_split_asm)

lemma removeAll_mset_filter_mset: "removeAll_mset C M = filter_mset ((\<noteq>) C) M"
  by (induction M) (auto simp: ac_simps multiset_eq_iff)

abbreviation remove1_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "remove1_mset C M \<equiv> M - {#C#}"

lemma removeAll_subseteq_remove1_mset: "removeAll_mset x M \<subseteq># remove1_mset x M"
  by (auto simp: subseteq_mset_def)

lemma in_remove1_mset_neq:
  assumes ab: "a \<noteq> b"
  shows "a \<in># remove1_mset b C \<longleftrightarrow> a \<in># C"
  by (metis assms diff_single_trivial in_diffD insert_DiffM insert_noteq_member)

lemma size_mset_removeAll_mset_le_iff: "size (removeAll_mset x M) < size M \<longleftrightarrow> x \<in># M"
  by (auto intro: count_inI mset_subset_size simp: subset_mset_def multiset_eq_iff)

lemma size_remove1_mset_If: \<open>size (remove1_mset x M) = size M - (if x \<in># M then 1 else 0)\<close>
  by (auto simp: size_Diff_subset_Int)

lemma size_mset_remove1_mset_le_iff: "size (remove1_mset x M) < size M \<longleftrightarrow> x \<in># M"
  using less_irrefl
  by (fastforce intro!: mset_subset_size elim: in_countE simp: subset_mset_def multiset_eq_iff)

lemma remove_1_mset_id_iff_notin: "remove1_mset a M = M \<longleftrightarrow> a \<notin># M"
  by (meson diff_single_trivial multi_drop_mem_not_eq)

lemma id_remove_1_mset_iff_notin: "M = remove1_mset a M \<longleftrightarrow> a \<notin># M"
  using remove_1_mset_id_iff_notin by metis

lemma remove1_mset_eqE:
  "remove1_mset L x1 = M \<Longrightarrow>
    (L \<in># x1 \<Longrightarrow> x1 = M + {#L#} \<Longrightarrow> P) \<Longrightarrow>
    (L \<notin># x1 \<Longrightarrow> x1 = M \<Longrightarrow> P) \<Longrightarrow>
  P"
  by (cases "L \<in># x1") auto

lemma image_filter_ne_mset[simp]:
  "image_mset f {#x \<in># M. f x \<noteq> y#} = removeAll_mset y (image_mset f M)"
  by (induction M) simp_all

lemma image_mset_remove1_mset_if:
  "image_mset f (remove1_mset a M) =
   (if a \<in># M then remove1_mset (f a) (image_mset f M) else image_mset f M)"
  by (auto simp: image_mset_Diff)

lemma filter_mset_neq: "{#x \<in># M. x \<noteq> y#} = removeAll_mset y M"
  by (metis add_diff_cancel_left' filter_eq_replicate_mset multiset_partition)

lemma filter_mset_neq_cond: "{#x \<in># M. P x \<and> x \<noteq> y#} = removeAll_mset y {# x\<in>#M. P x#}"
  by (metis filter_filter_mset filter_mset_neq)

lemma remove1_mset_add_mset_If:
  "remove1_mset L (add_mset L' C) = (if L = L' then C else remove1_mset L C + {#L'#})"
  by (auto simp: multiset_eq_iff)

lemma minus_remove1_mset_if:
  "A - remove1_mset b B = (if b \<in># B \<and> b \<in># A \<and> count A b \<ge> count B b then {#b#} + (A - B) else A - B)"
  by (auto simp: multiset_eq_iff count_greater_zero_iff[symmetric]
    simp del: count_greater_zero_iff)

lemma add_mset_eq_add_mset_ne:
  "a \<noteq> b \<Longrightarrow> add_mset a A = add_mset b B \<longleftrightarrow> a \<in># B \<and> b \<in># A \<and> A = add_mset b (B - {#a#})"
  by (metis (no_types, lifting) diff_single_eq_union diff_union_swap multi_self_add_other_not_self
    remove_1_mset_id_iff_notin union_single_eq_diff)

lemma add_mset_eq_add_mset: \<open>add_mset a M = add_mset b M' \<longleftrightarrow>
  (a = b \<and> M = M') \<or> (a \<noteq> b \<and> b \<in># M \<and> add_mset a (M - {#b#}) = M')\<close>
  by (metis add_mset_eq_add_mset_ne add_mset_remove_trivial union_single_eq_member)

(* TODO move to Multiset: could replace add_mset_remove_trivial_eq? *)
lemma add_mset_remove_trivial_iff: \<open>N = add_mset a (N - {#b#}) \<longleftrightarrow> a \<in># N \<and> a = b\<close>
  by (metis add_left_cancel add_mset_remove_trivial insert_DiffM2 single_eq_single
      size_mset_remove1_mset_le_iff union_single_eq_member)

lemma trivial_add_mset_remove_iff: \<open>add_mset a (N - {#b#}) = N \<longleftrightarrow> a \<in># N \<and> a = b\<close>
  by (subst eq_commute) (fact add_mset_remove_trivial_iff)

lemma remove1_single_empty_iff[simp]: \<open>remove1_mset L {#L'#} = {#} \<longleftrightarrow> L = L'\<close>
  using add_mset_remove_trivial_iff by fastforce

lemma add_mset_less_imp_less_remove1_mset:
  assumes xM_lt_N: "add_mset x M < N"
  shows "M < remove1_mset x N"
proof -
  have "M < N"
    using assms le_multiset_right_total mset_le_trans by blast
  then show ?thesis
    by (metis add_less_cancel_right add_mset_add_single diff_single_trivial insert_DiffM2 xM_lt_N)
qed

subsection \<open>Lemmas about Replicate\<close>

lemma replicate_mset_minus_replicate_mset_same[simp]:
  "replicate_mset m x - replicate_mset n x = replicate_mset (m - n) x"
  by (induct m arbitrary: n, simp, metis left_diff_repeat_mset_distrib' repeat_mset_replicate_mset)

lemma replicate_mset_subset_iff_lt[simp]: "replicate_mset m x \<subset># replicate_mset n x \<longleftrightarrow> m < n"
  by (induct n m rule: diff_induct) (auto intro: subset_mset.gr_zeroI)

lemma replicate_mset_subseteq_iff_le[simp]: "replicate_mset m x \<subseteq># replicate_mset n x \<longleftrightarrow> m \<le> n"
  by (induct n m rule: diff_induct) auto

lemma replicate_mset_lt_iff_lt[simp]: "replicate_mset m x < replicate_mset n x \<longleftrightarrow> m < n"
  by (induct n m rule: diff_induct) (auto intro: subset_mset.gr_zeroI gr_zeroI)

lemma replicate_mset_le_iff_le[simp]: "replicate_mset m x \<le> replicate_mset n x \<longleftrightarrow> m \<le> n"
  by (induct n m rule: diff_induct) auto

lemma replicate_mset_eq_iff[simp]:
  "replicate_mset m x = replicate_mset n y \<longleftrightarrow> m = n \<and> (m \<noteq> 0 \<longrightarrow> x = y)"
  by (cases m; cases n; simp)
    (metis in_replicate_mset insert_noteq_member size_replicate_mset union_single_eq_diff)

lemma replicate_mset_plus: "replicate_mset (a + b) C = replicate_mset a C + replicate_mset b C"
  by (induct a) (auto simp: ac_simps)

lemma mset_replicate_replicate_mset: "mset (replicate n L) = replicate_mset n L"
  by (induction n) auto

lemma set_mset_single_iff_replicate_mset: "set_mset U = {a} \<longleftrightarrow> (\<exists>n > 0. U = replicate_mset n a)"
  by (rule, metis count_greater_zero_iff count_replicate_mset insertI1 multi_count_eq singletonD
    zero_less_iff_neq_zero, force)

lemma ex_replicate_mset_if_all_elems_eq:
  assumes "\<forall>x \<in># M. x = y"
  shows "\<exists>n. M = replicate_mset n y"
  using assms by (metis count_replicate_mset mem_Collect_eq multiset_eqI neq0_conv set_mset_def)

subsection \<open>Multiset and Set Conversions\<close>

lemma count_mset_set_if: "count (mset_set A) a = (if a \<in> A \<and> finite A then 1 else 0)"
  by auto

lemma mset_set_set_mset_empty_mempty[iff]: "mset_set (set_mset D) = {#} \<longleftrightarrow> D = {#}"
  by (simp add: mset_set_empty_iff)

lemma count_mset_set_le_one: "count (mset_set A) x \<le> 1"
  by (simp add: count_mset_set_if)

lemma mset_set_set_mset_subseteq[simp]: "mset_set (set_mset A) \<subseteq># A"
  by (simp add: mset_set_set_mset_msubset)

lemma mset_sorted_list_of_set[simp]: "mset (sorted_list_of_set A) = mset_set A"
  by (metis mset_sorted_list_of_multiset sorted_list_of_mset_set)

lemma mset_take_subseteq: "mset (take n xs) \<subseteq># mset xs"
  apply (induct xs arbitrary: n)
   apply simp
  by (case_tac n) simp_all

lemma sorted_list_of_multiset_eq_Nil[simp]: "sorted_list_of_multiset M = [] \<longleftrightarrow> M = {#}"
  by (metis mset_sorted_list_of_multiset sorted_list_of_multiset_empty)

subsection \<open>Duplicate Removal\<close>

(* TODO: use abbreviation? *)
definition remdups_mset :: "'v multiset \<Rightarrow> 'v multiset" where
  "remdups_mset S = mset_set (set_mset S)"

lemma set_mset_remdups_mset[simp]: \<open>set_mset (remdups_mset A) = set_mset A\<close>
  unfolding remdups_mset_def by auto

lemma count_remdups_mset_eq_1: "a \<in># remdups_mset A \<longleftrightarrow> count (remdups_mset A) a = 1"
  unfolding remdups_mset_def by (auto simp: count_eq_zero_iff intro: count_inI)

lemma remdups_mset_empty[simp]: "remdups_mset {#} = {#}"
  unfolding remdups_mset_def by auto

lemma remdups_mset_singleton[simp]: "remdups_mset {#a#} = {#a#}"
  unfolding remdups_mset_def by auto

lemma remdups_mset_eq_empty[iff]: "remdups_mset D = {#} \<longleftrightarrow> D = {#}"
  unfolding remdups_mset_def by blast

lemma remdups_mset_singleton_sum[simp]:
  "remdups_mset (add_mset a A) = (if a \<in># A then remdups_mset A else add_mset a (remdups_mset A))"
  unfolding remdups_mset_def by (simp_all add: insert_absorb)

lemma mset_remdups_remdups_mset[simp]: "mset (remdups D) = remdups_mset (mset D)"
  by (induction D) (auto simp add: ac_simps)

declare mset_remdups_remdups_mset[symmetric, code]

definition distinct_mset :: "'a multiset \<Rightarrow> bool" where
  "distinct_mset S \<longleftrightarrow> (\<forall>a. a \<in># S \<longrightarrow> count S a = 1)"

lemma distinct_mset_count_less_1: "distinct_mset S \<longleftrightarrow> (\<forall>a. count S a \<le> 1)"
  using eq_iff nat_le_linear unfolding distinct_mset_def by fastforce

lemma distinct_mset_empty[simp]: "distinct_mset {#}"
  unfolding distinct_mset_def by auto

lemma distinct_mset_singleton: "distinct_mset {#a#}"
  unfolding distinct_mset_def by auto

lemma distinct_mset_union:
  assumes dist: "distinct_mset (A + B)"
  shows "distinct_mset A"
  unfolding distinct_mset_count_less_1
proof (rule allI)
  fix a
  have \<open>count A a \<le> count (A + B) a\<close> by auto
  moreover have \<open>count (A + B) a \<le> 1\<close>
    using dist unfolding distinct_mset_count_less_1 by auto
  ultimately show \<open>count A a \<le> 1\<close>
    by simp
qed

lemma distinct_mset_minus[simp]: "distinct_mset A \<Longrightarrow> distinct_mset (A - B)"
  by (metis diff_subset_eq_self mset_subset_eq_exists_conv distinct_mset_union)

lemma count_remdups_mset_If: \<open>count (remdups_mset A) a = (if a \<in># A then 1 else 0)\<close>
  unfolding remdups_mset_def by auto

lemma distinct_mset_rempdups_union_mset:
  assumes "distinct_mset A" and "distinct_mset B"
  shows "A \<union># B = remdups_mset (A + B)"
  using assms nat_le_linear unfolding remdups_mset_def
  by (force simp add: multiset_eq_iff max_def count_mset_set_if distinct_mset_def not_in_iff)

lemma distinct_mset_add_mset[simp]: "distinct_mset (add_mset a L) \<longleftrightarrow> a \<notin># L \<and> distinct_mset L"
  unfolding distinct_mset_def
  apply (rule iffI)
   apply (auto split: if_split_asm; fail)[]
  by (auto simp: not_in_iff; fail)

lemma distinct_mset_size_eq_card: "distinct_mset C \<Longrightarrow> size C = card (set_mset C)"
  by (induction C) auto

lemma distinct_mset_add:
  "distinct_mset (L + L') \<longleftrightarrow> distinct_mset L \<and> distinct_mset L' \<and> L \<inter># L' = {#}"
  by (induction L arbitrary: L') auto

lemma distinct_mset_set_mset_ident[simp]: "distinct_mset M \<Longrightarrow> mset_set (set_mset M) = M"
  by (induction M) auto

lemma distinct_finite_set_mset_subseteq_iff[iff]:
  assumes "distinct_mset M" "finite N"
  shows "set_mset M \<subseteq> N \<longleftrightarrow> M \<subseteq># mset_set N"
  by (metis assms distinct_mset_set_mset_ident finite_set_mset msubset_mset_set_iff)

lemma distinct_mem_diff_mset:
  assumes dist: "distinct_mset M" and mem: "x \<in> set_mset (M - N)"
  shows "x \<notin> set_mset N"
proof -
  have "count M x = 1"
    using dist mem by (meson distinct_mset_def in_diffD)
  then show ?thesis
    using mem by (metis count_greater_eq_one_iff in_diff_count not_less)
qed

lemma distinct_set_mset_eq:
  assumes "distinct_mset M" "distinct_mset N" "set_mset M = set_mset N"
  shows "M = N"
  using assms distinct_mset_set_mset_ident by fastforce

lemma distinct_mset_union_mset[simp]:
  \<open>distinct_mset (D \<union># C) \<longleftrightarrow> distinct_mset D \<and> distinct_mset C\<close>
  unfolding distinct_mset_count_less_1 by force

lemma distinct_mset_inter_mset:
  "distinct_mset C \<Longrightarrow> distinct_mset (C \<inter># D)"
  "distinct_mset D \<Longrightarrow> distinct_mset (C \<inter># D)"
  by (simp_all add: multiset_inter_def,
    metis distinct_mset_minus multiset_inter_commute multiset_inter_def)

lemma distinct_mset_remove1_All: "distinct_mset C \<Longrightarrow> remove1_mset L C = removeAll_mset L C"
  by (auto simp: multiset_eq_iff distinct_mset_count_less_1)

lemma distinct_mset_size_2: "distinct_mset {#a, b#} \<longleftrightarrow> a \<noteq> b"
  by auto

lemma distinct_mset_filter: "distinct_mset M \<Longrightarrow> distinct_mset {# L \<in># M. P L#}"
  by (simp add: distinct_mset_def)

lemma distinct_mset_mset_distinct[simp]: \<open>distinct_mset (mset xs) = distinct xs\<close>
  by (induction xs) auto

lemma distinct_image_mset_inj:
  \<open>inj_on f (set_mset M) \<Longrightarrow> distinct_mset (image_mset f M) \<longleftrightarrow> distinct_mset M\<close>
  by (induction M) (auto simp: inj_on_def)

subsection \<open>Repeat Operation\<close>

lemma repeat_mset_compower: "repeat_mset n A = (((+) A) ^^ n) {#}"
  by (induction n) auto

lemma repeat_mset_prod: "repeat_mset (m * n) A = (((+) (repeat_mset n A)) ^^ m) {#}"
  by (induction m) (auto simp: repeat_mset_distrib)

subsection \<open>Cartesian Product\<close>

text \<open>Definition of the cartesian products over multisets. The construction mimics of the cartesian
  product on sets and use the same theorem names (adding only the suffix \<open>_mset\<close> to Sigma
  and Times). See file @{file \<open>~~/src/HOL/Product_Type.thy\<close>}\<close>

definition Sigma_mset :: "'a multiset \<Rightarrow> ('a \<Rightarrow> 'b multiset) \<Rightarrow> ('a \<times> 'b) multiset" where
  "Sigma_mset A B \<equiv> \<Union># {#{#(a, b). b \<in># B a#}. a \<in># A #}"

abbreviation Times_mset :: "'a multiset \<Rightarrow> 'b multiset \<Rightarrow> ('a \<times> 'b) multiset" (infixr "\<times>#" 80) where
  "Times_mset A B \<equiv> Sigma_mset A (\<lambda>_. B)"

hide_const (open) Times_mset

text \<open>Contrary to the set version @{term \<open>SIGMA x:A. B\<close>}, we use the non-ASCII symbol \<open>\<in>#\<close>.\<close>

syntax
  "_Sigma_mset" :: "[pttrn, 'a multiset, 'b multiset] => ('a * 'b) multiset"
  ("(3SIGMAMSET _\<in>#_./ _)" [0, 0, 10] 10)
translations
  "SIGMAMSET x\<in>#A. B" == "CONST Sigma_mset A (\<lambda>x. B)"

text \<open>Link between the multiset and the set cartesian product:\<close>

lemma Times_mset_Times: "set_mset (A \<times># B) = set_mset A \<times> set_mset B"
  unfolding Sigma_mset_def by auto

lemma Sigma_msetI [intro!]: "\<lbrakk>a \<in># A; b \<in># B a\<rbrakk> \<Longrightarrow> (a, b) \<in># Sigma_mset A B"
  by (unfold Sigma_mset_def) auto

lemma Sigma_msetE[elim!]: "\<lbrakk>c \<in># Sigma_mset A B; \<And>x y. \<lbrakk>x \<in># A; y \<in># B x; c = (x, y)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (unfold Sigma_mset_def) auto

text \<open>Elimination of @{term "(a, b) \<in># A \<times># B"} -- introduces no eigenvariables.\<close>

lemma Sigma_msetD1: "(a, b) \<in># Sigma_mset A B \<Longrightarrow> a \<in># A"
  by blast

lemma Sigma_msetD2: "(a, b) \<in># Sigma_mset A B \<Longrightarrow> b \<in># B a"
  by blast

lemma Sigma_msetE2: "\<lbrakk>(a, b) \<in># Sigma_mset A B; \<lbrakk>a \<in># A; b \<in># B a\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by blast

lemma Sigma_mset_cong:
  "\<lbrakk>A = B; \<And>x. x \<in># B \<Longrightarrow> C x = D x\<rbrakk> \<Longrightarrow> (SIGMAMSET x \<in># A. C x) = (SIGMAMSET x \<in># B. D x)"
  by (metis (mono_tags, lifting) Sigma_mset_def image_mset_cong)

lemma count_sum_mset: "count (\<Union># M) b = (\<Sum>P \<in># M. count P b)"
  by (induction M) auto

lemma Sigma_mset_plus_distrib1[simp]: "Sigma_mset (A + B) C = Sigma_mset A C + Sigma_mset B C"
  unfolding Sigma_mset_def by auto

lemma Sigma_mset_plus_distrib2[simp]:
  "Sigma_mset A (\<lambda>i. B i + C i) = Sigma_mset A B + Sigma_mset A C"
  unfolding Sigma_mset_def by (induction A) (auto simp: multiset_eq_iff)

lemma Times_mset_single_left: "{#a#} \<times># B = image_mset (Pair a) B"
  unfolding Sigma_mset_def by auto

lemma Times_mset_single_right: "A \<times># {#b#} = image_mset (\<lambda>a. Pair a b) A"
  unfolding Sigma_mset_def by (induction A) auto

lemma Times_mset_single_single[simp]: "{#a#} \<times># {#b#} = {#(a, b)#}"
  unfolding Sigma_mset_def by simp

lemma count_image_mset_Pair:
  "count (image_mset (Pair a) B) (x, b) = (if x = a then count B b else 0)"
  by (induction B) auto

lemma count_Sigma_mset: "count (Sigma_mset A B) (a, b) = count A a * count (B a) b"
  by (induction A) (auto simp: Sigma_mset_def count_image_mset_Pair)

lemma Sigma_mset_empty1[simp]: "Sigma_mset {#} B = {#}"
  unfolding Sigma_mset_def by auto

lemma Sigma_mset_empty2[simp]: "A \<times># {#} = {#}"
  by (auto simp: multiset_eq_iff count_Sigma_mset)

lemma Sigma_mset_mono:
  assumes "A \<subseteq># C" and "\<And>x. x \<in># A \<Longrightarrow> B x \<subseteq># D x"
  shows "Sigma_mset A B \<subseteq># Sigma_mset C D"
proof -
  have "count A a * count (B a) b \<le> count C a * count (D a) b" for a b
    using assms unfolding subseteq_mset_def by (metis count_inI eq_iff mult_eq_0_iff mult_le_mono)
  then show ?thesis
    by (auto simp: subseteq_mset_def count_Sigma_mset)
qed

lemma mem_Sigma_mset_iff[iff]: "((a,b) \<in># Sigma_mset A B) = (a \<in># A \<and> b \<in># B a)"
  by blast

lemma Sigma_mset_empty_iff: "(SIGMAMSET i\<in>#I. X i) = {#} \<longleftrightarrow> (\<forall>i\<in>#I. X i = {#})"
  by (auto simp: Sigma_mset_def)

lemma Times_mset_subset_mset_cancel1: "x \<in># A \<Longrightarrow> (A \<times># B \<subseteq># A \<times># C) = (B \<subseteq># C)"
  by (auto simp: subseteq_mset_def count_Sigma_mset)

lemma Times_mset_subset_mset_cancel2: "x \<in># C \<Longrightarrow> (A \<times># C \<subseteq># B \<times># C) = (A \<subseteq># B)"
  by (auto simp: subseteq_mset_def count_Sigma_mset)

lemma Times_mset_eq_cancel2: "x \<in># C \<Longrightarrow> (A \<times># C = B \<times># C) = (A = B)"
  by (auto simp: multiset_eq_iff count_Sigma_mset dest!: in_countE)

lemma split_paired_Ball_mset_Sigma_mset[simp]:
  "(\<forall>z\<in>#Sigma_mset A B. P z) \<longleftrightarrow> (\<forall>x\<in>#A. \<forall>y\<in>#B x. P (x, y))"
  by blast

lemma split_paired_Bex_mset_Sigma_mset[simp]:
  "(\<exists>z\<in>#Sigma_mset A B. P z) \<longleftrightarrow> (\<exists>x\<in>#A. \<exists>y\<in>#B x. P (x, y))"
  by blast

lemma sum_mset_if_eq_constant:
  "(\<Sum>x\<in>#M. if a = x then (f x) else 0) = (((+) (f a)) ^^ (count M a)) 0"
  by (induction M) (auto simp: ac_simps)

lemma iterate_op_plus: "(((+) k) ^^ m) 0 = k * m"
  by (induction m) auto

lemma untion_image_mset_Pair_distribute:
  "\<Union>#{#image_mset (Pair x) (C x). x \<in># J - I#} =
   \<Union># {#image_mset (Pair x) (C x). x \<in># J#} - \<Union>#{#image_mset (Pair x) (C x). x \<in># I#}"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    iterate_op_plus diff_mult_distrib2)

lemma Sigma_mset_Un_distrib1: "Sigma_mset (I \<union># J) C = Sigma_mset I C \<union># Sigma_mset J C"
  by (auto simp: Sigma_mset_def sup_subset_mset_def untion_image_mset_Pair_distribute)

lemma Sigma_mset_Un_distrib2: "(SIGMAMSET i\<in>#I. A i \<union># B i) = Sigma_mset I A \<union># Sigma_mset I B"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def diff_mult_distrib2 iterate_op_plus max_def not_in_iff)

lemma Sigma_mset_Int_distrib1: "Sigma_mset (I \<inter># J) C = Sigma_mset I C \<inter># Sigma_mset J C"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff)

lemma Sigma_mset_Int_distrib2: "(SIGMAMSET i\<in>#I. A i \<inter># B i) = Sigma_mset I A \<inter># Sigma_mset I B"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff)

lemma Sigma_mset_Diff_distrib1: "Sigma_mset (I - J) C = Sigma_mset I C - Sigma_mset J C"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff diff_mult_distrib2)

lemma Sigma_mset_Diff_distrib2: "(SIGMAMSET i\<in>#I. A i - B i) = Sigma_mset I A - Sigma_mset I B"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff diff_mult_distrib)

lemma Sigma_mset_Union: "Sigma_mset (\<Union>#X) B = (\<Union># (image_mset (\<lambda>A. Sigma_mset A B) X))"
  by (auto simp: multiset_eq_iff count_sum_mset count_image_mset_Pair sum_mset_if_eq_constant
    Sigma_mset_def iterate_op_plus min_def not_in_iff sum_mset_distrib_left)

lemma Times_mset_Un_distrib1: "(A \<union># B) \<times># C = A \<times># C \<union># B \<times># C"
  by (fact Sigma_mset_Un_distrib1)

lemma Times_mset_Int_distrib1: "(A \<inter># B) \<times># C = A \<times># C \<inter># B \<times># C"
  by (fact Sigma_mset_Int_distrib1)

lemma Times_mset_Diff_distrib1: "(A - B) \<times># C = A \<times># C - B \<times># C"
  by (fact Sigma_mset_Diff_distrib1)

lemma Times_mset_empty[simp]: "A \<times># B = {#} \<longleftrightarrow> A = {#} \<or> B = {#}"
  by (auto simp: Sigma_mset_empty_iff)

lemma Times_insert_left: "A \<times># add_mset x B = A \<times># B + image_mset (\<lambda>a. Pair a x) A"
  unfolding add_mset_add_single[of x B] Sigma_mset_plus_distrib2
  by (simp add: Times_mset_single_right)

lemma Times_insert_right: "add_mset a A \<times># B = A \<times># B + image_mset (Pair a) B"
  unfolding add_mset_add_single[of a A] Sigma_mset_plus_distrib1
  by (simp add: Times_mset_single_left)

lemma fst_image_mset_times_mset [simp]:
  "image_mset fst (A \<times># B) = (if B = {#} then {#} else repeat_mset (size B) A)"
  by (induct B) (auto simp: Times_mset_single_right ac_simps Times_insert_left)

lemma snd_image_mset_times_mset [simp]:
  "image_mset snd (A \<times># B) = (if A = {#} then {#} else repeat_mset (size A) B)"
  by (induct B) (auto simp add: Times_mset_single_right Times_insert_left image_mset_const_eq)

lemma product_swap_mset: "image_mset prod.swap (A \<times># B) = B \<times># A"
  by (induction A) (auto simp add: Times_mset_single_left Times_mset_single_right
      Times_insert_right Times_insert_left)

context
begin

qualified definition product_mset :: "'a multiset \<Rightarrow> 'b multiset \<Rightarrow> ('a \<times> 'b) multiset" where
  [code_abbrev]: "product_mset A B = A \<times># B"

lemma member_product_mset: "x \<in># product_mset A B \<longleftrightarrow> x \<in># A \<times># B"
  by (simp add: Multiset_More.product_mset_def)

end

lemma count_Sigma_mset_abs_def: "count (Sigma_mset A B) = (\<lambda>(a, b) \<Rightarrow> count A a * count (B a) b)"
  by (auto simp: fun_eq_iff count_Sigma_mset)

lemma Times_mset_image_mset1: "image_mset f A \<times># B = image_mset (\<lambda>(a, b). (f a, b)) (A \<times># B)"
  by (induct B) (auto simp: Times_insert_left)

lemma Times_mset_image_mset2: "A \<times># image_mset f B = image_mset (\<lambda>(a, b). (a, f b)) (A \<times># B)"
  by (induct A) (auto simp: Times_insert_right)

lemma sum_le_singleton: "A \<subseteq> {x} \<Longrightarrow> sum f A = (if x \<in> A then f x else 0)"
  by (auto simp: subset_singleton_iff elim: finite_subset)

lemma Times_mset_assoc: "(A \<times># B) \<times># C = image_mset (\<lambda>(a, b, c). ((a, b), c)) (A \<times># B \<times># C)"
  by (auto simp: multiset_eq_iff count_Sigma_mset count_image_mset vimage_def Times_mset_Times
      Int_commute count_eq_zero_iff intro!: trans[OF _ sym[OF sum_le_singleton[of _ "(_, _, _)"]]]
      cong: sum.cong if_cong)

subsection \<open>Transfer Rules\<close>

lemma plus_multiset_transfer[transfer_rule]:
  "(rel_fun (rel_mset R) (rel_fun (rel_mset R) (rel_mset R))) (+) (+)"
  by (unfold rel_fun_def rel_mset_def)
    (force dest: list_all2_appendI intro: exI[of _ "_ @ _"] conjI[rotated])

lemma minus_multiset_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique R"
  shows "(rel_fun (rel_mset R) (rel_fun (rel_mset R) (rel_mset R))) (-) (-)"
proof (unfold rel_fun_def rel_mset_def, safe)
  fix xs ys xs' ys'
  assume [transfer_rule]: "list_all2 R xs ys" "list_all2 R xs' ys'"
  have "list_all2 R (fold remove1 xs' xs) (fold remove1 ys' ys)"
    by transfer_prover
  moreover have "mset (fold remove1 xs' xs) = mset xs - mset xs'"
    by (induct xs' arbitrary: xs) auto
  moreover have "mset (fold remove1 ys' ys) = mset ys - mset ys'"
    by (induct ys' arbitrary: ys) auto
  ultimately show "\<exists>xs'' ys''.
    mset xs'' = mset xs - mset xs' \<and> mset ys'' = mset ys - mset ys' \<and> list_all2 R xs'' ys''"
    by blast
qed

declare rel_mset_Zero[transfer_rule]

lemma count_transfer[transfer_rule]:
  assumes "bi_unique R"
  shows "(rel_fun (rel_mset R) (rel_fun R (=))) count count"
unfolding rel_fun_def rel_mset_def proof safe
  fix x y xs ys
  assume "list_all2 R xs ys" "R x y"
  then show "count (mset xs) x = count (mset ys) y"
  proof (induct xs ys rule: list.rel_induct)
    case (Cons x' xs y' ys)
    then show ?case
      using assms unfolding bi_unique_alt_def2 by (auto simp: rel_fun_def)
  qed simp
qed

lemma subseteq_multiset_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique R" "right_total R"
  shows "(rel_fun (rel_mset R) (rel_fun (rel_mset R) (=)))
    (\<lambda>M N. filter_mset (Domainp R) M \<subseteq># filter_mset (Domainp R) N) (\<subseteq>#)"
proof -
  have count_filter_mset_less:
    "(\<forall>a. count (filter_mset (Domainp R) M) a \<le> count (filter_mset (Domainp R) N) a) \<longleftrightarrow>
     (\<forall>a \<in> {x. Domainp R x}. count M a \<le> count N a)" for M and N by auto
  show ?thesis unfolding subseteq_mset_def count_filter_mset_less
    by transfer_prover
qed

lemma sum_mset_transfer[transfer_rule]:
  "R 0 0 \<Longrightarrow> rel_fun R (rel_fun R R) (+) (+) \<Longrightarrow> (rel_fun (rel_mset R) R) sum_mset sum_mset"
  using sum_list_transfer[of R] unfolding rel_fun_def rel_mset_def by auto

lemma Sigma_mset_transfer[transfer_rule]:
  "(rel_fun (rel_mset R) (rel_fun (rel_fun R (rel_mset S)) (rel_mset (rel_prod R S))))
     Sigma_mset Sigma_mset"
  by (unfold Sigma_mset_def) transfer_prover

subsection \<open>Even More about Multisets\<close>

subsubsection \<open>Multisets and functions\<close>

lemma range_image_mset:
  assumes "set_mset Ds \<subseteq> range f"
  shows "Ds \<in> range (image_mset f)"
proof -
  have "\<forall>D. D \<in># Ds \<longrightarrow> (\<exists>C. f C = D)"
    using assms by blast
  then obtain f_i where
    f_p: "\<forall>D. D \<in># Ds \<longrightarrow> (f (f_i D) = D)"
    by metis
  define Cs where
    "Cs \<equiv> image_mset f_i Ds"
  from f_p Cs_def have "image_mset f Cs = Ds"
    by auto
  then show ?thesis
    by blast
qed

subsubsection \<open>Multisets and lists\<close>

definition list_of_mset :: "'a multiset \<Rightarrow> 'a list" where
  "list_of_mset m = (SOME l. m = mset l)"

lemma range_mset_map:
  assumes "set_mset Ds \<subseteq> range f"
  shows "Ds \<in> range (\<lambda>Cl. mset (map f Cl))"
proof -
  have "Ds \<in> range (image_mset f)"
    by (simp add: assms range_image_mset)
  then obtain Cs where Cs_p: "image_mset f Cs = Ds"
    by auto
  define Cl where "Cl = list_of_mset Cs"
  then have "mset Cl = Cs"
    by auto
  then have "image_mset f (mset Cl) = Ds"
    using Cs_p by auto
  then have "mset (map f Cl) = Ds"
    by auto
  then show ?thesis
    by auto
qed

lemma list_of_mset_empty[iff]: "list_of_mset m = [] \<longleftrightarrow> m = {#}"
  by (metis (mono_tags, lifting) ex_mset list_of_mset_def mset_zero_iff_right someI_ex)

lemma in_mset_conv_nth: "(x \<in># mset xs) = (\<exists>i<length xs. xs ! i = x)"
  by (auto simp: in_set_conv_nth)

lemma in_mset_sum_list:
  assumes "L \<in># LL"
  assumes "LL \<in> set Ci"
  shows "L \<in># sum_list Ci"
  using assms by (induction Ci) auto

lemma in_mset_sum_list2:
  assumes "L \<in># sum_list Ci"
  obtains LL where
    "LL \<in> set Ci"
    "L \<in># LL"
  using assms by (induction Ci) auto

lemma subseteq_list_Union_mset:
  assumes "length Ci = n"
  assumes "length CAi = n"
  assumes "\<forall>i<n.  Ci ! i \<subseteq># CAi ! i "
  shows "\<Union># (mset Ci) \<subseteq># \<Union># (mset CAi)"
  using assms proof (induction n arbitrary: Ci CAi)
  case 0
  then show ?case by auto
next
  case (Suc n)
  from Suc have "\<forall>i<n. tl Ci ! i \<subseteq># tl CAi ! i"
    by (simp add: nth_tl)
  hence "\<Union>#(mset (tl Ci)) \<subseteq># \<Union>#(mset (tl CAi))" using Suc by auto
  moreover
  have "hd Ci \<subseteq># hd CAi" using Suc
    by (metis hd_conv_nth length_greater_0_conv zero_less_Suc)
  ultimately
  show "\<Union>#(mset Ci) \<subseteq># \<Union>#(mset CAi)"
    using Suc by (cases Ci; cases CAi) (auto intro: subset_mset.add_mono)
qed

subsubsection \<open>More on multisets and functions\<close>

lemma subseteq_mset_size_eql: "X \<subseteq># Y \<Longrightarrow> size Y = size X \<Longrightarrow> X = Y"
  using mset_subset_size subset_mset_def by fastforce

lemma image_mset_of_subset_list:
  assumes "image_mset \<eta> C' = mset lC"
  shows "\<exists>qC'. map \<eta> qC' = lC \<and> mset qC' = C'"
  using assms apply (induction lC arbitrary: C')
  subgoal by simp
  subgoal by (fastforce dest!: msed_map_invR intro: exI[of _ \<open>_ # _\<close>])
  done

lemma image_mset_of_subset:
  assumes "A \<subseteq># image_mset \<eta> C'"
  shows "\<exists>A'. image_mset \<eta> A' = A \<and> A' \<subseteq># C'"
proof -
  define C where "C = image_mset \<eta> C'"

  define lA where "lA = list_of_mset A"
  define lD where "lD = list_of_mset (C-A)"
  define lC where "lC = lA @ lD"

  have "mset lC = C"
    using C_def assms unfolding lD_def lC_def lA_def by auto
  then have "\<exists>qC'. map \<eta> qC' = lC \<and> mset qC' = C'"
    using assms image_mset_of_subset_list unfolding C_def by metis
  then obtain qC' where qC'_p: "map \<eta> qC' = lC \<and> mset qC' = C'"
    by auto
  let ?lA' = "take (length lA) qC'"
  have m: "map \<eta> ?lA' = lA"
    using qC'_p lC_def
    by (metis append_eq_conv_conj take_map)
  let ?A' = "mset ?lA'"

  have "image_mset \<eta> ?A' = A"
    using m using lA_def
    by (metis (full_types) ex_mset list_of_mset_def mset_map someI_ex)
  moreover have "?A' \<subseteq># C'"
    using qC'_p unfolding lA_def
    using mset_take_subseteq by blast
  ultimately show ?thesis by blast
qed

lemma Melem_subseteq_Union_mset[simp]:
  assumes "x \<in># T"
  shows "x \<subseteq># \<Union>#T"
  using assms sum_mset.remove by force

lemma Melem_subset_eq_sum_list[simp]:
  assumes "x \<in># mset T"
  shows "x \<subseteq># sum_list T"
  using assms by (metis mset_subset_eq_add_left sum_mset.remove sum_mset_sum_list)

lemma less_subset_eq_Union_mset[simp]:
  assumes "i < length CAi"
  shows "CAi ! i \<subseteq># \<Union>#(mset CAi)"
proof -
  from assms have "CAi ! i \<in># mset CAi"
    by auto
  then show ?thesis
    by auto
qed

lemma less_subset_eq_sum_list[simp]:
  assumes "i < length CAi"
  shows "CAi ! i \<subseteq># sum_list CAi"
proof -
  from assms have "CAi ! i \<in># mset CAi"
    by auto
  then show ?thesis
    by auto
qed

subsubsection \<open>More on multiset order\<close>

lemma less_multiset_doubletons:
  assumes
    "y <  t \<or>  y <  s"
    "x <  t \<or>  x <  s"
  shows
    "{# y,  x#} < {# t,  s#}"
  unfolding less_multiset\<^sub>D\<^sub>M
proof (intro exI)
  let ?X = "{# t,  s#}"
  let ?Y = "{#y, x#}"
  show "?X \<noteq> {#} \<and> ?X \<subseteq># {#t, s#} \<and> {#y, x#} = {#t, s#} - ?X + ?Y \<and> (\<forall>k. k \<in># ?Y \<longrightarrow> (\<exists>a. a \<in># ?X \<and> k < a))"
    using add_eq_conv_diff assms(1) assms(2) by auto
qed

end


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

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variant for the least significant bit\<close>

theory Least_significant_bit
  imports
    "HOL-Library.Word"
    Bits_Int
    More_Word
begin

class lsb = semiring_bits +
  fixes lsb :: \<open>'a \<Rightarrow> bool\<close>
  assumes lsb_odd: \<open>lsb = odd\<close>

instantiation int :: lsb
begin

definition lsb_int :: \<open>int \<Rightarrow> bool\<close>
  where \<open>lsb i = bit i 0\<close> for i :: int

instance
  by standard (simp add: fun_eq_iff lsb_int_def)

end

lemma bin_last_conv_lsb: "odd = (lsb :: int \<Rightarrow> bool)"
  by (simp add: lsb_odd)

lemma int_lsb_numeral [simp]:
  "lsb (0 :: int) = False"
  "lsb (1 :: int) = True"
  "lsb (Numeral1 :: int) = True"
  "lsb (- 1 :: int) = True"
  "lsb (- Numeral1 :: int) = True"
  "lsb (numeral (num.Bit0 w) :: int) = False"
  "lsb (numeral (num.Bit1 w) :: int) = True"
  "lsb (- numeral (num.Bit0 w) :: int) = False"
  "lsb (- numeral (num.Bit1 w) :: int) = True"
  by (simp_all add: lsb_int_def)

instantiation word :: (len) lsb
begin

definition lsb_word :: \<open>'a word \<Rightarrow> bool\<close>
  where word_lsb_def: \<open>lsb a \<longleftrightarrow> odd (uint a)\<close> for a :: \<open>'a word\<close>

instance
  apply standard
  apply (simp add: fun_eq_iff word_lsb_def)
  apply transfer apply simp
  done

end

lemma lsb_word_eq:
  \<open>lsb = (odd :: 'a word \<Rightarrow> bool)\<close> for w :: \<open>'a::len word\<close>
  by (fact lsb_odd)

lemma word_lsb_alt: "lsb w = bit w 0"
  for w :: "'a::len word"
  by (simp add: lsb_word_eq)

lemma word_lsb_1_0 [simp]: "lsb (1::'a::len word) \<and> \<not> lsb (0::'b::len word)"
  unfolding word_lsb_def by simp

lemma word_lsb_int: "lsb w \<longleftrightarrow> uint w mod 2 = 1"
  apply (simp add: lsb_odd flip: odd_iff_mod_2_eq_one)
  apply transfer
  apply simp
  done

lemmas word_ops_lsb = lsb0 [unfolded word_lsb_alt]

lemma word_lsb_numeral [simp]:
  "lsb (numeral bin :: 'a::len word) \<longleftrightarrow> odd (numeral bin :: int)"
  by (simp only: lsb_odd, transfer) rule

lemma word_lsb_neg_numeral [simp]:
  "lsb (- numeral bin :: 'a::len word) \<longleftrightarrow> odd (- numeral bin :: int)"
  by (simp only: lsb_odd, transfer) rule

lemma word_lsb_nat:"lsb w = (unat w mod 2 = 1)"
  apply (simp add: word_lsb_def Groebner_Basis.algebra(31))
  apply transfer
  apply (simp add: even_nat_iff)
  done

end