section \<open>Run Graphs\<close>

theory Graph
imports "Transition_Systems_and_Automata.NBA"
begin

  type_synonym 'state node = "nat \<times> 'state"

  abbreviation "ginitial A \<equiv> {0} \<times> initial A"
  abbreviation "gaccepting A \<equiv> accepting A \<circ> snd"

  global_interpretation graph: transition_system_initial
    "const"
    "\<lambda> u (k, p). w !! k \<in> alphabet A \<and> u \<in> {Suc k} \<times> transition A (w !! k) p \<inter> V"
    "\<lambda> v. v \<in> ginitial A \<inter> V"
    for A w V
    defines
      gpath = graph.path and grun = graph.run and
      greachable = graph.reachable and gnodes = graph.nodes
    by this

  text \<open>We disable rules that are degenerate due to @{term "execute = const"}.\<close>
  declare graph.reachable.execute[rule del]
  declare graph.nodes.execute[rule del]

  abbreviation "gtarget \<equiv> graph.target"
  abbreviation "gstates \<equiv> graph.states"
  abbreviation "gtrace \<equiv> graph.trace"

  abbreviation gsuccessors :: "('label, 'state) nba \<Rightarrow> 'label stream \<Rightarrow>
    'state node set \<Rightarrow> 'state node \<Rightarrow> 'state node set" where
    "gsuccessors A w V \<equiv> graph.successors TYPE('label) w A V"

  abbreviation "gusuccessors A w \<equiv> gsuccessors A w UNIV"
  abbreviation "gupath A w \<equiv> gpath A w UNIV"
  abbreviation "gurun A w \<equiv> grun A w UNIV"
  abbreviation "gureachable A w \<equiv> greachable A w UNIV"
  abbreviation "gunodes A w \<equiv> gnodes A w UNIV"

  lemma gtarget_alt_def: "gtarget r v = last (v # r)" using fold_const by this
  lemma gstates_alt_def: "gstates r v = r" by simp
  lemma gtrace_alt_def: "gtrace r v = r" by simp

  lemma gpath_elim[elim?]:
    assumes "gpath A w V s v"
    obtains r k p
    where "s = [Suc k ..< Suc k + length r] || r" "v = (k, p)"
  proof -
    obtain t r where 1: "s = t || r" "length t = length r"
      using zip_map_fst_snd[of s] by (metis length_map)
    obtain k p where 2: "v = (k, p)" by force
    have 3: "t = [Suc k ..< Suc k + length r]"
    using assms 1 2
    proof (induct arbitrary: t r k p)
      case (nil v)
      then show ?case by (metis add_0_right le_add1 length_0_conv length_zip min.idem upt_conv_Nil)
    next
      case (cons u v s)
      have 1: "t || r = (hd t, hd r) # (tl t || tl r)"
        by (metis cons.prems(1) hd_Cons_tl neq_Nil_conv zip.simps(1) zip_Cons_Cons zip_Nil)
      have 2: "s = tl t || tl r" using cons 1 by simp
      have "t = hd t # tl t" using cons(4) by (metis hd_Cons_tl list.simps(3) zip_Nil)
      also have "hd t = Suc k" using "1" cons.hyps(1) cons.prems(1) cons.prems(3) by auto
      also have "tl t = [Suc (Suc k) ..< Suc (Suc k) + length (tl r)]"
        using cons(3)[OF 2] using "1" \<open>hd t = Suc k\<close> cons.prems(1) cons.prems(2) by auto
      finally show ?case using cons.prems(2) upt_rec by auto
    qed
    show ?thesis using that 1 2 3 by simp
  qed

  lemma gpath_path[symmetric]: "path A (stake (length r) (sdrop k w) || r) p \<longleftrightarrow>
    gpath A w UNIV ([Suc k ..< Suc k + length r] || r) (k, p)"
  proof (induct r arbitrary: k p)
    case (Nil)
    show ?case by auto
  next
    case (Cons q r)
    have 1: "path A (stake (length r) (sdrop (Suc k) w) || r) q \<longleftrightarrow>
      gpath A w UNIV ([Suc (Suc k) ..< Suc k + length (q # r)] || r) (Suc k, q)"
      using Cons[of "Suc k" "q"] by simp
    have "stake (length (q # r)) (sdrop k w) || q # r =
      (w !! k, q) # (stake (length r) (sdrop (Suc k) w) || r)" by simp
    also have "path A \<dots> p \<longleftrightarrow>
      gpath A w UNIV ((Suc k, q) # ([Suc (Suc k) ..< Suc k + length (q # r)] || r)) (k, p)"
      using 1 by auto
    also have "(Suc k, q) # ([Suc (Suc k) ..< Suc k + length (q # r)] || r) =
      Suc k # [Suc (Suc k) ..< Suc k + length (q # r)] || q # r" unfolding zip_Cons_Cons by rule
    also have "Suc k # [Suc (Suc k) ..< Suc k + length (q # r)] = [Suc k ..< Suc k + length (q # r)]"
      by (simp add: upt_rec)
    finally show ?case by this
  qed

  lemma grun_elim[elim?]:
    assumes "grun A w V s v"
    obtains r k p
    where "s = fromN (Suc k) ||| r" "v = (k, p)"
  proof -
    obtain t r where 1: "s = t ||| r" using szip_smap by metis
    obtain k p where 2: "v = (k, p)" by force
    have 3: "t = fromN (Suc k)"
      using assms unfolding 1 2
      by (coinduction arbitrary: t r k p) (force iff: eq_scons elim: graph.run.cases)
    show ?thesis using that 1 2 3 by simp
  qed

  lemma run_grun:
    assumes "run A (sdrop k w ||| r) p"
    shows "gurun A w (fromN (Suc k) ||| r) (k, p)"
    using assms by (coinduction arbitrary: k p r) (auto elim: nba.run.cases)

  lemma grun_run:
    assumes "grun A w V (fromN (Suc k) ||| r) (k, p)"
    shows "run A (sdrop k w ||| r) p"
  proof -
    have 2: "\<exists> ka wa. sdrop k (stl w :: 'a stream) = sdrop ka wa \<and> P ka wa" if "P (Suc k) w" for P k w
      using that by (metis sdrop.simps(2))
    show ?thesis using assms by (coinduction arbitrary: k p w r) (auto intro!: 2 elim: graph.run.cases)
  qed

  lemma greachable_reachable:
    fixes l q k p
    defines "u \<equiv> (l, q)"
    defines "v \<equiv> (k, p)"
    assumes "u \<in> greachable A w V v"
    shows "q \<in> reachable A p"
  using assms(3, 1, 2)
  proof (induct arbitrary: l q k p)
    case reflexive
    then show ?case by auto
  next
    case (execute u)
    have 1: "q \<in> successors A (snd u)" using execute by auto
    have "snd u \<in> reachable A p" using execute by auto
    also have "q \<in> reachable A (snd u)" using 1 by blast
    finally show ?case by this
  qed

  lemma gnodes_nodes: "gnodes A w V \<subseteq> UNIV \<times> nodes A"
  proof
    fix v
    assume "v \<in> gnodes A w V"
    then show "v \<in> UNIV \<times> nodes A" by induct auto
  qed

  lemma gpath_subset:
    assumes "gpath A w V r v"
    assumes "set (gstates r v) \<subseteq> U"
    shows "gpath A w U r v"
    using assms by induct auto
  lemma grun_subset:
    assumes "grun A w V r v"
    assumes "sset (gtrace r v) \<subseteq> U"
    shows "grun A w U r v"
  using assms
  proof (coinduction arbitrary: r v)
    case (run a s r v)
    have 1: "grun A w V s a" using run(1, 2) by fastforce
    have 2: "a \<in> gusuccessors A w v" using run(1, 2) by fastforce
    show ?case using 1 2 run(1, 3) by force
  qed

  lemma greachable_subset: "greachable A w V v \<subseteq> insert v V"
  proof
    fix u
    assume "u \<in> greachable A w V v"
    then show "u \<in> insert v V" by induct auto
  qed

  lemma gtrace_infinite:
    assumes "grun A w V r v"
    shows "infinite (sset (gtrace r v))"
    using assms by (metis grun_elim gtrace_alt_def infinite_Ici sset_fromN sset_szip_finite)

  lemma infinite_greachable_gtrace:
    assumes "grun A w V r v"
    assumes "u \<in> sset (gtrace r v)"
    shows "infinite (greachable A w V u)"
  proof -
    obtain i where 1: "u = gtrace r v !! i" using sset_range imageE assms(2) by metis
    have 2: "gtarget (stake (Suc i) r) v = u" unfolding 1 sscan_snth by rule
    have "infinite (sset (sdrop (Suc i) (gtrace r v)))"
      using gtrace_infinite[OF assms(1)]
      by (metis List.finite_set finite_Un sset_shift stake_sdrop)
    also have "sdrop (Suc i) (gtrace r v) = gtrace (sdrop (Suc i) r) (gtarget (stake (Suc i) r) v)"
      by simp
    also have "sset \<dots> \<subseteq> greachable A w V u"
      using assms(1) 2 by (metis graph.reachable.reflexive graph.reachable_trace graph.run_sdrop)
    finally show ?thesis by this
  qed

  lemma finite_nodes_gsuccessors:
    assumes "finite (nodes A)"
    assumes "v \<in> gunodes A w"
    shows "finite (gusuccessors A w v)"
  proof -
    have "gusuccessors A w v \<subseteq> gureachable A w v" by rule
    also have "\<dots> \<subseteq> gunodes A w" using assms(2) by blast
    also have "\<dots> \<subseteq> UNIV \<times> nodes A" using gnodes_nodes by this
    finally have 3: "gusuccessors A w v \<subseteq> UNIV \<times> nodes A" by this
    have "gusuccessors A w v \<subseteq> {Suc (fst v)} \<times> nodes A" using 3 by auto
    also have "finite \<dots>" using assms(1) by simp
    finally show ?thesis by this
  qed

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Toolbox of various definitions and theorems about sets, relations and lists\<close>

theory MiscTools

imports
"HOL-Library.Discrete"
RelationProperties
"HOL-Library.Code_Target_Nat"
"HOL-Library.Indicator_Function"
Argmax

begin

subsection \<open>Facts and notations about relations, sets and functions.\<close>

(* We use as alternative notation for paste instead of +* also +< and overload this with the next definition *)
notation paste (infix "+<" 75)

text \<open>\<open>+<\<close> abbreviation permits to shorten the notation for altering a function f in a single point by giving a pair (a, b) so that the new function has value b with argument a.\<close>

abbreviation singlepaste
  where "singlepaste f pair == f +* {(fst pair, snd pair)}"
  notation singlepaste (infix "+<" 75)
(* Type of g in f +< g should avoid ambiguities *)

text \<open>\<open>--\<close> abbreviation permits to shorten the notation for considering a function outside a single point.\<close>

abbreviation singleoutside (infix "--" 75)
  where "f -- x \<equiv> f outside {x}"

text \<open>Turns a HOL function into a set-theoretical function\<close>

definition (*Graph :: "('a => 'b) => ('a \<times> 'b) set" where *)
  "Graph f = {(x, f x) | x . True}"

text \<open>Inverts @{term Graph} (which is equivalently done by @{term eval_rel}).\<close>
(* Assume (x, y) is in R. Apply R to x, i.e., R ,, x,  will result in y assumed y is unique. *)

definition
  "toFunction R = (\<lambda> x . (R ,, x))"

(* toFunction = eval_rel *)
lemma
  "toFunction = eval_rel"
  using toFunction_def by blast

lemma lm001:
  "((P \<union> Q) || X) = ((P || X) \<union> (Q||X))"
  unfolding restrict_def by blast

text \<open>update behaves like P +* Q (paste), but without enlarging P's Domain. update is the set theoretic equivalent of the lambda function update @{term fun_upd}\<close>

definition update
  where "update P Q = P +* (Q || (Domain P))"
  notation update (infix "+^" 75)

(* The operator runiqer will make out of an arbitrary relation a function by making a choice to all those elements in the domain for which the value is not unique by applying the axiom of choice. *)
definition runiqer  :: "('a \<times> 'b) set => ('a \<times> 'b) set"
  where "runiqer R = { (x, THE y. y \<in> R `` {x})| x. x \<in> Domain R }"

text \<open>@{term graph} is like @{term Graph}, but with a built-in restriction to a given set @{term X}.
This makes it computable for finite X, whereas @{term "Graph f || X"} is not computable.
Duplicates the eponymous definition found in \<open>Function_Order\<close>, which is otherwise not needed.\<close>

definition graph
  where "graph X f = {(x, f x) | x. x \<in> X}"

lemma lm002:
  assumes "runiq R"
  shows "R \<supseteq> graph (Domain R) (toFunction R)"
  unfolding graph_def toFunction_def
  using assms graph_def toFunction_def eval_runiq_rel by fastforce

lemma lm003:
  assumes "runiq R"
  shows "R \<subseteq> graph (Domain R) (toFunction R)"
  unfolding graph_def toFunction_def
  using assms eval_runiq_rel runiq_basic Domain.DomainI mem_Collect_eq subrelI by fastforce

lemma lm004:
  assumes "runiq R"
  shows "R = graph (Domain R) (toFunction R)"
  using assms lm002 lm003 by fast

lemma domainOfGraph:
  "runiq(graph X f) & Domain(graph X f)=X"
  unfolding graph_def
  using rightUniqueRestrictedGraph by fast

(* The following definition gives the image of a relation R for a fixed element x. It is equivalent to eval_rel for right unique R, but more general since it determines values even when R is not right unique. *)
abbreviation "eval_rel2 (R::('a \<times> ('b set)) set) (x::'a) == \<Union> (R``{x})"
  notation eval_rel2 (infix ",,," 75)

lemma imageEquivalence:
  assumes "runiq (f::(('a \<times> ('b set)) set))" "x \<in> Domain f"
  shows "f,,x = f,,,x"
  using assms Image_runiq_eq_eval cSup_singleton by metis

(* UNIV is the universal set containing everything of the given type. It is defined in Set.thy.*)
lemma lm005:
  "Graph f=graph UNIV f"
  unfolding Graph_def graph_def by simp

lemma graphIntersection:
  "graph (X \<inter> Y) f \<subseteq> ((graph X f) || Y)"
  unfolding graph_def
  using Int_iff mem_Collect_eq restrict_ext subrelI by auto

definition runiqs
  where "runiqs={f. runiq f}"

lemma outsideOutside:
  "((P outside X) outside Y) = P outside (X\<union>Y)"
  unfolding Outside_def by blast

corollary lm006:
  "((P outside X) outside X) = P outside X"
  using outsideOutside by force

lemma lm007:
  assumes "(X \<inter> Domain P) \<subseteq> Domain Q"
  shows "P +* Q = (P outside X) +* Q"
  unfolding paste_def Outside_def using assms by blast

corollary lm008:
  "P +* Q = (P outside (Domain Q)) +* Q"
  using lm007 by fast

corollary outsideUnion:
  "R = (R outside {x}) \<union> ({x} \<times> (R `` {x}))"
  using restrict_to_singleton outside_union_restrict by metis

lemma lm009:
  "P = P \<union> {x}\<times>P``{x}"
  by (metis outsideUnion sup.right_idem)

corollary lm010:
  "R = (R outside {x}) +* ({x} \<times> (R `` {x}))"
  by (metis paste_outside_restrict restrict_to_singleton)

lemma lm011:
  "R \<subseteq> R +* ({x} \<times> (R``{x}))"
  using lm010 lm008 paste_def Outside_def by fast

lemma lm012:
  "R \<supseteq> R+*({x} \<times> (R``{x}))"
  by (metis Un_least Un_upper1 outside_union_restrict paste_def
            restrict_to_singleton restriction_is_subrel)

lemma lm013:
  "R = R +* ({x} \<times> (R``{x}))"
  using lm011 lm012 by force

lemma rightUniqueTrivialCartes:
  assumes "trivial Y"
  shows "runiq (X \<times> Y)"
  using assms runiq_def Image_subset lm013 trivial_subset lm011 by (metis(no_types))

(* Two constant functions can be combined to a function *)
lemma lm014:
  "runiq ((X \<times> {x}) +* (Y \<times> {y}))"
  using rightUniqueTrivialCartes trivial_singleton runiq_paste2 by metis

lemma lm015:
  "(P || (X \<inter> Y)) \<subseteq> (P||X)    &    P outside (X \<union> Y) \<subseteq> P outside X"
  using Outside_def restrict_def Sigma_Un_distrib1 Un_upper1 inf_mono Diff_mono subset_refl
  by (metis (lifting) Sigma_mono inf_le1)

lemma lm016:
  "P || X \<subseteq> (P||(X \<union> Y))       &    P outside X \<subseteq> P outside (X \<inter> Y)"
  using lm015 distrib_sup_le sup_idem le_inf_iff subset_antisym sup_commute
  by (metis sup_ge1)

lemma cardinalityOneSubset:
  assumes "card X=1" and "X \<subseteq> Y"
  shows "Union X \<in> Y"
  using assms cardinalityOneTheElemIdentity by (metis cSup_singleton insert_subset)

lemma cardinalityOneTheElem:
  assumes "card X=1" "X \<subseteq> Y"
  shows "the_elem X \<in> Y"
  using assms by (metis (full_types) insert_subset cardinalityOneTheElemIdentity)

lemma lm018:
  "(R outside X1) outside X2 = (R outside X2) outside X1"
  by (metis outsideOutside sup_commute)

subsection \<open>Ordered relations\<close>

(* note that card \<^bold>X\<ge>1 means in Isabelle that X is finite and not empty *)
lemma lm019:
  assumes "card X\<ge>1" "\<forall>x\<in>X. y > x"
  shows "y > Max X"
  using assms by (metis (poly_guards_query) Max_in One_nat_def card_eq_0_iff lessI not_le)

(* assume the function f has a maximum in mx *)
lemma lm020:
  assumes "finite X" "mx \<in> X" "f x < f mx"
  shows"x \<notin> argmax f X"
  using assms not_less by fastforce

lemma lm021:
  assumes "finite X" "mx \<in> X" "\<forall>x \<in> X-{mx}. f x < f mx"
  shows "argmax f X \<subseteq> {mx}"
  using assms mk_disjoint_insert by force

lemma lm022:
  assumes "finite X" "mx \<in> X" "\<forall>x \<in> X-{mx}. f x < f mx"
  shows "argmax f X = {mx}"
  using assms lm021 by (metis argmax_non_empty_iff equals0D subset_singletonD)

(* The following corollary is essentially the same as lm022, however, is simplifies a proof in UniformTieBreaking.thy *)
corollary argmaxProperty:
  "(finite X & mx \<in> X & (\<forall>aa \<in> X-{mx}. f aa < f mx)) \<longrightarrow> argmax f X = {mx}"
  using lm022 by metis

corollary lm023:
  assumes "finite X" "mx \<in> X" "\<forall>x \<in> X. x \<noteq> mx \<longrightarrow> f x < f mx"
  shows "argmax f X = {mx}"
  using assms lm022 by (metis Diff_iff insertI1)

lemma lm024:
  assumes "f \<circ> g = id"
  shows "inj_on g UNIV" using assms
  by (metis inj_on_id inj_on_imageI2)

(* Note that Pow X is the powerset of X *)
lemma lm025:
  assumes "inj_on f X"
  shows "inj_on (image f) (Pow X)"
  using assms inj_on_image_eq_iff inj_onI PowD by (metis (mono_tags, lifting))

lemma injectionPowerset:
  assumes "inj_on f Y" "X \<subseteq> Y"
  shows "inj_on (image f) (Pow X)"
  using assms lm025 by (metis subset_inj_on)

(* the finest possible partition of X, e.g., X = {1, 2, 3} goes to {{1}, {2}, {3}}. *)
definition finestpart
  where "finestpart X = (%x. {x}) ` X"

lemma finestPart:
  "finestpart X = {{x}|x . x\<in>X}"
  unfolding finestpart_def by blast

lemma finestPartUnion:
  "X=\<Union> (finestpart X)"
  using finestPart by auto

lemma lm026:
  "Union \<circ> finestpart = id"
  using finestpart_def finestPartUnion by fastforce

lemma lm027:
  "inj_on Union (finestpart ` UNIV)"
  using lm026 by (metis inj_on_id inj_on_imageI)

lemma nonEqualitySetOfSets:
  assumes "X \<noteq> Y"
  shows "{{x}| x. x \<in> X} \<noteq> {{x}| x. x \<in> Y}"
  using assms by auto

corollary lm028:
  "inj_on finestpart UNIV"
  using nonEqualitySetOfSets finestPart by (metis (lifting, no_types) injI)

(* E.g. in the following example, with X = {{1}, {1,2}}, x can be {1} and {1,2} and Y is {{1}} and {{1},{2}}, that is, the lefthand and righthand sides evaluate to {{1},{2}} *)
lemma unionFinestPart:
  "{Y | Y. \<exists>x.((Y \<in> finestpart x) \<and> (x \<in> X))} = \<Union>(finestpart`X)"
  by auto

(* Now we specialize the previous lemma to the situation where X consists of a relation (that is is a set of pairs) *)
lemma rangeSetOfPairs:
  "Range {(fst pair, Y)| Y pair. Y \<in> finestpart (snd pair) & pair \<in> X} =
   {Y. \<exists>x. ((Y \<in> finestpart x) \<and> (x \<in> Range X))}"
  by auto

(* Further specialization to a singleton for Y *)
lemma setOfPairsEquality:
  "{(fst pair, {y})| y pair. y \<in> snd pair & pair \<in> X} =
   {(fst pair, Y)| Y pair. Y \<in> finestpart (snd pair) & pair \<in> X}"
  using finestpart_def by fastforce

lemma setOfPairs:
  "{(fst pair, {y})| y. y \<in>  snd pair} =
   {fst pair} \<times> {{y}| y. y \<in> snd pair}"
  by fastforce

lemma lm029:
  "x \<in> X = ({x} \<in> finestpart X)"
  using finestpart_def by force

lemma pairDifference:
  "{(x,X)}-{(x,Y)} = {x}\<times>({X}-{Y})"
  by blast

lemma lm030:
  assumes "\<Union> P = X"
  shows "P \<subseteq> Pow X"
  using assms by blast

lemma lm031:
  "argmax f {x} = {x}"
  by auto

lemma sortingSameSet:
  assumes "finite X"
  shows "set (sorted_list_of_set X) = X"
  using assms by simp

(* We assume for the next lemma that f has value in numbers, and sum f A is
   sum f(x) for x in A. *)
lemma lm032:
  assumes "finite A"
  shows "sum f A = sum f (A \<inter> B) + sum f (A - B)"
  using assms by (metis DiffD2 Int_iff Un_Diff_Int Un_commute finite_Un sum.union_inter_neutral)

corollary sumOutside:
  assumes "finite g"
  shows "sum f g = sum f (g outside X) + (sum f (g||X))"
  unfolding Outside_def restrict_def using assms add.commute inf_commute lm032 by (metis)

lemma lm033:
  assumes "(Domain P \<subseteq> Domain Q)"
  shows "(P +* Q) = Q"
  unfolding paste_def Outside_def using assms by fast

lemma lm034:
  assumes "(P +* Q=Q)"
  shows "(Domain P \<subseteq> Domain Q)"
  using assms paste_def Outside_def by blast

lemma lm035:
  "(Domain P \<subseteq> Domain Q) = (P +* Q=Q)"
  using lm033 lm034 by metis

lemma
  "(P||(Domain Q)) +* Q = Q"
  by (metis Int_lower2 restrictedDomain lm035)

lemma lm036:
  "P||X   =   P outside (Domain P - X)"
  using Outside_def restrict_def by fastforce

lemma lm037:
  "(P outside X) \<subseteq>    P || ((Domain P)-X)"
  using lm036 lm016 by (metis Int_commute restrictedDomain outside_reduces_domain)

lemma lm038:
  "Domain (P outside X) \<inter> Domain (Q || X) = {}"
  using lm036
  by (metis Diff_disjoint Domain_empty_iff Int_Diff inf_commute restrictedDomain
            outside_reduces_domain restrict_empty)

lemma lm039:
  "(P outside X) \<inter> (Q || X) = {}"
  using lm038 by fast

lemma lm040:
  "(P outside (X \<union> Y)) \<inter> (Q || X) = {}   &   (P outside X) \<inter> (Q || (X \<inter> Z)) = {}"
  using Outside_def restrict_def lm039 lm015 by fast

lemma lm041:
  "P outside X    =    P || ((Domain P) - X)"
  using Outside_def restrict_def  lm037 by fast

lemma lm042:
  "R``(X-Y) = (R||X)``(X-Y)"
  using restrict_def by blast

(* x is a (non-empty) element of the family XX whose union is a subset of X *)
lemma lm043:
  assumes "\<Union> XX \<subseteq> X" "x \<in> XX" "x \<noteq> {}"
  shows "x \<inter> X \<noteq> {}"
  using assms by blast

(* Note that set converts lists such as L1 into sets. L1 is here a list of lists and l an element, that is, a list. We assume furthermore that f2 is constant function with the fixed 2nd argument N. Then we can convert lists to sets in a canonical way. *)
lemma lm044:
  assumes "\<forall>l \<in> set L1. set L2 = f2 (set l) N"
  shows "set [set L2. l <- L1]  =  {f2 P N| P. P \<in> set (map set L1)}"
  using assms by auto

(* Two Variants of the previous lemma *)
lemma setVsList:
  assumes "\<forall>l \<in> set (g1 G). set (g2 l N) = f2 (set l) N"
  shows "set [set (g2 l N). l <- (g1 G)]  =  {f2 P N| P. P \<in> set (map set (g1 G))}"
  using assms by auto

lemma lm045:
  "(\<forall>l \<in> set (g1 G). set (g2 l N) = f2 (set l) N) -->
     {f2 P N| P. P \<in> set (map set (g1 G))} = set [set (g2 l N). l <- g1 G]"
  by auto

lemma lm046:
  assumes "X \<inter> Y  =  {}"
  shows "R``X = (R outside Y)``X"
  using assms Outside_def Image_def by blast

lemma lm047:
  assumes "(Range P) \<inter> (Range Q) = {}" "runiq (P^-1)" "runiq (Q^-1)"
  shows "runiq ((P \<union> Q)^-1)"
  using assms by (metis Domain_converse converse_Un disj_Un_runiq)

lemma lm048:
  assumes "(Range P) \<inter> (Range Q) = {}" "runiq (P^-1)" "runiq (Q^-1)"
  shows "runiq ((P +* Q)^-1)"
  using lm047 assms subrel_runiq by (metis converse_converse converse_subset_swap paste_sub_Un)

lemma lm049:
  assumes "runiq R"
  shows "card (R `` {a}) = 1 \<longleftrightarrow> a \<in> Domain R"
  using assms card_Suc_eq One_nat_def
  by (metis Image_within_domain' Suc_neq_Zero assms rightUniqueSetCardinality)

(* triples a can be bracket in any way, i.e., (1st, (2nd, 3rd)) \<rightarrow> ((1st, 2nd), 3rd).*)
lemma lm050:
  "inj (\<lambda>a. ((fst a, fst (snd a)), snd (snd a)))"
  by (auto intro: injI)

lemma lm051:
  assumes "finite X" "x > Max X"
  shows "x \<notin> X"
  using assms Max.coboundedI by (metis leD)

lemma lm052:
  assumes "finite A" "A \<noteq> {}"
  shows "Max (f`A) \<in> f`A"
  using assms by (metis Max_in finite_imageI image_is_empty)

(* Note that in the following -` means the inverse image of the following set. *)
lemma lm053:
  "argmax f A \<subseteq> f -` {Max (f ` A)}"
  by force

lemma lm054:
  "argmax f A = A \<inter> { x . f x = Max (f ` A) }"
  by auto

lemma lm055:
  "(x \<in> argmax f X) = (x \<in> X & f x = Max (f ` X))"
  using argmax.simps mem_Collect_eq by (metis (mono_tags, lifting))

lemma rangeEmpty:
  "Range -` {{}} = {{}}"
  by auto

lemma finitePairSecondRange:
  "(\<forall> pair \<in> R. finite (snd pair)) = (\<forall> y \<in> Range R. finite y)"
  by fastforce

lemma lm056:
  "fst ` P = snd ` (P^-1)"
  by force

lemma lm057:
  "fst pair = snd (flip pair) & snd pair = fst (flip pair)"
  unfolding flip_def by simp

lemma flip_flip2:
  "flip \<circ> flip   =   id"
  using flip_flip by fastforce

lemma lm058:
  "fst = (snd\<circ>flip)"
  using lm057 by fastforce

lemma lm059:
  "snd = (fst\<circ>flip)"
  using lm057 by fastforce

lemma lm060:
  "inj_on fst P = inj_on (snd\<circ>flip) P"
  using lm058 by metis

lemma lm062:
  "inj_on fst P = inj_on snd (P^-1)"
  using lm060 flip_conv by (metis converse_converse inj_on_imageI lm059)

lemma sumPairsInverse:
  assumes "runiq (P^-1)"
  shows "sum (f \<circ> snd) P = sum f (Range P)"
  using assms lm062 converse_converse rightUniqueInjectiveOnFirst rightUniqueInjectiveOnFirst
        sum.reindex snd_eq_Range
  by metis

lemma notEmptyFinestpart:
  assumes "X \<noteq> {}"
  shows "finestpart X \<noteq> {}"
  using assms finestpart_def by blast

lemma lm063:
  assumes "inj_on g X"
  shows "sum f (g`X) = sum (f \<circ> g) X"
  using assms by (metis sum.reindex)

lemma functionOnFirstEqualsSecond:
  assumes "runiq R" "z \<in> R"
  shows "R,,(fst z) = snd z"
  using assms by (metis rightUniquePair surjective_pairing)

lemma lm064:
  assumes "runiq R"
  shows "sum (toFunction R) (Domain R) = sum snd R"
  using assms toFunction_def sum.reindex_cong functionOnFirstEqualsSecond
        rightUniqueInjectiveOnFirst
  by (metis (no_types) fst_eq_Domain)

corollary lm065:
  assumes "runiq (f||X)"
  shows "sum (toFunction (f||X)) (X \<inter> Domain f) = sum snd (f||X)"
  using assms lm064 by (metis Int_commute restrictedDomain)

lemma lm066:
  "Range (R outside X) = R``((Domain R) - X)"
  by (metis Diff_idemp ImageE Range.intros Range_outside_sub_Image_Domain lm041
            lm042 order_class.order.antisym subsetI)

lemma lm067:
  "(R||X) `` X = R``X"
  using Int_absorb doubleRestriction restrictedRange by metis

lemma lm068:
  assumes "x \<in> Domain (f||X)"
  shows "(f||X)``{x} = f``{x}"
  using assms doubleRestriction restrictedRange Int_empty_right Int_iff
        Int_insert_right_if1 restrictedDomain
  by metis

lemma lm069:
  assumes "x \<in> X \<inter> Domain f" "runiq (f||X)"
  shows "(f||X),,x = f,,x"
  using assms doubleRestriction restrictedRange Int_empty_right Int_iff Int_insert_right_if1
        eval_rel.simps
  by metis

lemma lm070:
  assumes "runiq (f||X)"
  shows "sum (toFunction (f||X)) (X \<inter> Domain f) = sum (toFunction f) (X \<inter> Domain f)"
  using assms sum.cong lm069 toFunction_def by metis

corollary sumRestrictedToDomainInvariant:
  assumes "runiq (f||X)"
  shows "sum (toFunction f) (X \<inter> Domain f) = sum snd (f||X)"
  using assms lm065 lm070 by fastforce

corollary sumRestrictedOnFunction:
  assumes "runiq (f||X)"
  shows "sum (toFunction (f||X)) (X \<inter> Domain f) = sum snd (f||X)"
  using assms lm064 restrictedDomain Int_commute by metis

lemma cardFinestpart:
  "card (finestpart X) = card X"
  using finestpart_def by (metis (lifting) card_image inj_on_inverseI the_elem_eq)

corollary lm071:
  "finestpart {} = {}    &    card \<circ> finestpart = card"
  using cardFinestpart finestpart_def by fastforce

lemma finiteFinestpart:
  "finite (finestpart X) = finite X"
  using finestpart_def lm071
  by (metis card_eq_0_iff empty_is_image finite.simps cardFinestpart)

lemma lm072:
  "finite \<circ> finestpart = finite"
  using finiteFinestpart by fastforce

lemma finestpartSubset:
  assumes "X \<subseteq> Y"
  shows "finestpart X \<subseteq> finestpart Y"
  using assms finestpart_def by (metis image_mono)

corollary lm073:
  assumes "x \<in> X"
  shows "finestpart x \<subseteq> finestpart (\<Union> X)"
  using assms finestpartSubset by (metis Union_upper)

lemma lm074:
  "\<Union> (finestpart ` XX) \<subseteq> finestpart (\<Union> XX)"
  using finestpart_def lm073 by force

lemma lm075:
  "\<Union> (finestpart ` XX) \<supseteq> finestpart (\<Union> XX)"
  (is "?L \<supseteq> ?R")
  unfolding finestpart_def using finestpart_def by auto

corollary commuteUnionFinestpart:
  "\<Union> (finestpart ` XX) = finestpart (\<Union> XX)"
  using lm074 lm075 by fast

lemma unionImage:
  assumes "runiq a"
  shows "{(x, {y})| x y. y \<in> \<Union> (a``{x}) & x \<in> Domain a} =
         {(x, {y})| x y. y \<in> a,,x & x \<in> Domain a}"
  using assms Image_runiq_eq_eval
  by (metis (lifting, no_types) cSup_singleton)

lemma lm076:
  assumes "runiq P"
  shows "card (Domain P) = card P"
  using assms rightUniqueInjectiveOnFirst card_image by (metis Domain_fst)

lemma finiteDomainImpliesFinite:
  assumes "runiq f"
  shows "finite (Domain f) = finite f"
  using assms Domain_empty_iff card_eq_0_iff finite.emptyI lm076 by metis

(* A relation for the sum of all y\<in>Y of f(x,y) for a fixed x. *)
lemma sumCurry:
  "sum ((curry f) x) Y = sum f ({x} \<times> Y)"
proof -
  let ?f="% y. (x, y)" let ?g="(curry f) x" let ?h=f
  have "inj_on ?f Y" by (metis(no_types) Pair_inject inj_onI)
  moreover have "{x} \<times> Y = ?f ` Y" by fast
  moreover have "\<forall> y. y \<in> Y \<longrightarrow> ?g y = ?h (?f y)" by simp
  ultimately show ?thesis using sum.reindex_cong by metis
qed

lemma lm077:
  "sum (%y. f (x,y)) Y = sum f ({x}\<times>Y)"
  using sumCurry Sigma_cong curry_def sum.cong by fastforce

corollary lm078:
  assumes "finite X"
  shows "sum f X = sum f (X-Y) + (sum f (X \<inter> Y))"
  using assms Diff_iff IntD2 Un_Diff_Int finite_Un inf_commute sum.union_inter_neutral
  by metis

lemma lm079:
  "(P +* Q)``(Domain Q\<inter>X)  =  Q``(Domain Q\<inter>X)"
  unfolding paste_def Outside_def Image_def Domain_def by blast

corollary lm080:
  "(P +* Q)``(X\<inter>(Domain Q))  =  Q``X"
  using Int_commute lm079 by (metis lm017)

corollary lm081:
  assumes "X \<inter> (Domain Q) = {}"
  shows "(P +* Q) `` X = (P outside (Domain Q))`` X"
  using assms paste_def by fast

lemma lm082:
  assumes "X\<inter>Y = {}"
  shows "(P outside Y)``X=P``X"
  using assms Outside_def by blast

corollary lm083:
  assumes "X\<inter> (Domain Q) = {}"
  shows "(P +* Q)``X=P``X"
  using assms lm081 lm082 by metis

lemma lm084:
  assumes "finite X" "finite Y" "card(X\<inter>Y) = card X"
  shows "X \<subseteq> Y"
  using assms by (metis Int_lower1 Int_lower2 card_seteq order_refl)

lemma cardinalityIntersectionEquality:
  assumes "finite X" "finite Y" "card X = card Y"
  shows "(card (X\<inter>Y) = card X)     =    (X = Y)"
  using assms lm084 by (metis card_seteq le_iff_inf order_refl)

lemma lm085: (*fixes f::"'a => 'b" fixes P::"'a => bool" fixes xx::"'a"*)
  assumes "P xx"
  shows "{(x,f x)| x. P x},,xx   =   f xx"
proof -
  let ?F="{(x,f x)| x. P x}" let ?X="?F``{xx}"
  have "?X={f xx}" using Image_def assms by blast thus ?thesis by fastforce
qed

lemma graphEqImage:
  assumes "x \<in> X"
  shows "graph X f,,x   =   f x"
  unfolding graph_def using assms lm085 by (metis (mono_tags) Gr_def)

lemma lm086:
  "Graph f,,x    =    f x"
  using UNIV_I graphEqImage lm005 by (metis(no_types))

lemma lm087:
  "toFunction (Graph f)    =    f"    (is "?L=_")
proof -
  {fix x have "?L x=f x" unfolding toFunction_def lm086 by metis}
  thus ?thesis by blast
qed

lemma lm088:
  "R outside X \<subseteq> R"
  by (metis outside_union_restrict subset_Un_eq sup_left_idem)

lemma lm089:
  "Range(f outside X) \<supseteq> (Range f)-(f``X)"
  using Outside_def by blast

lemma lm090:
  assumes "runiq P"
  shows "(P\<inverse>``((Range P)-Y)) \<inter> ((P\<inverse>)``Y)   =   {}"
  using assms rightUniqueFunctionAfterInverse by blast

lemma lm092:
  assumes "runiq f" "runiq (f^-1)"
  shows "Range(f outside X) \<subseteq> (Range f)-(f``X)"
  using assms Diff_triv lm091 lm066 Diff_iff ImageE Range_iff subsetI by metis

lemma rangeOutside:
  assumes "runiq f" "runiq (f^-1)"
  shows "Range(f outside X) = (Range f)-(f``X)"
  using assms lm089 lm092 by (metis order_class.order.antisym)

(* X and Y are family of sets such that any x and y in X and Y resp. are disjoint. *)
lemma unionIntersectionEmpty:
  "(\<forall>x\<in>X. \<forall>y\<in>Y. x\<inter>y = {}) = ((\<Union>X)\<inter>(\<Union> Y)={})"
  by blast

lemma setEqualityAsDifference:
  "{x}-{y} = {}  =  (x = y)"
  by auto

lemma lm093:
  assumes "R \<noteq> {}" "Domain R \<inter> X \<noteq> {}"
  shows "R``X \<noteq> {}"
  using assms by blast

lemma lm095:
  "R \<subseteq> (Domain R) \<times> (Range R)"
  by auto

lemma finiteRelationCharacterization:
  "(finite (Domain Q) & finite (Range Q)) = finite Q"
  using rev_finite_subset finite_SigmaI lm095 finite_Domain finite_Range by metis

lemma familyUnionFiniteEverySetFinite:
  assumes "finite (\<Union> XX)"
  shows "\<forall>X \<in> XX. finite X"
  using assms by (metis Union_upper finite_subset)

lemma lm096:
  assumes "runiq f" "X \<subseteq> (f^-1)``Y"
  shows "f``X \<subseteq> Y"
  using assms rightUniqueFunctionAfterInverse by (metis Image_mono order_refl subset_trans)

lemma lm097:
  assumes "y \<in> f``{x}" "runiq f"
  shows "f,,x = y"
  using assms by (metis Image_singleton_iff rightUniquePair)

subsection \<open>Indicator function in set-theoretical form.\<close>

abbreviation
  "Outside' X f == f outside X"

abbreviation
  "Chi X Y == (Y \<times> {0::nat}) +* (X \<times> {1})"
  notation Chi (infix "<||" 80)

abbreviation
  "chii X Y == toFunction (X <|| Y)"
  notation chii (infix "<|" 80)

(* X is a set and chi X is a function that returns 1 for elements X and 0 else. *)
abbreviation
  "chi X == indicator X"

lemma lm098:
  "runiq (X <|| Y)"
  by (rule lm014)

lemma lm099:
  assumes "x \<in> X"
  shows "1 \<in> (X <|| Y) `` {x}"
  using assms toFunction_def paste_def Outside_def runiq_def lm014 by blast

lemma lm100:
  assumes "x \<in> Y-X"
  shows "0 \<in> (X <|| Y) `` {x}"
  using assms toFunction_def paste_def Outside_def runiq_def lm014 by blast

lemma lm101:
  assumes "x \<in> X \<union> Y"
  shows "(X <|| Y),,x = chi X x" (is "?L=?R")
  using assms lm014 lm099 lm100 lm097
  by (metis DiffI Un_iff indicator_simps(1) indicator_simps(2))

lemma lm102:
  assumes "x \<in> X \<union> Y"
  shows "(X <| Y) x = chi X x"
  using assms toFunction_def lm101 by metis

corollary lm103:
  "sum (X <| Y) (X\<union>Y) = sum (chi X) (X\<union>Y)"
  using lm102 sum.cong by metis

corollary lm104:
  assumes "\<forall>x\<in>X. f x = g x"
  shows "sum f X = sum g X"
  using assms by (metis (poly_guards_query) sum.cong)

corollary lm105:
  assumes "\<forall>x\<in>X. f x = g x" "Y\<subseteq>X"
  shows "sum f Y = sum g Y"
  using assms lm104 by (metis contra_subsetD)

corollary lm106:
  assumes "Z \<subseteq> X \<union> Y"
  shows "sum (X <| Y) Z = sum (chi X) Z"
proof -
  have "\<forall>x\<in>Z.(X<|Y) x=(chi X) x" using assms lm102 in_mono by metis
  thus ?thesis using lm104 by blast
qed

corollary lm107:
  "sum (chi X) (Z - X) = 0"
  by simp

corollary lm108:
  assumes "Z \<subseteq> X \<union> Y"
  shows "sum (X <| Y) (Z - X) = 0"
  using assms lm107 lm106 Diff_iff in_mono subsetI by metis

corollary lm109:
  assumes "finite Z"
  shows "sum (X <| Y) Z    =    sum (X <| Y) (Z - X)   +  (sum (X <| Y) (Z \<inter> X))"
  using lm078 assms by blast

corollary lm110:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "sum (X <| Y) Z = sum (X <| Y) (Z \<inter> X)"
  using assms lm078 lm108 comm_monoid_add_class.add_0 by metis

corollary lm111:
  assumes "finite Z"
  shows "sum (chi X) Z = card (X \<inter> Z)"
  using assms sum_indicator_eq_card by (metis Int_commute)

corollary lm112:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "sum (X <| Y) Z = card (Z \<inter> X)"
  using assms lm111 by (metis lm106 sum_indicator_eq_card)

corollary subsetCardinality:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "(sum (X <| Y) X) - (sum (X <| Y) Z) = card X - card (Z \<inter> X)"
  using assms lm112 by (metis Int_absorb2 Un_upper1 card_infinite equalityE sum.infinite)

corollary differenceSumVsCardinality:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "int (sum (X <| Y) X) - int (sum (X <| Y) Z) =  int (card X) - int (card (Z \<inter> X))"
  using assms lm112 by (metis Int_absorb2 Un_upper1 card_infinite equalityE sum.infinite)

(* type conversion in Isabelle *)
lemma lm113:
  "int (n::nat) = real n"
  by simp

(* same as differenceSumVsCardinality but for type real *)
corollary differenceSumVsCardinalityReal:
  assumes "Z\<subseteq>X\<union>Y" "finite Z"
  shows "real (sum (X <| Y) X) - real (sum (X <| Y) Z) =
         real (card X) - real (card (Z \<inter> X))"
  using assms lm112 by (metis Int_absorb2 Un_upper1 card_infinite equalityE sum.infinite)

subsection \<open>Lists\<close>
(* If there is an element in a list satisfying P, then the list of all elements satisfying P is not the empty list *)

(* Assume ll is an element of list l, then there is an index n such that the n-th entry of l is ll. *)
lemma lm115:
  assumes "ll \<in> set (l::'a list)"
  shows "\<exists> n\<in> (nth l) -` (set l). ll=l!n"
  using assms(1) by (metis in_set_conv_nth vimageI2)

(* variant of the above *)
lemma lm116:
  assumes "ll \<in> set (l::'a list)"
  shows "\<exists> n. ll=l!n & n < size l & n >= 0"
  using assms in_set_conv_nth by (metis le0)

(* another variant of the above *)
lemma lm117:
  assumes "P -` {True} \<inter> set l \<noteq> {}"
  shows "\<exists> n \<in> {0..<size l}. P (l!n)"
  using assms lm116 by fastforce

(* variant of lm114 *)
lemma nonEmptyListFiltered:
  assumes "P -` {True} \<inter> set l \<noteq> {}"
  shows "[n. n \<leftarrow> [0..<size l], P (l!n)] \<noteq> []"
  using assms filterpositions2_def lm117 lm114 by metis

(* take the elements of a list l which are also in a set X then this forms a subset of X intersection with the elements of the list *)
lemma lm118:
  "(nth l) ` set ([n. n \<leftarrow> [0..<size l], (%x. x\<in>X) (l!n)]) \<subseteq> X\<inter>set l"
  by force

(* variant of the above *)
corollary lm119:
  "(nth l)` set (filterpositions2 (%x.(x\<in>X)) l) \<subseteq> X \<inter>  set l"
  unfolding filterpositions2_def using lm118 by fast

lemma lm120:
  "(n\<in>{0..<N}) = ((n::nat) < N)"
  using atLeast0LessThan lessThan_iff by metis

(* If X is a set of indices then the corresponding elements combined are a subset of all the elements of the list. *)
lemma lm121:
  assumes "X \<subseteq> {0..<size list}"
  shows "(nth list)`X \<subseteq> set list"
  using assms atLeastLessThan_def atLeast0LessThan lessThan_iff by auto

(* The indices of the elements of a list satisfying a predicate P are a subset of all the indices. *)
lemma lm122:
  "set ([n. n \<leftarrow> [0..<size l], P (l!n)]) \<subseteq> {0..<size l}"
  by force

(* variant of the above *)
lemma lm123:
  "set (filterpositions2 pre list) \<subseteq> {0..<size list}"
  using filterpositions2_def lm122 by metis

subsection \<open>Computing all the permutations of a list\<close>
abbreviation
  "rotateLeft == rotate"
abbreviation
  "rotateRight n l == rotateLeft (size l - (n mod (size l))) l"

(* for n in {0, ..., size l} inserts x in l so that it will have index n in the output*)
(* note that for other n, the behaviour is not guaranteed to be consistent with that *)
abbreviation
  "insertAt x l n == rotateRight n (x#(rotateLeft n l))"

(* for n in {0,..., fact(size l) - 1 },
   perm2 l n gives all and only the possible permutations of l *)
fun perm2 where
  "perm2 [] = (%n. [])" |
  "perm2 (x#l) = (%n. insertAt x ((perm2 l) (n div (1+size l)))
                      (n mod (1+size l)))"

abbreviation
  "takeAll P list == map (nth list) (filterpositions2 P list)"

lemma permutationNotEmpty:
  assumes "l \<noteq> []"
  shows "perm2 l n \<noteq> []"
  using assms perm2.simps(2) rotate_is_Nil_conv by (metis neq_Nil_conv)

lemma lm124:
  "set (takeAll P list) = ((nth list) ` set (filterpositions2 P list))"
  by simp

corollary listIntersectionWithSet:
  "set (takeAll (%x.(x\<in>X)) l) \<subseteq>  (X \<inter> set l)"
  using lm119 lm124 by metis

corollary lm125:
  "set (takeAll P list) \<subseteq> set list"
  using lm123 lm124 lm121 by metis

lemma takeAllSubset:
  "set (takeAll (%x. x\<in> P) list) \<subseteq> P"
  by (metis Int_subset_iff listIntersectionWithSet)

lemma lm126:
  "set (insertAt x l n) = {x} \<union> set l"
  by simp

lemma lm127:
  "\<forall>n. set (perm2 [] n) = set []"
  by simp

lemma lm128:
  assumes "\<forall>n. (set (perm2 l n) = set l)"
  shows "set (perm2 (x#l) n) = {x} \<union> set l"
  using assms lm126 by force

(* Combining the previous two lemmas we get inductively that the set of elements in a permuted list are the same as the elements in the original list. This is weaker than saying (perm2 l n) is a permutation of l, but suffices for our purposes. *)
corollary permutationInvariance:
   "\<forall>n. set (perm2 (l::'a list) n) = set l"
proof (induct l)
   let ?P = "%l::('a list). (\<forall>n. set (perm2 l n)  =  set l)"
   show "?P []" using lm127 by force
   fix x fix l
   assume "?P l" then
   show "?P (x#l)" by force
qed

(* variant of listIntersectionWithSet with permutation added *)
corollary takeAllPermutation:
  "set (perm2 (takeAll (%x.(x\<in>X)) l) n)  \<subseteq>  X \<inter> set l"
  using listIntersectionWithSet permutationInvariance by metis

(* "subList list1 list2" extracts the components of list1 according to the indices given in list2, e.g.,  "subList [1::nat,2,3,4] [0,2]" gives [1,3] *)
abbreviation "subList l xl == map (nth l) (takeAll (%x. x \<le> size l) xl)"

subsection \<open>A more computable version of @{term toFunction}.\<close>

(* If R is a relation and the image of x is unique then take that, else take the fallback *)
abbreviation "toFunctionWithFallback R fallback ==
              (% x. if (R``{x} = {R,,x}) then (R,,x) else fallback)"
notation
  toFunctionWithFallback (infix "Else" 75)

abbreviation sum' where
  "sum' R X == sum (R Else 0) X"

lemma lm129:
  assumes "runiq f" "x \<in> Domain f"
  shows "(f Else 0) x = (toFunction f) x"
  using assms by (metis Image_runiq_eq_eval toFunction_def)

lemma lm130:
  assumes "runiq f"
  shows "sum (f Else 0) (X\<inter>(Domain f))  =  sum (toFunction f) (X\<inter>(Domain f))"
  using assms sum.cong lm129 by fastforce

lemma lm131:
  assumes "Y \<subseteq> f-`{0}"
  shows "sum f Y  =  0"
  using assms by (metis rev_subsetD sum.neutral vimage_singleton_eq)

lemma lm132:
  assumes "Y \<subseteq> f-`{0}" "finite X"
  shows "sum f X = sum f (X-Y)"
  using Int_lower2 add.comm_neutral assms(1) assms(2) lm078 lm131 order_trans
  by (metis (no_types))

(* - means the complement of a set. *)
lemma lm133:
  "-(Domain f) \<subseteq> (f Else 0)-`{0}"
  by fastforce

corollary lm134:
  assumes "finite X"
  shows "sum (f Else 0) X    =   sum (f Else 0) (X\<inter>Domain f)"
proof -
  have "X\<inter>Domain f=X-(-Domain f)" by simp
  thus ?thesis using assms lm133 lm132 by fastforce
qed

corollary lm135:
  assumes "finite X"
  shows "sum (f Else 0) (X\<inter>Domain f)   =   sum (f Else 0) X"
  (is "?L=?R")
proof -
  have "?R=?L" using assms by (rule lm134)
  thus ?thesis by simp
qed

corollary lm136:
  assumes "finite X" "runiq f"
  shows "sum (f Else 0) X = sum (toFunction f) (X\<inter>Domain f)"
  (is "?L=?R")
proof -
  have "?R = sum (f Else 0) (X\<inter>Domain f) " using assms(2) lm130 by fastforce
  moreover have "... = ?L" using assms(1) by (rule lm135)
  ultimately show ?thesis by presburger
qed

lemma lm137:
  "sum (f Else 0) X = sum' f X"
  by fast

corollary lm138:
  assumes "finite X" "runiq f"
  shows "sum (toFunction f) (X\<inter>Domain f)   =   sum' f X"
  using assms lm137 lm136 by fastforce

lemma lm139:
  "argmax (sum' b) = (argmax \<circ> sum') b"
  by simp

lemma domainConstant:
  "Domain (Y \<times> {0::nat}) = Y & Domain (X \<times> {1}) = X"
  by blast

lemma domainCharacteristicFunction:
  "Domain (X <|| Y) = X \<union> Y"
  using domainConstant paste_Domain sup_commute by metis

lemma functionEquivalenceOnSets:
  assumes "\<forall>x \<in> X. f x = g x"
  shows "f`X = g`X"
  using assms by (metis image_cong)

subsection \<open>Cardinalities of sets.\<close>
lemma lm140:
  assumes "runiq R" "runiq (R^-1)"
  shows "(R``A) \<inter> (R``B) = R``(A\<inter>B)"
  using assms rightUniqueInjectiveOnFirst converse_Image by force

lemma intersectionEmptyRelationIntersectionEmpty:
  assumes "runiq (R^-1)" "runiq R" "X1 \<inter> X2 = {}"
  shows "(R``X1) \<inter> (R``X2) = {}"
  using assms by (metis disj_Domain_imp_disj_Image inf_assoc inf_bot_right)

lemma lm141:
  assumes "runiq f" "trivial Y"
  shows "trivial (f `` (f^-1 `` Y))"
  using assms by (metis rightUniqueFunctionAfterInverse trivial_subset)

lemma lm142:
  assumes "trivial X"
  shows "card (Pow X)\<in>{1,2}"
  using trivial_empty_or_singleton card_Pow Pow_empty assms trivial_implies_finite
        cardinalityOneTheElemIdentity power_one_right the_elem_eq
  by (metis insert_iff)

lemma lm143:
  assumes "card (Pow A) = 1"
  shows "A = {}"
  using assms by (metis Pow_bottom Pow_top cardinalityOneTheElemIdentity singletonD)

(* Note that in Isabelle infinite sets have cardinality 0 *)
lemma lm144:
  "(\<not> (finite A)) = (card (Pow A) = 0)"
  by auto

corollary lm145:
  "(finite A) = (card (Pow A) \<noteq> 0)"
  using lm144 by metis

lemma lm146:
  assumes "card (Pow A) \<noteq> 0"
  shows "card A=Discrete.log (card (Pow A))"
  using assms log_exp card_Pow by (metis card_infinite finite_Pow_iff)

lemma log_2 [simp]:
  "Discrete.log 2 = 1"
  using log_exp [of 1] by simp

lemma lm147:
  assumes "card (Pow A) = 2"
  shows "card A = 1"
  using assms lm146 [of A] by simp

lemma lm148:
  assumes "card (Pow X) = 1 \<or> card (Pow X) = 2"
  shows "trivial X"
  using assms trivial_empty_or_singleton lm143 lm147 cardinalityOneTheElemIdentity by metis

lemma lm149:
  "trivial A = (card (Pow A) \<in> {1,2})"
  using lm148 lm142 by blast

lemma lm150:
  assumes "R \<subseteq> f" "runiq f" "Domain f = Domain R"
  shows "runiq R"
  using assms by (metis subrel_runiq)

lemma lm151:
  assumes "f \<subseteq> g" "runiq g" "Domain f = Domain g"
  shows "g \<subseteq> f"
  using assms Domain_iff contra_subsetD runiq_wrt_ex1 subrelI
  by (metis (full_types,hide_lams))

lemma lm152:
  assumes "R \<subseteq> f" "runiq f" "Domain f \<subseteq> Domain R"
  shows "f = R"
  using assms lm151 by (metis Domain_mono dual_order.antisym)

lemma lm153:
  "graph X f = (Graph f) || X"
  using inf_top.left_neutral lm005 domainOfGraph restrictedDomain lm152 graphIntersection
        restriction_is_subrel subrel_runiq subset_iff
  by (metis (erased, lifting))

lemma lm154:
  "graph (X \<inter> Y) f = (graph X f) || Y"
  using doubleRestriction lm153 by metis

lemma restrictionVsIntersection:
  "{(x, f x)| x. x \<in> X2} || X1 = {(x, f x)| x. x \<in> X2 \<inter> X1}"
  using graph_def lm154 by metis

lemma lm155:
  assumes "runiq f" "X \<subseteq> Domain f"
  shows "graph X (toFunction f) = (f||X)"
proof -
  have "\<And>v w. (v::'a set) \<subseteq> w \<longrightarrow> w \<inter> v = v" by (simp add: Int_commute inf.absorb1)
  thus "graph X (toFunction f) = f || X" by (metis assms(1) assms(2) doubleRestriction lm004 lm153)
qed

lemma lm156:
  "(Graph f) `` X = f ` X"
  unfolding Graph_def image_def by auto

lemma lm157:
  assumes "X \<subseteq> Domain f" "runiq f"
  shows "f``X = (eval_rel f)`X"
  using assms lm156 by (metis restrictedRange lm153 lm155 toFunction_def)

lemma cardOneImageCardOne:
  assumes "card A = 1"
  shows "card (f`A) = 1"
  using assms card_image card_image_le
proof -
  have "finite (f`A)" using assms One_nat_def Suc_not_Zero card_infinite finite_imageI
       by (metis(no_types))
  moreover have "f`A \<noteq> {}" using assms by fastforce
  moreover have "card (f`A) \<le> 1" using assms card_image_le One_nat_def Suc_not_Zero card_infinite
       by (metis)
  ultimately show ?thesis by (metis assms image_empty image_insert
                                    cardinalityOneTheElemIdentity the_elem_eq)
qed

lemma cardOneTheElem:
  assumes "card A = 1"
  shows "the_elem (f`A) = f (the_elem A)"
  using assms image_empty image_insert the_elem_eq by (metis cardinalityOneTheElemIdentity)

(* With split being the inverse of curry we have with g as swap f,  (g x y) = (f y x) *)
abbreviation
  "swap f == curry ((case_prod f) \<circ> flip)" (*swaps the two arguments of a function*)

(* X is finite if and only if X is the set of elements of some list. *)
lemma lm158:
  "finite X   =  (X \<in> range set)"
  by (metis List.finite_set finite_list image_iff rangeI)

(* as above, just as lambda expression *)
lemma lm159:
  "finite = (%X. X\<in>range set)"
  using lm158 by metis

lemma lm160:
  "swap f = (%x. %y. f y x)"
  by (metis comp_eq_dest_lhs curry_def flip_def fst_conv old.prod.case snd_conv)

subsection \<open>Some easy properties on real numbers\<close>
lemma lm161:
  fixes a::real
  fixes b c
  shows "a*b - a*c=a*(b-c)"
  by (metis real_scaleR_def real_vector.scale_right_diff_distrib)

lemma lm162:
  fixes a::real
  fixes b c
  shows "a*b - c*b=(a-c)*b"
  using lm161 by (metis mult.commute)

end


(*  Title:      ZF/ex/CoUnit.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Trivial codatatype definitions, one of which goes wrong!\<close>

theory CoUnit imports ZF begin

text \<open>
  See discussion in: L C Paulson.  A Concrete Final Coalgebra Theorem
  for ZF Set Theory.  Report 334, Cambridge University Computer
  Laboratory.  1994.

  \bigskip

  This degenerate definition does not work well because the one
  constructor's definition is trivial!  The same thing occurs with
  Aczel's Special Final Coalgebra Theorem.
\<close>

consts
  counit :: i
codatatype
  "counit" = Con ("x \<in> counit")

inductive_cases ConE: "Con(x) \<in> counit"
  \<comment> \<open>USELESS because folding on \<^term>\<open>Con(xa) == xa\<close> fails.\<close>

lemma Con_iff: "Con(x) = Con(y) \<longleftrightarrow> x = y"
  \<comment> \<open>Proving freeness results.\<close>
  by (auto elim!: counit.free_elims)

lemma counit_eq_univ: "counit = quniv(0)"
  \<comment> \<open>Should be a singleton, not everything!\<close>
  apply (rule counit.dom_subset [THEN equalityI])
  apply (rule subsetI)
  apply (erule counit.coinduct)
   apply (rule subset_refl)
  apply (unfold counit.con_defs)
  apply fast
  done

text \<open>
  \medskip A similar example, but the constructor is non-degenerate
  and it works!  The resulting set is a singleton.
\<close>

consts
  counit2 :: i
codatatype
  "counit2" = Con2 ("x \<in> counit2", "y \<in> counit2")

inductive_cases Con2E: "Con2(x, y) \<in> counit2"

lemma Con2_iff: "Con2(x, y) = Con2(x', y') \<longleftrightarrow> x = x' & y = y'"
  \<comment> \<open>Proving freeness results.\<close>
  by (fast elim!: counit2.free_elims)

lemma Con2_bnd_mono: "bnd_mono(univ(0), %x. Con2(x, x))"
  apply (unfold counit2.con_defs)
  apply (rule bnd_monoI)
   apply (assumption | rule subset_refl QPair_subset_univ QPair_mono)+
  done

lemma lfp_Con2_in_counit2: "lfp(univ(0), %x. Con2(x,x)) \<in> counit2"
  apply (rule singletonI [THEN counit2.coinduct])
  apply (rule qunivI [THEN singleton_subsetI])
  apply (rule subset_trans [OF lfp_subset empty_subsetI [THEN univ_mono]])
  apply (fast intro!: Con2_bnd_mono [THEN lfp_unfold])
  done

lemma counit2_Int_Vset_subset [rule_format]:
  "Ord(i) ==> \<forall>x y. x \<in> counit2 \<longrightarrow> y \<in> counit2 \<longrightarrow> x \<inter> Vset(i) \<subseteq> y"
  \<comment> \<open>Lemma for proving finality.\<close>
  apply (erule trans_induct)
  apply (tactic "safe_tac (put_claset subset_cs \<^context>)")
  apply (erule counit2.cases)
  apply (erule counit2.cases)
  apply (unfold counit2.con_defs)
  apply (tactic \<open>fast_tac (put_claset subset_cs \<^context>
    addSIs [@{thm QPair_Int_Vset_subset_UN} RS @{thm subset_trans}, @{thm QPair_mono}]
    addSEs [@{thm Ord_in_Ord}, @{thm Pair_inject}]) 1\<close>)
  done

lemma counit2_implies_equal: "[| x \<in> counit2;  y \<in> counit2 |] ==> x = y"
  apply (rule equalityI)
  apply (assumption | rule conjI counit2_Int_Vset_subset [THEN Int_Vset_subset])+
  done

lemma counit2_eq_univ: "counit2 = {lfp(univ(0), %x. Con2(x,x))}"
  apply (rule equalityI)
   apply (rule_tac [2] lfp_Con2_in_counit2 [THEN singleton_subsetI])
  apply (rule subsetI)
  apply (drule lfp_Con2_in_counit2 [THEN counit2_implies_equal])
  apply (erule subst)
  apply (rule singletonI)
  done

end


(*  Title:       Syntactic Ordinals in Cantor Normal Form
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Author:      Mathias Fleury <mfleury at mpi-inf.mpg.de>, 2016
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Syntactic Ordinals in Cantor Normal Form\<close>

theory Syntactic_Ordinal
imports Hereditary_Multiset "HOL-Library.Product_Order" "HOL-Library.Extended_Nat"
begin

subsection \<open>Natural (Hessenberg) Product\<close>

instantiation hmultiset :: comm_semiring_1
begin

abbreviation \<omega>_exp :: "hmultiset \<Rightarrow> hmultiset" ("\<omega>^") where
  "\<omega>^ \<equiv> \<lambda>m. HMSet {#m#}"

definition one_hmultiset :: hmultiset where
  "1 = \<omega>^0"

abbreviation \<omega> :: hmultiset where
  "\<omega> \<equiv> \<omega>^1"

definition times_hmultiset :: "hmultiset \<Rightarrow> hmultiset \<Rightarrow> hmultiset"  where
  "A * B = HMSet (image_mset (case_prod (+)) (hmsetmset A \<times># hmsetmset B))"

lemma hmsetmset_times:
  "hmsetmset (m * n) = image_mset (case_prod (+)) (hmsetmset m \<times># hmsetmset n)"
  unfolding times_hmultiset_def by simp

instance
proof (intro_classes, goal_cases assoc comm one distrib_plus zeroL zeroR zero_one)
  case (assoc a b c)
  thus ?case
    by (auto simp: times_hmultiset_def Times_mset_image_mset1 Times_mset_image_mset2
      Times_mset_assoc ac_simps intro: multiset.map_cong)
next
  case (comm a b)
  thus ?case
    unfolding times_hmultiset_def
    by (subst product_swap_mset[symmetric]) (auto simp: ac_simps intro: multiset.map_cong)
next
  case (one a)
  thus ?case
    by (auto simp: one_hmultiset_def times_hmultiset_def Times_mset_single_left)
next
  case (distrib_plus a b c)
  thus ?case
    by (auto simp: plus_hmultiset_def times_hmultiset_def)
next
  case (zeroL a)
  thus ?case
    by (auto simp: times_hmultiset_def)
next
  case (zeroR a)
  thus ?case
    by (auto simp: times_hmultiset_def)
next
  case zero_one
  thus ?case
    by (auto simp: one_hmultiset_def)
qed

end

lemma empty_times_left_hmset[simp]: "HMSet {#} * M = 0"
  by (simp add: times_hmultiset_def)

lemma empty_times_right_hmset[simp]: "M * HMSet {#} = 0"
  by (metis mult_zero_right zero_hmultiset_def)

lemma singleton_times_left_hmset[simp]: "\<omega>^M * N = HMSet (image_mset ((+) M) (hmsetmset N))"
  by (simp add: times_hmultiset_def Times_mset_single_left)

lemma singleton_times_right_hmset[simp]: "N * \<omega>^M = HMSet (image_mset ((+) M) (hmsetmset N))"
  by (metis mult.commute singleton_times_left_hmset)

subsection \<open>Inequalities\<close>

definition plus_nmultiset :: "unit nmultiset \<Rightarrow> unit nmultiset \<Rightarrow> unit nmultiset"  where
  "plus_nmultiset X Y = Rep_hmultiset (Abs_hmultiset X + Abs_hmultiset Y)"

lemma plus_nmultiset_mono:
  assumes less: "(X, Y) < (X', Y')" and no_elem: "no_elem X" "no_elem Y" "no_elem X'" "no_elem Y'"
  shows "plus_nmultiset X Y < plus_nmultiset X' Y'"
  using less[unfolded less_le_not_le] no_elem
  by (auto simp: plus_nmultiset_def plus_hmultiset_def less_multiset_ext\<^sub>D\<^sub>M_less less_eq_nmultiset_def
          union_less_mono type_definition.Abs_inverse[OF type_definition_hmultiset, simplified]
        elim!: no_elem.cases)

lemma plus_hmultiset_transfer[transfer_rule]:
  "(rel_fun pcr_hmultiset (rel_fun pcr_hmultiset pcr_hmultiset)) plus_nmultiset (+)"
  unfolding rel_fun_def plus_nmultiset_def pcr_hmultiset_def nmultiset.rel_eq eq_OO cr_hmultiset_def
  by (auto simp: type_definition.Rep_inverse[OF type_definition_hmultiset])

lemma Times_mset_monoL:
  assumes less: "M < N" and Z_nemp: "Z \<noteq> {#}"
  shows "M \<times># Z < N \<times># Z"
proof -
  obtain Y X where
    Y_nemp: "Y \<noteq> {#}" and Y_sub_N: "Y \<subseteq># N" and M_eq: "M = N - Y + X" and
    ex_Y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> x < y)"
    using less[unfolded less_multiset\<^sub>D\<^sub>M] by blast

  let ?X = "X \<times># Z"
  let ?Y = "Y \<times># Z"

  show ?thesis
    unfolding less_multiset\<^sub>D\<^sub>M
  proof (intro exI conjI)
    show "M \<times># Z = N \<times># Z - ?Y + ?X"
      unfolding M_eq by (auto simp: Sigma_mset_Diff_distrib1)
  next
    obtain y where y: "\<forall>x. x \<in># X \<longrightarrow> y x \<in># Y \<and> x < y x"
      using ex_Y by moura

    show "\<forall>x. x \<in># ?X \<longrightarrow> (\<exists>y. y \<in># ?Y \<and> x < y)"
    proof (intro allI impI)
      fix x
      assume "x \<in># ?X"
      thus "\<exists>y. y \<in># ?Y \<and> x < y"
        using y by (intro exI[of _ "(y (fst x), snd x)"]) (auto simp: less_le_not_le)
    qed
  qed (auto simp: Z_nemp Y_nemp Y_sub_N Sigma_mset_mono)
qed

lemma times_hmultiset_monoL:
  "a < b \<Longrightarrow> 0 < c \<Longrightarrow> a * c < b * c" for a b c :: hmultiset
  by (cases a, cases b, cases c, hypsubst_thin,
    unfold times_hmultiset_def zero_hmultiset_def hmultiset.sel, transfer,
    auto simp: less_multiset_ext\<^sub>D\<^sub>M_less multiset.pred_set
      intro!: image_mset_strict_mono Times_mset_monoL elim!: plus_nmultiset_mono)

instance hmultiset :: linordered_semiring_strict
  by intro_classes (subst (1 2) mult.commute, rule times_hmultiset_monoL)

lemma mult_le_mono1_hmset: "i \<le> j \<Longrightarrow> i * k \<le> j * k" for i j k :: hmultiset
  by (simp add: mult_right_mono)

lemma mult_le_mono2_hmset: "i \<le> j \<Longrightarrow> k * i \<le> k * j" for i j k :: hmultiset
  by (simp add: mult_left_mono)

lemma mult_le_mono_hmset: "i \<le> j \<Longrightarrow> k \<le> l \<Longrightarrow> i * k \<le> j * l" for i j k l :: hmultiset
  by (simp add: mult_mono)

lemma less_iff_add1_le_hmset: "m < n \<longleftrightarrow> m + 1 \<le> n" for m n :: hmultiset
proof (cases m n rule: hmultiset.exhaust[case_product hmultiset.exhaust])
  case (HMSet_HMSet m0 n0)
  note m = this(1) and n = this(2)

  show ?thesis
  proof (simp add: m n one_hmultiset_def plus_hmultiset_def order.order_iff_strict
      less_multiset_ext\<^sub>D\<^sub>M_less, intro iffI)
    assume m0_lt_n0: "m0 < n0"
    note
      m0_ne_n0 = m0_lt_n0[unfolded less_multiset\<^sub>H\<^sub>O, THEN conjunct1] and
      ex_n0_gt_m0 = m0_lt_n0[unfolded less_multiset\<^sub>H\<^sub>O, THEN conjunct2, rule_format]

    {
      assume zero_m0_gt_n0: "add_mset 0 m0 > n0"
      note
        n0_ne_0m0 = zero_m0_gt_n0[unfolded less_multiset\<^sub>H\<^sub>O, THEN conjunct1] and
        ex_0m0_gt_n0 = zero_m0_gt_n0[unfolded less_multiset\<^sub>H\<^sub>O, THEN conjunct2, rule_format]

      {
        fix y
        assume m0y_lt_n0y: "count m0 y < count n0 y"

        have "\<exists>x > y. count n0 x < count m0 x"
        proof (cases "count (add_mset 0 m0) y < count n0 y")
          case True
          then obtain aa where
            aa_gt_y: "aa > y" and
            count_n0aa_lt_count_0m0aa: "count n0 aa < count (add_mset 0 m0) aa"
            using ex_0m0_gt_n0 by blast
          have "aa \<noteq> 0"
            by (rule gr_implies_not_zero_hmset[OF aa_gt_y])
          hence "count (add_mset 0 m0) aa = count m0 aa"
            by simp
          thus ?thesis
            using count_n0aa_lt_count_0m0aa aa_gt_y by auto
        next
          case not_0m0_y_lt_n0y: False
          hence y_eq_0: "y = 0"
            by (metis count_add_mset m0y_lt_n0y)
          have sm0y_eq_n0y: "Suc (count m0 y) = count n0 y"
            using m0y_lt_n0y not_0m0_y_lt_n0y count_add_mset[of 0 _ 0] unfolding y_eq_0 by simp

          obtain bb where "count n0 bb < count (add_mset 0 m0) bb"
            using lt_imp_ex_count_lt[OF zero_m0_gt_n0] by blast
          hence n0bb_lt_m0bb: "count n0 bb < count m0 bb"
            unfolding count_add_mset by (metis (full_types) less_irrefl_nat sm0y_eq_n0y y_eq_0)
          hence "bb \<noteq> 0"
            using sm0y_eq_n0y y_eq_0 by auto
          thus ?thesis
            unfolding y_eq_0 using n0bb_lt_m0bb not_gr_zero_hmset by blast
        qed
      }
      hence "n0 < m0"
        unfolding less_multiset\<^sub>H\<^sub>O using m0_ne_n0 by blast
      hence False
        using m0_lt_n0 by simp
    }
    thus "add_mset 0 m0 < n0 \<or> add_mset 0 m0 = n0"
      using antisym_conv3 by blast
  next
    assume "add_mset 0 m0 < n0 \<or> add_mset 0 m0 = n0"
    thus "m0 < n0"
      using dual_order.strict_trans le_multiset_right_total by blast
  qed
qed

lemma zero_less_iff_1_le_hmset: "0 < n \<longleftrightarrow> 1 \<le> n" for n :: hmultiset
  by (rule less_iff_add1_le_hmset[of 0, simplified])

lemma less_add_1_iff_le_hmset: "m < n + 1 \<longleftrightarrow> m \<le> n" for m n :: hmultiset
  by (rule less_iff_add1_le_hmset[of m "n + 1", simplified])

instance hmultiset :: ordered_cancel_comm_semiring
  by intro_classes (simp add: mult_le_mono2_hmset)

instance hmultiset :: zero_less_one
  by intro_classes (simp add: zero_less_iff_neq_zero_hmset)

instance hmultiset :: linordered_semiring_1_strict
  by intro_classes

instance hmultiset :: bounded_lattice_bot
  by intro_classes

instance hmultiset :: linordered_nonzero_semiring
  by intro_classes simp

instance hmultiset :: semiring_no_zero_divisors
  by intro_classes (use mult_pos_pos not_gr_zero_hmset in blast)

lemma lt_1_iff_eq_0_hmset: "M < 1 \<longleftrightarrow> M = 0" for M :: hmultiset
  by (simp add: less_iff_add1_le_hmset)

lemma zero_less_mult_iff_hmset[simp]: "0 < m * n \<longleftrightarrow> 0 < m \<and> 0 < n" for m n :: hmultiset
  using mult_eq_0_iff not_gr_zero_hmset by blast

lemma one_le_mult_iff_hmset[simp]: "1 \<le> m * n \<longleftrightarrow> 1 \<le> m \<and> 1 \<le> n" for m n :: hmultiset
  by (metis lt_1_iff_eq_0_hmset mult_eq_0_iff not_le)

lemma mult_less_cancel2_hmset[simp]: "m * k < n * k \<longleftrightarrow> 0 < k \<and> m < n" for k m n :: hmultiset
  by (metis gr_zeroI_hmset leD leI le_cases mult_right_mono mult_zero_right times_hmultiset_monoL)

lemma mult_less_cancel1_hmset[simp]: "k * m < k * n \<longleftrightarrow> 0 < k \<and> m < n" for k m n :: hmultiset
  by (simp add: mult.commute[of k])

lemma mult_le_cancel1_hmset[simp]: "k * m \<le> k * n \<longleftrightarrow> (0 < k \<longrightarrow> m \<le> n)" for k m n :: hmultiset
  by (simp add: linorder_not_less[symmetric], auto)

lemma mult_le_cancel2_hmset[simp]: "m * k \<le> n * k \<longleftrightarrow> (0 < k \<longrightarrow> m \<le> n)" for k m n :: hmultiset
  by (simp add: linorder_not_less[symmetric], auto)

lemma mult_le_cancel_left1_hmset: "y > 0 \<Longrightarrow> x \<le> x * y" for x y :: hmultiset
  by (metis zero_less_iff_1_le_hmset mult.commute mult.left_neutral mult_le_cancel2_hmset)

lemma mult_le_cancel_left2_hmset: "y \<le> 1 \<Longrightarrow> x * y \<le> x" for x y :: hmultiset
  by (metis mult.commute mult.left_neutral mult_le_cancel2_hmset)

lemma mult_le_cancel_right1_hmset: "y > 0 \<Longrightarrow> x \<le> y * x" for x y :: hmultiset
  by (subst mult.commute) (fact mult_le_cancel_left1_hmset)

lemma mult_le_cancel_right2_hmset: "y \<le> 1 \<Longrightarrow> y * x \<le> x" for x y :: hmultiset
  by (subst mult.commute) (fact mult_le_cancel_left2_hmset)

lemma le_square_hmset: "m \<le> m * m" for m :: hmultiset
  using mult_le_cancel_left1_hmset by force

lemma le_cube_hmset: "m \<le> m * (m * m)" for m :: hmultiset
  using mult_le_cancel_left1_hmset by force

lemma
  less_imp_minus_plus_hmset: "m < n \<Longrightarrow> k < k - m + n" and
  le_imp_minus_plus_hmset: "m \<le> n \<Longrightarrow> k \<le> k - m + n" for k m n :: hmultiset
  by (meson add_less_cancel_left leD le_minus_plus_same_hmset less_le_trans not_le_imp_less)+

lemma gt_0_lt_mult_gt_1_hmset:
  fixes m n :: hmultiset
  assumes "m > 0" and "n > 1"
  shows "m < m * n"
  using assms by (metis mult.right_neutral mult_less_cancel1_hmset)

instance hmultiset :: linordered_comm_semiring_strict
  by intro_classes simp

subsection \<open>Embedding of Natural Numbers\<close>

lemma of_nat_inject_hmset[simp]: "(of_nat m :: hmultiset) = of_nat n \<longleftrightarrow> m = n"
  unfolding of_nat_hmset by simp

lemma of_nat_minus_hmset: "of_nat (m - n) = (of_nat m :: hmultiset) - of_nat n"
  unfolding of_nat_hmset minus_hmultiset_def by simp

lemma plus_of_nat_plus_of_nat_hmset:
  "k + of_nat m + of_nat n = k + of_nat (m + n)" for k :: hmultiset
  by simp

lemma plus_of_nat_minus_of_nat_hmset:
  fixes k :: hmultiset
  assumes "n \<le> m"
  shows "k + of_nat m - of_nat n = k + of_nat (m - n)"
  using assms by (metis add.left_commute add_diff_cancel_left' le_add_diff_inverse of_nat_add)

lemma of_nat_lt_\<omega>[simp]: "of_nat n < \<omega>"
  by (auto simp: of_nat_hmset zero_less_iff_neq_zero_hmset less_multiset_ext\<^sub>D\<^sub>M_less)

lemma of_nat_ne_\<omega>[simp]: "of_nat n \<noteq> \<omega>"
  by (simp add: neq_iff)

lemma of_nat_less_hmset[simp]: "(of_nat M :: hmultiset) < of_nat N \<longleftrightarrow> M < N"
  unfolding of_nat_hmset less_multiset_ext\<^sub>D\<^sub>M_less by simp

lemma of_nat_le_hmset[simp]: "(of_nat M :: hmultiset) \<le> of_nat N \<longleftrightarrow> M \<le> N"
  unfolding of_nat_hmset order_le_less less_multiset_ext\<^sub>D\<^sub>M_less by simp

lemma of_nat_times_\<omega>_exp: "of_nat n * \<omega>^m = HMSet (replicate_mset n m)"
  by (induct n) (simp_all add: hmsetmset_plus one_hmultiset_def)

lemma \<omega>_exp_times_of_nat: "\<omega>^m * of_nat n = HMSet (replicate_mset n m)"
  using of_nat_times_\<omega>_exp by simp

subsection \<open>Embedding of Extended Natural Numbers\<close>

primrec hmset_of_enat :: "enat \<Rightarrow> hmultiset" where
  "hmset_of_enat (enat n) = of_nat n"
| "hmset_of_enat \<infinity> = \<omega>"

lemma hmset_of_enat_0[simp]: "hmset_of_enat 0 = 0"
  by (simp add: zero_enat_def)

lemma hmset_of_enat_1[simp]: "hmset_of_enat 1 = 1"
  by (simp add: one_enat_def del: One_nat_def)

lemma hmset_of_enat_of_nat[simp]: "hmset_of_enat (of_nat n) = of_nat n"
  using of_nat_eq_enat by auto

lemma hmset_of_enat_numeral[simp]: "hmset_of_enat (numeral n) = numeral n"
  by (simp add: numeral_eq_enat)

lemma hmset_of_enat_le_\<omega>[simp]: "hmset_of_enat n \<le> \<omega>"
  using of_nat_lt_\<omega>[THEN less_imp_le] by (cases n) auto

lemma hmset_of_enat_eq_\<omega>_iff[simp]: "hmset_of_enat n = \<omega> \<longleftrightarrow> n = \<infinity>"
  by (cases n) auto

subsection \<open>Head Omega\<close>

definition head_\<omega> :: "hmultiset \<Rightarrow> hmultiset" where
  "head_\<omega> M = (if M = 0 then 0 else \<omega>^(Max (set_mset (hmsetmset M))))"

lemma head_\<omega>_subseteq: "hmsetmset (head_\<omega> M) \<subseteq># hmsetmset M"
  unfolding head_\<omega>_def by simp

lemma head_\<omega>_0[simp]: "head_\<omega> 0 = 0"
  by simp

lemma head_\<omega>_1[simp]: "head_\<omega> 1 = 1"
  unfolding head_\<omega>_def one_hmultiset_def by simp

lemma head_\<omega>_of_nat[simp]: "head_\<omega> (of_nat n) = (if n = 0 then 0 else 1)"
  unfolding head_\<omega>_def one_hmultiset_def of_nat_hmset by simp

lemma head_\<omega>_numeral[simp]: "head_\<omega> (numeral n) = 1"
  by (metis head_\<omega>_of_nat of_nat_numeral zero_neq_numeral)

lemma head_\<omega>_\<omega>[simp]: "head_\<omega> \<omega> = \<omega>"
  unfolding head_\<omega>_def by simp

lemma le_imp_head_\<omega>_le:
  assumes m_le_n: "m \<le> n"
  shows "head_\<omega> m \<le> head_\<omega> n"
proof -
  have le_in_le_max: "\<And>a M N. M \<le> N \<Longrightarrow> a \<in># M \<Longrightarrow> a \<le> Max (set_mset N)"
    by (metis (no_types) Max_ge finite_set_mset le_less less_eq_multiset\<^sub>H\<^sub>O linorder_not_less
      mem_Collect_eq neq0_conv order_trans set_mset_def)
  show ?thesis
    using m_le_n unfolding head_\<omega>_def
    by (cases m, cases n,
      auto simp del: hmsetmset_le simp: head_\<omega>_def hmsetmset_le[symmetric] zero_hmultiset_def,
      metis Max_in dual_order.antisym finite_set_mset le_in_le_max le_less set_mset_eq_empty_iff)
qed

lemma head_\<omega>_lt_imp_lt: "head_\<omega> m < head_\<omega> n \<Longrightarrow> m < n"
  unfolding head_\<omega>_def hmsetmset_less[symmetric]
  by (rule all_lt_Max_imp_lt_mset, auto simp: zero_hmultiset_def split: if_splits)

lemma head_\<omega>_plus[simp]: "head_\<omega> (m + n) = sup (head_\<omega> m) (head_\<omega> n)"
proof (cases m n rule: hmultiset.exhaust[case_product hmultiset.exhaust])
  case m_n: (HMSet_HMSet M N)
  show ?thesis
  proof (cases "Max_mset M < Max_mset N")
    case True
    thus ?thesis
      unfolding m_n head_\<omega>_def sup_hmultiset_def zero_hmultiset_def plus_hmultiset_def
      by (simp add: Max.union max_def dual_order.strict_implies_order)
  next
    case False
    thus ?thesis
      unfolding m_n head_\<omega>_def sup_hmultiset_def zero_hmultiset_def plus_hmultiset_def
      by simp (metis False Max.union finite_set_mset leI max_def set_mset_eq_empty_iff sup.commute)
  qed
qed

lemma head_\<omega>_times[simp]: "head_\<omega> (m * n) = head_\<omega> m * head_\<omega> n"
proof (cases "m = 0 \<or> n = 0")
  case False
  hence m_nz: "m \<noteq> 0" and n_nz: "n \<noteq> 0"
    by simp+

  define \<delta> where "\<delta> = hmsetmset m"
  define \<epsilon> where "\<epsilon> = hmsetmset n"

  have \<delta>_nemp: "\<delta> \<noteq> {#}"
    unfolding \<delta>_def using m_nz by simp
  have \<epsilon>_nemp: "\<epsilon> \<noteq> {#}"
    unfolding \<epsilon>_def using n_nz by simp

  let ?D = "set_mset \<delta>"
  let ?E = "set_mset \<epsilon>"
  let ?DE = "{z. \<exists>x \<in> ?D. \<exists>y \<in> ?E. z = x + y}"

  have max_D_in: "Max ?D \<in> ?D"
    using \<delta>_nemp by simp
  have max_E_in: "Max ?E \<in> ?E"
    using \<epsilon>_nemp by simp

  have "Max ?DE = Max ?D + Max ?E"
  proof (rule order_antisym, goal_cases le ge)
    case le
    have "\<And>x y. x \<in> ?D \<Longrightarrow> y \<in> ?E \<Longrightarrow> x + y \<le> Max ?D + Max ?E"
      by (simp add: add_mono)
    hence mem_imp_le: "\<And>z. z \<in> ?DE \<Longrightarrow> z \<le> Max ?D + Max ?E"
      by auto
    show ?case
      by (intro mem_imp_le Max_in, simp, use \<delta>_nemp \<epsilon>_nemp in fast)
  next
    case ge
    have "{z. \<exists>x \<in> {Max ?D}. \<exists>y \<in> {Max ?E}. z = x + y} \<subseteq> {z. \<exists>x \<in># \<delta>. \<exists>y \<in># \<epsilon>. z = x + y}"
      using max_D_in max_E_in by fast
    thus ?case
      by simp
  qed
  thus ?thesis
    unfolding \<delta>_def \<epsilon>_def by (auto simp: head_\<omega>_def image_def times_hmultiset_def)
qed auto

subsection \<open>More Inequalities and Some Equalities\<close>

lemma zero_lt_\<omega>[simp]: "0 < \<omega>"
  by (metis of_nat_lt_\<omega> of_nat_0)

lemma one_lt_\<omega>[simp]: "1 < \<omega>"
  by (metis enat_defs(2) hmset_of_enat.simps(1) hmset_of_enat_1 of_nat_lt_\<omega>)

lemma numeral_lt_\<omega>[simp]: "numeral n < \<omega>"
  using hmset_of_enat_numeral[symmetric] hmset_of_enat.simps(1) of_nat_lt_\<omega> numeral_eq_enat
  by presburger

lemma one_le_\<omega>[simp]: "1 \<le> \<omega>"
  by (simp add: less_imp_le)

lemma of_nat_le_\<omega>[simp]: "of_nat n \<le> \<omega>"
  by (simp add: le_less)

lemma numeral_le_\<omega>[simp]: "numeral n \<le> \<omega>"
  by (simp add: less_imp_le)

lemma not_\<omega>_lt_1[simp]: "\<not> \<omega> < 1"
  by (simp add: not_less)

lemma not_\<omega>_lt_of_nat[simp]: "\<not> \<omega> < of_nat n"
  by (simp add: not_less)

lemma not_\<omega>_lt_numeral[simp]: "\<not> \<omega> < numeral n"
  by (simp add: not_less)

lemma not_\<omega>_le_1[simp]: "\<not> \<omega> \<le> 1"
  by (simp add: not_le)

lemma not_\<omega>_le_of_nat[simp]: "\<not> \<omega> \<le> of_nat n"
  by (simp add: not_le)

lemma not_\<omega>_le_numeral[simp]: "\<not> \<omega> \<le> numeral n"
  by (simp add: not_le)

lemma zero_ne_\<omega>[simp]: "0 \<noteq> \<omega>"
  by (metis not_\<omega>_le_1 zero_le_hmset)

lemma one_ne_\<omega>[simp]: "1 \<noteq> \<omega>"
  using not_\<omega>_le_1 by force

lemma numeral_ne_\<omega>[simp]: "numeral n \<noteq> \<omega>"
  by (metis not_\<omega>_le_numeral numeral_le_\<omega>)

lemma
  \<omega>_ne_0[simp]: "\<omega> \<noteq> 0" and
  \<omega>_ne_1[simp]: "\<omega> \<noteq> 1" and
  \<omega>_ne_of_nat[simp]: "\<omega> \<noteq> of_nat m" and
  \<omega>_ne_numeral[simp]: "\<omega> \<noteq> numeral n"
  using zero_ne_\<omega> one_ne_\<omega> of_nat_ne_\<omega> numeral_ne_\<omega> by metis+

lemma
  hmset_of_enat_inject[simp]: "hmset_of_enat m = hmset_of_enat n \<longleftrightarrow> m = n" and
  hmset_of_enat_less[simp]: "hmset_of_enat m < hmset_of_enat n \<longleftrightarrow> m < n" and
  hmset_of_enat_le[simp]: "hmset_of_enat m \<le> hmset_of_enat n \<longleftrightarrow> m \<le> n"
  by (cases m; cases n; simp)+

lemma lt_\<omega>_imp_ex_of_nat:
  assumes M_lt_\<omega>: "M < \<omega>"
  shows "\<exists>n. M = of_nat n"
proof -
  have M_lt_single_1: "hmsetmset M < {#1#}"
    by (rule M_lt_\<omega>[unfolded hmsetmset_less[symmetric] less_multiset_ext\<^sub>D\<^sub>M_less hmultiset.sel])

  have "N = 0" if "N \<in># hmsetmset M" for N
  proof -
    have "0 < count (hmsetmset M) N"
      using that by auto
    hence "N < 1"
      by (metis (no_types) M_lt_single_1 count_single gr_implies_not0 less_eq_multiset\<^sub>H\<^sub>O less_one
        neq_iff not_le)
    thus ?thesis
      by (simp add: lt_1_iff_eq_0_hmset)
  qed
  then obtain n where hmmM: "M = HMSet (replicate_mset n 0)"
    using ex_replicate_mset_if_all_elems_eq by (metis hmultiset.collapse)
  show ?thesis
    unfolding hmmM of_nat_hmset by blast
qed

lemma le_\<omega>_imp_ex_hmset_of_enat:
  assumes M_le_\<omega>: "M \<le> \<omega>"
  shows "\<exists>n. M = hmset_of_enat n"
proof (cases "M = \<omega>")
  case True
  thus ?thesis
    by (metis hmset_of_enat.simps(2))
next
  case False
  thus ?thesis
    using M_le_\<omega> lt_\<omega>_imp_ex_of_nat by (metis hmset_of_enat.simps(1) le_less)
qed

lemma lt_\<omega>_lt_\<omega>_imp_times_lt_\<omega>: "M < \<omega> \<Longrightarrow> N < \<omega> \<Longrightarrow> M * N < \<omega>"
  by (metis lt_\<omega>_imp_ex_of_nat of_nat_lt_\<omega> of_nat_mult)

lemma times_\<omega>_minus_of_nat[simp]: "m * \<omega> - of_nat n = m * \<omega>"
  by (auto intro!: Diff_triv_mset simp: times_hmultiset_def minus_hmultiset_def
    Times_mset_single_right of_nat_hmset disjunct_not_in image_def)

lemma times_\<omega>_minus_numeral[simp]: "m * \<omega> - numeral n = m * \<omega>"
  by (metis of_nat_numeral times_\<omega>_minus_of_nat)

lemma \<omega>_minus_of_nat[simp]: "\<omega> - of_nat n = \<omega>"
  using times_\<omega>_minus_of_nat[of 1] by (metis mult.left_neutral)

lemma \<omega>_minus_1[simp]: "\<omega> - 1 = \<omega>"
  using \<omega>_minus_of_nat[of 1] by simp

lemma \<omega>_minus_numeral[simp]: "\<omega> - numeral n = \<omega>"
  using times_\<omega>_minus_numeral[of 1] by (metis mult.left_neutral)

lemma hmset_of_enat_minus_enat[simp]: "hmset_of_enat (m - enat n) = hmset_of_enat m - of_nat n"
  by (cases m) (auto simp: of_nat_minus_hmset)

lemma of_nat_lt_hmset_of_enat_iff: "of_nat m < hmset_of_enat n \<longleftrightarrow> enat m < n"
  by (metis hmset_of_enat.simps(1) hmset_of_enat_less)

lemma of_nat_le_hmset_of_enat_iff: "of_nat m \<le> hmset_of_enat n \<longleftrightarrow> enat m \<le> n"
  by (metis hmset_of_enat.simps(1) hmset_of_enat_le)

lemma hmset_of_enat_lt_iff_ne_infinity: "hmset_of_enat x < \<omega> \<longleftrightarrow> x \<noteq> \<infinity>"
  by (cases x; simp)

lemma minus_diff_sym_hmset: "m - (m - n) = n - (n - m)" for m n :: hmultiset
  unfolding minus_hmultiset_def by simp (metis multiset_inter_def subset_mset.inf_aci(1))

lemma diff_plus_sym_hmset: "(c - b) + b = (b - c) + c" for b c :: hmultiset
proof -
  have f1: "\<And>h ha :: hmultiset. h - (ha + h) = 0"
    by (simp add: add.commute)
  have f2: "\<And>h ha hb :: hmultiset. h + ha - (h - hb) = hb + ha - (hb - h)"
    by (metis (no_types) add_diff_cancel_right minus_diff_sym_hmset)
  have "\<And>h ha hb :: hmultiset. h + (ha + hb) - hb = h + ha"
    by (metis (no_types) add.assoc add_diff_cancel_right')
  then show ?thesis
    using f2 f1 by (metis (no_types) add.commute add.right_neutral diff_diff_add_hmset)
qed

lemma times_diff_plus_sym_hmset: "a * (c - b) + a * b = a * (b - c) + a * c" for a b c :: hmultiset
  by (metis distrib_left diff_plus_sym_hmset)

lemma times_of_nat_minus_left:
  "(of_nat m - of_nat n) * l = of_nat m * l - of_nat n * l" for l :: hmultiset
  by (induct n m rule: diff_induct) (auto simp: ring_distribs)

lemma times_of_nat_minus_right:
  "l * (of_nat m - of_nat n) = l * of_nat m - l * of_nat n" for l :: hmultiset
  by (metis times_of_nat_minus_left mult.commute)

lemma lt_\<omega>_imp_times_minus_left: "m < \<omega> \<Longrightarrow> n < \<omega> \<Longrightarrow> (m - n) * l = m * l - n * l"
  by (metis lt_\<omega>_imp_ex_of_nat times_of_nat_minus_left)

lemma lt_\<omega>_imp_times_minus_right: "m < \<omega> \<Longrightarrow> n < \<omega> \<Longrightarrow> l * (m - n) = l * m - l * n"
  by (metis lt_\<omega>_imp_ex_of_nat times_of_nat_minus_right)

lemma hmset_pair_decompose:
  "\<exists>k n1 n2. m1 = k + n1 \<and> m2 = k + n2 \<and> (head_\<omega> n1 \<noteq> head_\<omega> n2 \<or> n1 = 0 \<and> n2 = 0)"
proof -
  define n1 where n1: "n1 = m1 - m2"
  define n2 where n2: "n2 = m2 - m1"
  define k where k1: "k = m1 - n1"

  have k2: "k = m2 - n2"
    using k1 unfolding n1 n2 by (simp add: minus_diff_sym_hmset)

  have "m1 = k + n1"
    unfolding k1
    by (metis (no_types) n1 add_diff_cancel_left add.commute add_diff_cancel_right' diff_add_zero
      diff_diff_add minus_diff_sym_hmset)
  moreover have "m2 = k + n2"
    unfolding k2
    by (metis n2 add.commute add_diff_cancel_left add_diff_cancel_left' add_diff_cancel_right'
      diff_add_zero diff_diff_add diff_zero k2 minus_diff_sym_hmset)
  moreover have hd_n: "head_\<omega> n1 \<noteq> head_\<omega> n2" if n1_or_n2_nz: "n1 \<noteq> 0 \<or> n2 \<noteq> 0"
  proof (cases "n1 = 0" "n2 = 0" rule: bool.exhaust[case_product bool.exhaust])
    case False_False
    note n1_nz = this(1)[simplified] and n2_nz = this(2)[simplified]

    define \<delta>1 where "\<delta>1 = hmsetmset n1"
    define \<delta>2 where "\<delta>2 = hmsetmset n2"

    have \<delta>1_inter_\<delta>2: "\<delta>1 \<inter># \<delta>2 = {#}"
      unfolding \<delta>1_def \<delta>2_def n1 n2 minus_hmultiset_def by (simp add: diff_intersect_sym_diff)

    have \<delta>1_ne: "\<delta>1 \<noteq> {#}"
      unfolding \<delta>1_def using n1_nz by simp
    have \<delta>2_ne: "\<delta>2 \<noteq> {#}"
      unfolding \<delta>2_def using n2_nz by simp

    have max_\<delta>1: "Max (set_mset \<delta>1) \<in># \<delta>1"
      using \<delta>1_ne by simp
    have max_\<delta>2: "Max (set_mset \<delta>2) \<in># \<delta>2"
      using \<delta>2_ne by simp
    have max_\<delta>1_ne_\<delta>2: "Max (set_mset \<delta>1) \<noteq> Max (set_mset \<delta>2)"
      using \<delta>1_inter_\<delta>2 disjunct_not_in max_\<delta>1 max_\<delta>2 by force

    show ?thesis
      using n1_nz n2_nz
      by (cases n1 rule: hmultiset.exhaust_sel, cases n2 rule: hmultiset.exhaust_sel,
        auto simp: head_\<omega>_def zero_hmultiset_def max_\<delta>1_ne_\<delta>2[unfolded \<delta>1_def \<delta>2_def])
  qed (use n1_or_n2_nz in \<open>auto simp: head_\<omega>_def\<close>)
  ultimately show ?thesis
    by blast
qed

lemma hmset_pair_decompose_less:
  assumes m1_lt_m2: "m1 < m2"
  shows "\<exists>k n1 n2. m1 = k + n1 \<and> m2 = k + n2 \<and> head_\<omega> n1 < head_\<omega> n2"
proof -
  obtain k n1 n2 where
    m1: "m1 = k + n1" and
    m2: "m2 = k + n2" and
    hds: "head_\<omega> n1 \<noteq> head_\<omega> n2 \<or> n1 = 0 \<and> n2 = 0"
    using hmset_pair_decompose[of m1 m2] by blast

  {
    assume "n1 = 0" and "n2 = 0"
    hence "m1 = m2"
      unfolding m1 m2 by simp
    hence False
      using m1_lt_m2 by simp
  }
  moreover
  {
    assume "head_\<omega> n1 > head_\<omega> n2"
    hence "n1 > n2"
      by (rule head_\<omega>_lt_imp_lt)
    hence "m1 > m2"
      unfolding m1 m2 by simp
    hence False
      using m1_lt_m2 by simp
  }
  ultimately show ?thesis
    using m1 m2 hds by (blast elim: neqE)
qed

lemma hmset_pair_decompose_less_eq:
  assumes "m1 \<le> m2"
  shows "\<exists>k n1 n2. m1 = k + n1 \<and> m2 = k + n2 \<and> (head_\<omega> n1 < head_\<omega> n2 \<or> n1 = 0 \<and> n2 = 0)"
  using assms
  by (metis add_cancel_right_right hmset_pair_decompose_less order.not_eq_order_implies_strict)

lemma mono_cross_mult_less_hmset:
  fixes Aa A Ba B :: hmultiset
  assumes A_lt: "A < Aa" and B_lt: "B < Ba"
  shows "A * Ba + B * Aa < A * B + Aa * Ba"
proof -
  obtain j m1 m2 where A: "A = j + m1" and Aa: "Aa = j + m2" and hd_m: "head_\<omega> m1 < head_\<omega> m2"
    by (metis hmset_pair_decompose_less[OF A_lt])
  obtain k n1 n2 where B: "B = k + n1" and Ba: "Ba = k + n2" and hd_n: "head_\<omega> n1 < head_\<omega> n2"
    by (metis hmset_pair_decompose_less[OF B_lt])

  have hd_lt: "head_\<omega> (m1 * n2 + m2 * n1) < head_\<omega> (m1 * n1 + m2 * n2)"
  proof simp
    have "\<And>h ha :: hmultiset. 0 < h \<or> \<not> ha < h"
      by force
    hence "\<not> head_\<omega> m2 * head_\<omega> n2 \<le> sup (head_\<omega> m1 * head_\<omega> n2) (head_\<omega> m2 * head_\<omega> n1)"
      using hd_m hd_n sup_hmultiset_def by auto
    thus "sup (head_\<omega> m1 * head_\<omega> n2) (head_\<omega> m2 * head_\<omega> n1)
      < sup (head_\<omega> m1 * head_\<omega> n1) (head_\<omega> m2 * head_\<omega> n2)"
      by (meson leI sup.bounded_iff)
  qed
  show ?thesis
    unfolding A Aa B Ba ring_distribs by (simp add: algebra_simps head_\<omega>_lt_imp_lt[OF hd_lt])
qed

lemma triple_cross_mult_hmset:
  "An * (Bn * Cn + Bp * Cp - (Bn * Cp + Cn * Bp))
   + (Cn * (An * Bp + Bn * Ap - (An * Bn + Ap * Bp))
      + (Ap * (Bn * Cp + Cn * Bp - (Bn * Cn + Bp * Cp))
         + Cp * (An * Bn + Ap * Bp - (An * Bp + Bn * Ap)))) =
   An * (Bn * Cp + Cn * Bp - (Bn * Cn + Bp * Cp))
   + (Cn * (An * Bn + Ap * Bp - (An * Bp + Bn * Ap))
      + (Ap * (Bn * Cn + Bp * Cp - (Bn * Cp + Cn * Bp))
         + Cp * (An * Bp + Bn * Ap - (An * Bn + Ap * Bp))))"
  for Ap An Bp Bn Cp Cn Dp Dn :: hmultiset
  apply (simp add: algebra_simps)
  apply (unfold add.assoc[symmetric])

  apply (rule add_right_cancel[THEN iffD1, of _ "Cp * (An * Bp + Ap * Bn)"])
  apply (unfold add.assoc)
  apply (subst times_diff_plus_sym_hmset)
  apply (unfold add.assoc[symmetric])
  apply (subst (12) add.commute)
  apply (subst (11) add.commute)
  apply (unfold add.assoc[symmetric])

  apply (rule add_right_cancel[THEN iffD1, of _ "Cn * (An * Bn + Ap * Bp)"])
  apply (unfold add.assoc)
  apply (subst times_diff_plus_sym_hmset)
  apply (unfold add.assoc[symmetric])
  apply (subst (14) add.commute)
  apply (subst (13) add.commute)
  apply (unfold add.assoc[symmetric])

  apply (rule add_right_cancel[THEN iffD1, of _ "Ap * (Bn * Cn + Bp * Cp)"])
  apply (unfold add.assoc)
  apply (subst times_diff_plus_sym_hmset)
  apply (unfold add.assoc[symmetric])
  apply (subst (16) add.commute)
  apply (subst (15) add.commute)
  apply (unfold add.assoc[symmetric])

  apply (rule add_right_cancel[THEN iffD1, of _ "An * (Bn * Cp + Bp * Cn)"])
  apply (unfold add.assoc)
  apply (subst times_diff_plus_sym_hmset)
  apply (unfold add.assoc[symmetric])
  apply (subst (18) add.commute)
  apply (subst (17) add.commute)
  apply (unfold add.assoc[symmetric])

  by (simp add: algebra_simps)

subsection \<open>Conversions to Natural Numbers\<close>

definition offset_hmset :: "hmultiset \<Rightarrow> nat" where
  "offset_hmset M = count (hmsetmset M) 0"

lemma offset_hmset_of_nat[simp]: "offset_hmset (of_nat n) = n"
  unfolding offset_hmset_def of_nat_hmset by simp

lemma offset_hmset_numeral[simp]: "offset_hmset (numeral n) = numeral n"
  unfolding offset_hmset_def by (metis offset_hmset_def offset_hmset_of_nat of_nat_numeral)

definition sum_coefs :: "hmultiset \<Rightarrow> nat" where
  "sum_coefs M = size (hmsetmset M)"

lemma sum_coefs_distrib_plus[simp]: "sum_coefs (M + N) = sum_coefs M + sum_coefs N"
  unfolding plus_hmultiset_def sum_coefs_def by simp

lemma sum_coefs_gt_0: "sum_coefs M > 0 \<longleftrightarrow> M > 0"
  by (auto simp: sum_coefs_def zero_hmultiset_def hmsetmset_less[symmetric] less_multiset_ext\<^sub>D\<^sub>M_less
    nonempty_has_size[symmetric])

subsection \<open>An Example\<close>

text \<open>
The following proof is based on an informal proof by Uwe Waldmann, inspired by
a similar argument by Michel Ludwig.
\<close>

lemma ludwig_waldmann_less:
  fixes \<alpha>1 \<alpha>2 \<beta>1 \<beta>2 \<gamma> \<delta> :: hmultiset
  assumes
    \<alpha>\<beta>2\<gamma>_lt_\<alpha>\<beta>1\<gamma>: "\<alpha>2 + \<beta>2 * \<gamma> < \<alpha>1 + \<beta>1 * \<gamma>" and
    \<beta>2_le_\<beta>1: "\<beta>2 \<le> \<beta>1" and
    \<gamma>_lt_\<delta>: "\<gamma> < \<delta>"
  shows "\<alpha>2 + \<beta>2 * \<delta> < \<alpha>1 + \<beta>1 * \<delta>"
proof -
  obtain \<beta>0 \<beta>2a \<beta>1a where
    \<beta>1: "\<beta>1 = \<beta>0 + \<beta>1a" and
    \<beta>2: "\<beta>2 = \<beta>0 + \<beta>2a" and
    hd_\<beta>2a_vs_\<beta>1a: "head_\<omega> \<beta>2a < head_\<omega> \<beta>1a \<or> \<beta>2a = 0 \<and> \<beta>1a = 0"
    using hmset_pair_decompose_less_eq[OF \<beta>2_le_\<beta>1] by blast

  obtain \<eta> \<gamma>a \<delta>a where
    \<gamma>: "\<gamma> = \<eta> + \<gamma>a" and
    \<delta>: "\<delta> = \<eta> + \<delta>a" and
    hd_\<gamma>a_lt_\<delta>a: "head_\<omega> \<gamma>a < head_\<omega> \<delta>a"
    using hmset_pair_decompose_less[OF \<gamma>_lt_\<delta>] by blast

  have "\<alpha>2 + \<beta>0 * \<gamma> + \<beta>2a * \<gamma> = \<alpha>2 + \<beta>2 * \<gamma>"
    unfolding \<beta>2 by (simp add: add.commute add.left_commute distrib_left mult.commute)
  also have "\<dots> < \<alpha>1 + \<beta>1 * \<gamma>"
    by (rule \<alpha>\<beta>2\<gamma>_lt_\<alpha>\<beta>1\<gamma>)
  also have "\<dots> = \<alpha>1 + \<beta>0 * \<gamma> + \<beta>1a * \<gamma>"
    unfolding \<beta>1 by (simp add: add.commute add.left_commute distrib_left mult.commute)
  finally have *: "\<alpha>2 + \<beta>2a * \<gamma> < \<alpha>1 + \<beta>1a * \<gamma>"
    by (metis add_less_cancel_right semiring_normalization_rules(23))

  have "\<alpha>2 + \<beta>2 * \<delta> = \<alpha>2 + \<beta>0 * \<delta> + \<beta>2a * \<delta>"
    unfolding \<beta>2 by (simp add: ab_semigroup_add_class.add_ac(1) distrib_right)
  also have "\<dots> = \<alpha>2 + \<beta>0 * \<delta> + \<beta>2a * \<eta> + \<beta>2a * \<delta>a"
    unfolding \<delta> by (simp add: distrib_left semiring_normalization_rules(25))
  also have "\<dots> \<le> \<alpha>2 + \<beta>0 * \<delta> + \<beta>2a * \<eta> + \<beta>2a * \<delta>a + \<beta>2a * \<gamma>a"
    by simp
  also have "\<dots> = \<alpha>2 + \<beta>2a * \<gamma> + \<beta>0 * \<delta> + \<beta>2a * \<delta>a"
    unfolding \<gamma> distrib_left add.assoc[symmetric] by (simp add: semiring_normalization_rules(23))
  also have "\<dots> < \<alpha>1 + \<beta>1a * \<gamma> + \<beta>0 * \<delta> + \<beta>2a * \<delta>a"
    using * by simp
  also have "\<dots> = \<alpha>1 + \<beta>1a * \<eta> + \<beta>1a * \<gamma>a + \<beta>0 * \<eta> + \<beta>0 * \<delta>a + \<beta>2a * \<delta>a"
    unfolding \<gamma> \<delta> distrib_left add.assoc[symmetric] by (rule refl)
  also have "\<dots> \<le> \<alpha>1 + \<beta>1a * \<eta> + \<beta>0 * \<eta> + \<beta>0 * \<delta>a + \<beta>1a * \<delta>a"
  proof -
    have "\<beta>1a * \<gamma>a + \<beta>2a * \<delta>a \<le> \<beta>1a * \<delta>a"
    proof (cases "\<beta>2a = 0 \<and> \<beta>1a = 0")
      case False
      hence "head_\<omega> \<beta>2a < head_\<omega> \<beta>1a"
        using hd_\<beta>2a_vs_\<beta>1a by blast
      hence "head_\<omega> (\<beta>1a * \<gamma>a + \<beta>2a * \<delta>a) < head_\<omega> (\<beta>1a * \<delta>a)"
        using hd_\<gamma>a_lt_\<delta>a by (auto intro: gr_zeroI_hmset simp: sup_hmultiset_def)
      hence "\<beta>1a * \<gamma>a + \<beta>2a * \<delta>a < \<beta>1a * \<delta>a"
        by (rule head_\<omega>_lt_imp_lt)
      thus ?thesis
        by simp
    qed simp
    thus ?thesis
      by simp
  qed
  finally show ?thesis
    unfolding \<beta>1 \<delta>
    by (simp add: distrib_left distrib_right add.assoc[symmetric] semiring_normalization_rules(23))
qed

end