(* Title:      Lattice Basics
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Lattice Basics\<close>

text \<open>
This theory provides notations, basic definitions and facts of lattice-related structures used throughout the subsequent development.
\<close>

theory Lattice_Basics

imports Main

begin

subsection \<open>General Facts and Notations\<close>

text \<open>
The following results extend basic Isabelle/HOL facts.
\<close>

lemma imp_as_conj:
  assumes "P x \<Longrightarrow> Q x"
  shows "P x \<and> Q x \<longleftrightarrow> P x"
  using assms by auto

lemma if_distrib_2:
  "f (if c then x else y) (if c then z else w) = (if c then f x z else f y w)"
  by simp

lemma left_invertible_inj:
  "(\<forall>x . g (f x) = x) \<Longrightarrow> inj f"
  by (metis injI)

lemma invertible_bij:
  assumes "\<forall>x . g (f x) = x"
      and "\<forall>y . f (g y) = y"
    shows "bij f"
  by (metis assms bijI')

lemma finite_ne_subset_induct [consumes 3, case_names singleton insert]:
  assumes "finite F"
      and "F \<noteq> {}"
      and "F \<subseteq> S"
      and singleton: "\<And>x . P {x}"
      and insert: "\<And>x F . finite F \<Longrightarrow> F \<noteq> {} \<Longrightarrow> F \<subseteq> S \<Longrightarrow> x \<in> S \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
    shows "P F"
  using assms(1-3)
  apply (induct rule: finite_ne_induct)
  apply (simp add: singleton)
  by (simp add: insert)

lemma finite_set_of_finite_funs_pred:
  assumes "finite { x::'a . True }"
      and "finite { y::'b . P y }"
    shows "finite { f . (\<forall>x::'a . P (f x)) }"
  using assms finite_set_of_finite_funs by force

text \<open>
We use the following notations for the join, meet and complement operations.
Changing the precedence of the unary complement allows us to write terms like \<open>--x\<close> instead of \<open>-(-x)\<close>.
\<close>

context sup
begin

notation sup (infixl "\<squnion>" 65)

definition additive :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "additive f \<equiv> \<forall>x y . f (x \<squnion> y) = f x \<squnion> f y"

end

context inf
begin

notation inf (infixl "\<sqinter>" 67)

end

context uminus
begin

no_notation uminus ("- _" [81] 80)

notation uminus ("- _" [80] 80)

end

subsection \<open>Orders\<close>

text \<open>
We use the following definition of monotonicity for operations defined in classes.
The standard \<open>mono\<close> places a sort constraint on the target type.
We also give basic properties of Galois connections and lift orders to functions.
\<close>

context ord
begin

definition isotone :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "isotone f \<equiv> \<forall>x y . x \<le> y \<longrightarrow> f x \<le> f y"

definition galois :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "galois l u \<equiv> \<forall>x y . l x \<le> y \<longleftrightarrow> x \<le> u y"

definition lifted_less_eq :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("(_ \<le>\<le> _)" [51, 51] 50)
  where "f \<le>\<le> g \<equiv> \<forall>x . f x \<le> g x"

end

context order
begin

lemma order_lesseq_imp:
  "(\<forall>z . x \<le> z \<longrightarrow> y \<le> z) \<longleftrightarrow> y \<le> x"
  using order_trans by blast

lemma galois_char:
  "galois l u \<longleftrightarrow> (\<forall>x . x \<le> u (l x)) \<and> (\<forall>x . l (u x) \<le> x) \<and> isotone l \<and> isotone u"
  apply (rule iffI)
  apply (metis (full_types) galois_def isotone_def order_refl order_trans)
  using galois_def isotone_def order_trans by blast

lemma galois_closure:
  "galois l u \<Longrightarrow> l x = l (u (l x)) \<and> u x = u (l (u x))"
  by (simp add: galois_char isotone_def antisym)

lemma lifted_reflexive:
  "f = g \<Longrightarrow> f \<le>\<le> g"
  by (simp add: lifted_less_eq_def)

lemma lifted_transitive:
  "f \<le>\<le> g \<Longrightarrow> g \<le>\<le> h \<Longrightarrow> f \<le>\<le> h"
  using lifted_less_eq_def order_trans by blast

lemma lifted_antisymmetric:
  "f \<le>\<le> g \<Longrightarrow> g \<le>\<le> f \<Longrightarrow> f = g"
  by (metis (full_types) antisym ext lifted_less_eq_def)

text \<open>
If the image of a finite non-empty set under \<open>f\<close> is a totally ordered, there is an element that minimises the value of \<open>f\<close>.
\<close>

lemma finite_set_minimal:
  assumes "finite s"
      and "s \<noteq> {}"
      and "\<forall>x\<in>s . \<forall>y\<in>s . f x \<le> f y \<or> f y \<le> f x"
    shows "\<exists>m\<in>s . \<forall>z\<in>s . f m \<le> f z"
  apply (rule finite_ne_subset_induct[where S=s])
  apply (rule assms(1))
  apply (rule assms(2))
  apply simp
  apply simp
  by (metis assms(3) insert_iff order_trans subsetD)

end

subsection \<open>Semilattices\<close>

text \<open>
The following are basic facts in semilattices.
\<close>

context semilattice_sup
begin

lemma sup_left_isotone:
  "x \<le> y \<Longrightarrow> x \<squnion> z \<le> y \<squnion> z"
  using sup.mono by blast

lemma sup_right_isotone:
  "x \<le> y \<Longrightarrow> z \<squnion> x \<le> z \<squnion> y"
  using sup.mono by blast

lemma sup_left_divisibility:
  "x \<le> y \<longleftrightarrow> (\<exists>z . x \<squnion> z = y)"
  using sup.absorb2 sup.cobounded1 by blast

lemma sup_right_divisibility:
  "x \<le> y \<longleftrightarrow> (\<exists>z . z \<squnion> x = y)"
  by (metis sup.cobounded2 sup.orderE)

lemma sup_same_context:
  "x \<le> y \<squnion> z \<Longrightarrow> y \<le> x \<squnion> z \<Longrightarrow> x \<squnion> z = y \<squnion> z"
  by (simp add: le_iff_sup sup_left_commute)

lemma sup_relative_same_increasing:
  "x \<le> y \<Longrightarrow> x \<squnion> z = x \<squnion> w \<Longrightarrow> y \<squnion> z = y \<squnion> w"
  using sup.assoc sup_right_divisibility by auto

end

text \<open>
Every bounded semilattice is a commutative monoid.
Finite sums defined in commutative monoids are available via the following sublocale.
\<close>

context bounded_semilattice_sup_bot
begin

sublocale sup_monoid: comm_monoid_add where plus = sup and zero = bot
  apply unfold_locales
  apply (simp add: sup_assoc)
  apply (simp add: sup_commute)
  by simp

end

context semilattice_inf
begin

lemma inf_same_context:
  "x \<le> y \<sqinter> z \<Longrightarrow> y \<le> x \<sqinter> z \<Longrightarrow> x \<sqinter> z = y \<sqinter> z"
  using antisym by auto

end

text \<open>
The following class requires only the existence of upper bounds, which is a property common to bounded semilattices and (not necessarily bounded) lattices.
We use it in our development of filters.
\<close>

class directed_semilattice_inf = semilattice_inf +
  assumes ub: "\<exists>z . x \<le> z \<and> y \<le> z"

text \<open>
We extend the \<open>inf\<close> sublocale, which dualises the order in semilattices, to bounded semilattices.
\<close>

context bounded_semilattice_inf_top
begin

subclass directed_semilattice_inf
  apply unfold_locales
  using top_greatest by blast

sublocale inf: bounded_semilattice_sup_bot where sup = inf and less_eq = greater_eq and less = greater and bot = top
  by unfold_locales (simp_all add: less_le_not_le)

end

subsection \<open>Lattices\<close>

context lattice
begin

subclass directed_semilattice_inf
  apply unfold_locales
  using sup_ge1 sup_ge2 by blast

definition dual_additive :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "dual_additive f \<equiv> \<forall>x y . f (x \<squnion> y) = f x \<sqinter> f y"

end

text \<open>
Not every bounded lattice has complements, but two elements might still be complements of each other as captured in the following definition.
In this situation we can apply, for example, the shunting property shown below.
We introduce most definitions using the \<open>abbreviation\<close> command.
\<close>

context bounded_lattice
begin

abbreviation "complement x y \<equiv> x \<squnion> y = top \<and> x \<sqinter> y = bot"

lemma complement_symmetric:
  "complement x y \<Longrightarrow> complement y x"
  by (simp add: inf.commute sup.commute)

definition conjugate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "conjugate f g \<equiv> \<forall>x y . f x \<sqinter> y = bot \<longleftrightarrow> x \<sqinter> g y = bot"

end

class dense_lattice = bounded_lattice +
  assumes bot_meet_irreducible: "x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot"

context distrib_lattice
begin

lemma relative_equality:
  "x \<squnion> z = y \<squnion> z \<Longrightarrow> x \<sqinter> z = y \<sqinter> z \<Longrightarrow> x = y"
  by (metis inf.commute inf_sup_absorb inf_sup_distrib2)

end

text \<open>
Distributive lattices with a greatest element are widely used in the construction theorem for Stone algebras.
\<close>

class distrib_lattice_bot = bounded_lattice_bot + distrib_lattice

class distrib_lattice_top = bounded_lattice_top + distrib_lattice

class bounded_distrib_lattice = bounded_lattice + distrib_lattice
begin

subclass distrib_lattice_bot ..

subclass distrib_lattice_top ..

lemma complement_shunting:
  assumes "complement z w"
    shows "z \<sqinter> x \<le> y \<longleftrightarrow> x \<le> w \<squnion> y"
proof
  assume 1: "z \<sqinter> x \<le> y"
  have "x = (z \<squnion> w) \<sqinter> x"
    by (simp add: assms)
  also have "... \<le> y \<squnion> (w \<sqinter> x)"
    using 1 sup.commute sup.left_commute inf_sup_distrib2 sup_right_divisibility by fastforce
  also have "... \<le> w \<squnion> y"
    by (simp add: inf.coboundedI1)
  finally show "x \<le> w \<squnion> y"
    .
next
  assume "x \<le> w \<squnion> y"
  hence "z \<sqinter> x \<le> z \<sqinter> (w \<squnion> y)"
    using inf.sup_right_isotone by auto
  also have "... = z \<sqinter> y"
    by (simp add: assms inf_sup_distrib1)
  also have "... \<le> y"
    by simp
  finally show "z \<sqinter> x \<le> y"
    .
qed

end

subsection \<open>Linear Orders\<close>

text \<open>
We next consider lattices with a linear order structure.
In such lattices, join and meet are selective operations, which give the maximum and the minimum of two elements, respectively.
Moreover, the lattice is automatically distributive.
\<close>

class bounded_linorder = linorder + order_bot + order_top

class linear_lattice = lattice + linorder
begin

lemma max_sup:
  "max x y = x \<squnion> y"
  by (metis max.boundedI max.cobounded1 max.cobounded2 sup_unique)

lemma min_inf:
  "min x y = x \<sqinter> y"
  by (simp add: inf.absorb1 inf.absorb2 min_def)

lemma sup_inf_selective:
  "(x \<squnion> y = x \<and> x \<sqinter> y = y) \<or> (x \<squnion> y = y \<and> x \<sqinter> y = x)"
  by (meson inf.absorb1 inf.absorb2 le_cases sup.absorb1 sup.absorb2)

lemma sup_selective:
  "x \<squnion> y = x \<or> x \<squnion> y = y"
  using sup_inf_selective by blast

lemma inf_selective:
  "x \<sqinter> y = x \<or> x \<sqinter> y = y"
  using sup_inf_selective by blast

subclass distrib_lattice
  apply unfold_locales
  by (metis inf_selective antisym distrib_sup_le inf.commute inf_le2)

lemma sup_less_eq:
  "x \<le> y \<squnion> z \<longleftrightarrow> x \<le> y \<or> x \<le> z"
  by (metis le_supI1 le_supI2 sup_selective)

lemma inf_less_eq:
  "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<or> y \<le> z"
  by (metis inf.coboundedI1 inf.coboundedI2 inf_selective)

lemma sup_inf_sup:
  "x \<squnion> y = (x \<squnion> y) \<squnion> (x \<sqinter> y)"
  by (metis sup_commute sup_inf_absorb sup_left_commute)

end

text \<open>
The following class derives additional properties if the linear order of the lattice has a least and a greatest element.
\<close>

class linear_bounded_lattice = bounded_lattice + linorder
begin

subclass linear_lattice ..

subclass bounded_linorder ..

subclass bounded_distrib_lattice ..

lemma sup_dense:
  "x \<noteq> top \<Longrightarrow> y \<noteq> top \<Longrightarrow> x \<squnion> y \<noteq> top"
  by (metis sup_selective)

lemma inf_dense:
  "x \<noteq> bot \<Longrightarrow> y \<noteq> bot \<Longrightarrow> x \<sqinter> y \<noteq> bot"
  by (metis inf_selective)

lemma sup_not_bot:
  "x \<noteq> bot \<Longrightarrow> x \<squnion> y \<noteq> bot"
  by simp

lemma inf_not_top:
  "x \<noteq> top \<Longrightarrow> x \<sqinter> y \<noteq> top"
  by simp

subclass dense_lattice
  apply unfold_locales
  using inf_dense by blast

end

text \<open>
Every bounded linear order can be expanded to a bounded lattice.
Join and meet are maximum and minimum, respectively.
\<close>

class linorder_lattice_expansion = bounded_linorder + sup + inf +
  assumes sup_def [simp]: "x \<squnion> y = max x y"
  assumes inf_def [simp]: "x \<sqinter> y = min x y"
begin

subclass linear_bounded_lattice
  apply unfold_locales
  by auto

end

subsection \<open>Non-trivial Algebras\<close>

text \<open>
Some results, such as the existence of certain filters, require that the algebras are not trivial.
This is not an assumption of the order and lattice classes that come with Isabelle/HOL; for example, \<open>bot = top\<close> may hold in bounded lattices.
\<close>

class non_trivial =
  assumes consistent: "\<exists>x y . x \<noteq> y"

class non_trivial_order = non_trivial + order

class non_trivial_order_bot = non_trivial_order + order_bot

class non_trivial_bounded_order = non_trivial_order_bot + order_top
begin

lemma bot_not_top:
  "bot \<noteq> top"
proof -
  from consistent obtain x y :: 'a where "x \<noteq> y"
    by auto
  thus ?thesis
    by (metis bot_less top.extremum_strict)
qed

end

subsection \<open>Homomorphisms\<close>

text \<open>
This section gives definitions of lattice homomorphisms and isomorphisms and basic properties.
\<close>

class sup_inf_top_bot_uminus = sup + inf + top + bot + uminus
class sup_inf_top_bot_uminus_ord = sup_inf_top_bot_uminus + ord

context boolean_algebra
begin

subclass sup_inf_top_bot_uminus_ord .

end

abbreviation sup_homomorphism :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool"
  where "sup_homomorphism f \<equiv> \<forall>x y . f (x \<squnion> y) = f x \<squnion> f y"

abbreviation inf_homomorphism :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool"
  where "inf_homomorphism f \<equiv> \<forall>x y . f (x \<sqinter> y) = f x \<sqinter> f y"

abbreviation bot_homomorphism :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool"
  where "bot_homomorphism f \<equiv> f bot = bot"

abbreviation top_homomorphism :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool"
  where "top_homomorphism f \<equiv> f top = top"

abbreviation minus_homomorphism :: "('a::minus \<Rightarrow> 'b::minus) \<Rightarrow> bool"
  where "minus_homomorphism f \<equiv> \<forall>x y . f (x - y) = f x - f y"

abbreviation uminus_homomorphism :: "('a::uminus \<Rightarrow> 'b::uminus) \<Rightarrow> bool"
  where "uminus_homomorphism f \<equiv> \<forall>x . f (-x) = -f x"

abbreviation sup_inf_homomorphism :: "('a::{sup,inf} \<Rightarrow> 'b::{sup,inf}) \<Rightarrow> bool"
  where "sup_inf_homomorphism f \<equiv> sup_homomorphism f \<and> inf_homomorphism f"

abbreviation sup_inf_top_homomorphism :: "('a::{sup,inf,top} \<Rightarrow> 'b::{sup,inf,top}) \<Rightarrow> bool"
  where "sup_inf_top_homomorphism f \<equiv> sup_inf_homomorphism f \<and> top_homomorphism f"

abbreviation sup_inf_top_bot_homomorphism :: "('a::{sup,inf,top,bot} \<Rightarrow> 'b::{sup,inf,top,bot}) \<Rightarrow> bool"
  where "sup_inf_top_bot_homomorphism f \<equiv> sup_inf_top_homomorphism f \<and> bot_homomorphism f"

abbreviation bounded_lattice_homomorphism :: "('a::bounded_lattice \<Rightarrow> 'b::bounded_lattice) \<Rightarrow> bool"
  where "bounded_lattice_homomorphism f \<equiv> sup_inf_top_bot_homomorphism f"

abbreviation sup_inf_top_bot_uminus_homomorphism :: "('a::sup_inf_top_bot_uminus \<Rightarrow> 'b::sup_inf_top_bot_uminus) \<Rightarrow> bool"
  where "sup_inf_top_bot_uminus_homomorphism f \<equiv> sup_inf_top_bot_homomorphism f \<and> uminus_homomorphism f"

abbreviation sup_inf_top_bot_uminus_ord_homomorphism :: "('a::sup_inf_top_bot_uminus_ord \<Rightarrow> 'b::sup_inf_top_bot_uminus_ord) \<Rightarrow> bool"
  where "sup_inf_top_bot_uminus_ord_homomorphism f \<equiv> sup_inf_top_bot_uminus_homomorphism f \<and> (\<forall>x y . x \<le> y \<longrightarrow> f x \<le> f y)"

abbreviation sup_inf_top_isomorphism :: "('a::{sup,inf,top} \<Rightarrow> 'b::{sup,inf,top}) \<Rightarrow> bool"
  where "sup_inf_top_isomorphism f \<equiv> sup_inf_top_homomorphism f \<and> bij f"

abbreviation bounded_lattice_top_isomorphism :: "('a::bounded_lattice_top \<Rightarrow> 'b::bounded_lattice_top) \<Rightarrow> bool"
  where "bounded_lattice_top_isomorphism f \<equiv> sup_inf_top_isomorphism f"

abbreviation sup_inf_top_bot_uminus_isomorphism :: "('a::sup_inf_top_bot_uminus \<Rightarrow> 'b::sup_inf_top_bot_uminus) \<Rightarrow> bool"
  where "sup_inf_top_bot_uminus_isomorphism f \<equiv> sup_inf_top_bot_uminus_homomorphism f \<and> bij f"

abbreviation boolean_algebra_isomorphism :: "('a::boolean_algebra \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> bool"
  where "boolean_algebra_isomorphism f \<equiv> sup_inf_top_bot_uminus_isomorphism f \<and> minus_homomorphism f"

lemma sup_homomorphism_mono:
  "sup_homomorphism (f::'a::semilattice_sup \<Rightarrow> 'b::semilattice_sup) \<Longrightarrow> mono f"
  by (metis le_iff_sup monoI)

lemma sup_isomorphism_ord_isomorphism:
  assumes "sup_homomorphism (f::'a::semilattice_sup \<Rightarrow> 'b::semilattice_sup)"
      and "bij f"
    shows "x \<le> y \<longleftrightarrow> f x \<le> f y"
proof
  assume "x \<le> y"
  thus "f x \<le> f y"
    by (metis assms(1) le_iff_sup)
next
  assume "f x \<le> f y"
  hence "f (x \<squnion> y) = f y"
    by (simp add: assms(1) le_iff_sup)
  hence "x \<squnion> y = y"
    by (metis injD bij_is_inj assms(2))
  thus "x \<le> y"
    by (simp add: le_iff_sup)
qed

lemma minus_homomorphism_default:
  assumes "\<forall>x y::'a::{inf,minus,uminus} . x - y = x \<sqinter> -y"
      and "\<forall>x y::'b::{inf,minus,uminus} . x - y = x \<sqinter> -y"
      and "inf_homomorphism (f::'a \<Rightarrow> 'b)"
      and "uminus_homomorphism f"
    shows "minus_homomorphism f"
  by (simp add: assms)

end


(*  Title:      HOL/Map.thy
    Author:     Tobias Nipkow, based on a theory by David von Oheimb
    Copyright   1997-2003 TU Muenchen

The datatype of "maps"; strongly resembles maps in VDM.
*)

section \<open>Maps\<close>

theory Map
  imports List
  abbrevs "(=" = "\<subseteq>\<^sub>m"
begin

type_synonym ('a, 'b) "map" = "'a \<Rightarrow> 'b option" (infixr "\<rightharpoonup>" 0)

abbreviation
  empty :: "'a \<rightharpoonup> 'b" where
  "empty \<equiv> \<lambda>x. None"

definition
  map_comp :: "('b \<rightharpoonup> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c)"  (infixl "\<circ>\<^sub>m" 55) where
  "f \<circ>\<^sub>m g = (\<lambda>k. case g k of None \<Rightarrow> None | Some v \<Rightarrow> f v)"

definition
  map_add :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "++" 100) where
  "m1 ++ m2 = (\<lambda>x. case m2 x of None \<Rightarrow> m1 x | Some y \<Rightarrow> Some y)"

definition
  restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "|`"  110) where
  "m|`A = (\<lambda>x. if x \<in> A then m x else None)"

notation (latex output)
  restrict_map  ("_\<restriction>\<^bsub>_\<^esub>" [111,110] 110)

definition
  dom :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" where
  "dom m = {a. m a \<noteq> None}"

definition
  ran :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set" where
  "ran m = {b. \<exists>a. m a = Some b}"

definition
  map_le :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool"  (infix "\<subseteq>\<^sub>m" 50) where
  "(m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2) \<longleftrightarrow> (\<forall>a \<in> dom m\<^sub>1. m\<^sub>1 a = m\<^sub>2 a)"

nonterminal maplets and maplet

syntax
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /\<mapsto>/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[\<mapsto>]/ _")
  ""         :: "maplet \<Rightarrow> maplets"             ("_")
  "_Maplets" :: "[maplet, maplets] \<Rightarrow> maplets" ("_,/ _")
  "_MapUpd"  :: "['a \<rightharpoonup> 'b, maplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
  "_Map"     :: "maplets \<Rightarrow> 'a \<rightharpoonup> 'b"            ("(1[_])")

syntax (ASCII)
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /|->/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[|->]/ _")

translations
  "_MapUpd m (_Maplets xy ms)"  \<rightleftharpoons> "_MapUpd (_MapUpd m xy) ms"
  "_MapUpd m (_maplet  x y)"    \<rightleftharpoons> "m(x := CONST Some y)"
  "_Map ms"                     \<rightleftharpoons> "_MapUpd (CONST empty) ms"
  "_Map (_Maplets ms1 ms2)"     \<leftharpoondown> "_MapUpd (_Map ms1) ms2"
  "_Maplets ms1 (_Maplets ms2 ms3)" \<leftharpoondown> "_Maplets (_Maplets ms1 ms2) ms3"

primrec map_of :: "('a \<times> 'b) list \<Rightarrow> 'a \<rightharpoonup> 'b"
where
  "map_of [] = empty"
| "map_of (p # ps) = (map_of ps)(fst p \<mapsto> snd p)"

definition map_upds :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a \<rightharpoonup> 'b"
  where "map_upds m xs ys = m ++ map_of (rev (zip xs ys))"
translations
  "_MapUpd m (_maplets x y)" \<rightleftharpoons> "CONST map_upds m x y"

lemma map_of_Cons_code [code]:
  "map_of [] k = None"
  "map_of ((l, v) # ps) k = (if l = k then Some v else map_of ps k)"
  by simp_all

subsection \<open>@{term [source] empty}\<close>

lemma empty_upd_none [simp]: "empty(x := None) = empty"
  by (rule ext) simp

subsection \<open>@{term [source] map_upd}\<close>

lemma map_upd_triv: "t k = Some x \<Longrightarrow> t(k\<mapsto>x) = t"
  by (rule ext) simp

lemma map_upd_nonempty [simp]: "t(k\<mapsto>x) \<noteq> empty"
proof
  assume "t(k \<mapsto> x) = empty"
  then have "(t(k \<mapsto> x)) k = None" by simp
  then show False by simp
qed

lemma map_upd_eqD1:
  assumes "m(a\<mapsto>x) = n(a\<mapsto>y)"
  shows "x = y"
proof -
  from assms have "(m(a\<mapsto>x)) a = (n(a\<mapsto>y)) a" by simp
  then show ?thesis by simp
qed

lemma map_upd_Some_unfold:
  "((m(a\<mapsto>b)) x = Some y) = (x = a \<and> b = y \<or> x \<noteq> a \<and> m x = Some y)"
  by auto

lemma image_map_upd [simp]: "x \<notin> A \<Longrightarrow> m(x \<mapsto> y) ` A = m ` A"
  by auto

lemma finite_range_updI:
  assumes "finite (range f)" shows "finite (range (f(a\<mapsto>b)))"
proof -
  have "range (f(a\<mapsto>b)) \<subseteq> insert (Some b) (range f)"
    by auto
  then show ?thesis
    by (rule finite_subset) (use assms in auto)
qed

subsection \<open>@{term [source] map_of}\<close>

lemma map_of_eq_empty_iff [simp]:
  "map_of xys = empty \<longleftrightarrow> xys = []"
proof
  show "map_of xys = empty \<Longrightarrow> xys = []"
    by (induction xys) simp_all
qed simp

lemma empty_eq_map_of_iff [simp]:
  "empty = map_of xys \<longleftrightarrow> xys = []"
by(subst eq_commute) simp

lemma map_of_eq_None_iff:
  "(map_of xys x = None) = (x \<notin> fst ` (set xys))"
by (induct xys) simp_all

lemma map_of_eq_Some_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (map_of xys x = Some y) = ((x,y) \<in> set xys)"
proof (induct xys)
  case (Cons xy xys)
  then show ?case
    by (cases xy) (auto simp flip: map_of_eq_None_iff)
qed auto

lemma Some_eq_map_of_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (Some y = map_of xys x) = ((x,y) \<in> set xys)"
by (auto simp del: map_of_eq_Some_iff simp: map_of_eq_Some_iff [symmetric])

lemma map_of_is_SomeI [simp]:
  "\<lbrakk>distinct(map fst xys); (x,y) \<in> set xys\<rbrakk> \<Longrightarrow> map_of xys x = Some y"
  by simp

lemma map_of_zip_is_None [simp]:
  "length xs = length ys \<Longrightarrow> (map_of (zip xs ys) x = None) = (x \<notin> set xs)"
by (induct rule: list_induct2) simp_all

lemma map_of_zip_is_Some:
  assumes "length xs = length ys"
  shows "x \<in> set xs \<longleftrightarrow> (\<exists>y. map_of (zip xs ys) x = Some y)"
using assms by (induct rule: list_induct2) simp_all

lemma map_of_zip_upd:
  fixes x :: 'a and xs :: "'a list" and ys zs :: "'b list"
  assumes "length ys = length xs"
    and "length zs = length xs"
    and "x \<notin> set xs"
    and "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)"
  shows "map_of (zip xs ys) = map_of (zip xs zs)"
proof
  fix x' :: 'a
  show "map_of (zip xs ys) x' = map_of (zip xs zs) x'"
  proof (cases "x = x'")
    case True
    from assms True map_of_zip_is_None [of xs ys x']
      have "map_of (zip xs ys) x' = None" by simp
    moreover from assms True map_of_zip_is_None [of xs zs x']
      have "map_of (zip xs zs) x' = None" by simp
    ultimately show ?thesis by simp
  next
    case False from assms
      have "(map_of (zip xs ys)(x \<mapsto> y)) x' = (map_of (zip xs zs)(x \<mapsto> z)) x'" by auto
    with False show ?thesis by simp
  qed
qed

lemma map_of_zip_inject:
  assumes "length ys = length xs"
    and "length zs = length xs"
    and dist: "distinct xs"
    and map_of: "map_of (zip xs ys) = map_of (zip xs zs)"
  shows "ys = zs"
  using assms(1) assms(2)[symmetric]
  using dist map_of
proof (induct ys xs zs rule: list_induct3)
  case Nil show ?case by simp
next
  case (Cons y ys x xs z zs)
  from \<open>map_of (zip (x#xs) (y#ys)) = map_of (zip (x#xs) (z#zs))\<close>
    have map_of: "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)" by simp
  from Cons have "length ys = length xs" and "length zs = length xs"
    and "x \<notin> set xs" by simp_all
  then have "map_of (zip xs ys) = map_of (zip xs zs)" using map_of by (rule map_of_zip_upd)
  with Cons.hyps \<open>distinct (x # xs)\<close> have "ys = zs" by simp
  moreover from map_of have "y = z" by (rule map_upd_eqD1)
  ultimately show ?case by simp
qed

lemma map_of_zip_nth:
  assumes "length xs = length ys"
  assumes "distinct xs"
  assumes "i < length ys"
  shows "map_of (zip xs ys) (xs ! i) = Some (ys ! i)"
using assms proof (induct arbitrary: i rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons x xs y ys)
  then show ?case
    using less_Suc_eq_0_disj by auto
qed

lemma map_of_zip_map:
  "map_of (zip xs (map f xs)) = (\<lambda>x. if x \<in> set xs then Some (f x) else None)"
  by (induct xs) (simp_all add: fun_eq_iff)

lemma finite_range_map_of: "finite (range (map_of xys))"
proof (induct xys)
  case (Cons a xys)
  then show ?case
    using finite_range_updI by fastforce
qed auto

lemma map_of_SomeD: "map_of xs k = Some y \<Longrightarrow> (k, y) \<in> set xs"
  by (induct xs) (auto split: if_splits)

lemma map_of_mapk_SomeI:
  "inj f \<Longrightarrow> map_of t k = Some x \<Longrightarrow>
   map_of (map (case_prod (\<lambda>k. Pair (f k))) t) (f k) = Some x"
by (induct t) (auto simp: inj_eq)

lemma weak_map_of_SomeI: "(k, x) \<in> set l \<Longrightarrow> \<exists>x. map_of l k = Some x"
by (induct l) auto

lemma map_of_filter_in:
  "map_of xs k = Some z \<Longrightarrow> P k z \<Longrightarrow> map_of (filter (case_prod P) xs) k = Some z"
by (induct xs) auto

lemma map_of_map:
  "map_of (map (\<lambda>(k, v). (k, f v)) xs) = map_option f \<circ> map_of xs"
  by (induct xs) (auto simp: fun_eq_iff)

lemma dom_map_option:
  "dom (\<lambda>k. map_option (f k) (m k)) = dom m"
  by (simp add: dom_def)

lemma dom_map_option_comp [simp]:
  "dom (map_option g \<circ> m) = dom m"
  using dom_map_option [of "\<lambda>_. g" m] by (simp add: comp_def)

subsection \<open>\<^const>\<open>map_option\<close> related\<close>

lemma map_option_o_empty [simp]: "map_option f \<circ> empty = empty"
by (rule ext) simp

lemma map_option_o_map_upd [simp]:
  "map_option f \<circ> m(a\<mapsto>b) = (map_option f \<circ> m)(a\<mapsto>f b)"
by (rule ext) simp

subsection \<open>@{term [source] map_comp} related\<close>

lemma map_comp_empty [simp]:
  "m \<circ>\<^sub>m empty = empty"
  "empty \<circ>\<^sub>m m = empty"
by (auto simp: map_comp_def split: option.splits)

lemma map_comp_simps [simp]:
  "m2 k = None \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = None"
  "m2 k = Some k' \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = m1 k'"
by (auto simp: map_comp_def)

lemma map_comp_Some_iff:
  "((m1 \<circ>\<^sub>m m2) k = Some v) = (\<exists>k'. m2 k = Some k' \<and> m1 k' = Some v)"
by (auto simp: map_comp_def split: option.splits)

lemma map_comp_None_iff:
  "((m1 \<circ>\<^sub>m m2) k = None) = (m2 k = None \<or> (\<exists>k'. m2 k = Some k' \<and> m1 k' = None)) "
by (auto simp: map_comp_def split: option.splits)

subsection \<open>\<open>++\<close>\<close>

lemma map_add_empty[simp]: "m ++ empty = m"
by(simp add: map_add_def)

lemma empty_map_add[simp]: "empty ++ m = m"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_assoc[simp]: "m1 ++ (m2 ++ m3) = (m1 ++ m2) ++ m3"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_Some_iff:
  "((m ++ n) k = Some x) = (n k = Some x \<or> n k = None \<and> m k = Some x)"
by (simp add: map_add_def split: option.split)

lemma map_add_SomeD [dest!]:
  "(m ++ n) k = Some x \<Longrightarrow> n k = Some x \<or> n k = None \<and> m k = Some x"
by (rule map_add_Some_iff [THEN iffD1])

lemma map_add_find_right [simp]: "n k = Some xx \<Longrightarrow> (m ++ n) k = Some xx"
by (subst map_add_Some_iff) fast

lemma map_add_None [iff]: "((m ++ n) k = None) = (n k = None \<and> m k = None)"
by (simp add: map_add_def split: option.split)

lemma map_add_upd[simp]: "f ++ g(x\<mapsto>y) = (f ++ g)(x\<mapsto>y)"
by (rule ext) (simp add: map_add_def)

lemma map_add_upds[simp]: "m1 ++ (m2(xs[\<mapsto>]ys)) = (m1++m2)(xs[\<mapsto>]ys)"
by (simp add: map_upds_def)

lemma map_add_upd_left: "m\<notin>dom e2 \<Longrightarrow> e1(m \<mapsto> u1) ++ e2 = (e1 ++ e2)(m \<mapsto> u1)"
by (rule ext) (auto simp: map_add_def dom_def split: option.split)

lemma map_of_append[simp]: "map_of (xs @ ys) = map_of ys ++ map_of xs"
  unfolding map_add_def
proof (induct xs)
  case (Cons a xs)
  then show ?case
    by (force split: option.split)
qed auto

lemma finite_range_map_of_map_add:
  "finite (range f) \<Longrightarrow> finite (range (f ++ map_of l))"
proof (induct l)
case (Cons a l)
  then show ?case
    by (metis finite_range_updI map_add_upd map_of.simps(2))
qed auto

lemma inj_on_map_add_dom [iff]:
  "inj_on (m ++ m') (dom m') = inj_on m' (dom m')"
  by (fastforce simp: map_add_def dom_def inj_on_def split: option.splits)

lemma map_upds_fold_map_upd:
  "m(ks[\<mapsto>]vs) = foldl (\<lambda>m (k, v). m(k \<mapsto> v)) m (zip ks vs)"
unfolding map_upds_def proof (rule sym, rule zip_obtain_same_length)
  fix ks :: "'a list" and vs :: "'b list"
  assume "length ks = length vs"
  then show "foldl (\<lambda>m (k, v). m(k\<mapsto>v)) m (zip ks vs) = m ++ map_of (rev (zip ks vs))"
    by(induct arbitrary: m rule: list_induct2) simp_all
qed

lemma map_add_map_of_foldr:
  "m ++ map_of ps = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) ps m"
  by (induct ps) (auto simp: fun_eq_iff map_add_def)

subsection \<open>@{term [source] restrict_map}\<close>

lemma restrict_map_to_empty [simp]: "m|`{} = empty"
  by (simp add: restrict_map_def)

lemma restrict_map_insert: "f |` (insert a A) = (f |` A)(a := f a)"
  by (auto simp: restrict_map_def)

lemma restrict_map_empty [simp]: "empty|`D = empty"
  by (simp add: restrict_map_def)

lemma restrict_in [simp]: "x \<in> A \<Longrightarrow> (m|`A) x = m x"
  by (simp add: restrict_map_def)

lemma restrict_out [simp]: "x \<notin> A \<Longrightarrow> (m|`A) x = None"
  by (simp add: restrict_map_def)

lemma ran_restrictD: "y \<in> ran (m|`A) \<Longrightarrow> \<exists>x\<in>A. m x = Some y"
  by (auto simp: restrict_map_def ran_def split: if_split_asm)

lemma dom_restrict [simp]: "dom (m|`A) = dom m \<inter> A"
  by (auto simp: restrict_map_def dom_def split: if_split_asm)

lemma restrict_upd_same [simp]: "m(x\<mapsto>y)|`(-{x}) = m|`(-{x})"
  by (rule ext) (auto simp: restrict_map_def)

lemma restrict_restrict [simp]: "m|`A|`B = m|`(A\<inter>B)"
  by (rule ext) (auto simp: restrict_map_def)

lemma restrict_fun_upd [simp]:
  "m(x := y)|`D = (if x \<in> D then (m|`(D-{x}))(x := y) else m|`D)"
  by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_None_restrict [simp]:
  "(m|`D)(x := None) = (if x \<in> D then m|`(D - {x}) else m|`D)"
  by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict: "(m|`D)(x := y) = (m|`(D-{x}))(x := y)"
  by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict_conv [simp]:
  "x \<in> D \<Longrightarrow> (m|`D)(x := y) = (m|`(D-{x}))(x := y)"
  by (rule fun_upd_restrict)

lemma map_of_map_restrict:
  "map_of (map (\<lambda>k. (k, f k)) ks) = (Some \<circ> f) |` set ks"
  by (induct ks) (simp_all add: fun_eq_iff restrict_map_insert)

lemma restrict_complement_singleton_eq:
  "f |` (- {x}) = f(x := None)"
  by auto

subsection \<open>@{term [source] map_upds}\<close>

lemma map_upds_Nil1 [simp]: "m([] [\<mapsto>] bs) = m"
  by (simp add: map_upds_def)

lemma map_upds_Nil2 [simp]: "m(as [\<mapsto>] []) = m"
  by (simp add:map_upds_def)

lemma map_upds_Cons [simp]: "m(a#as [\<mapsto>] b#bs) = (m(a\<mapsto>b))(as[\<mapsto>]bs)"
  by (simp add:map_upds_def)

lemma map_upds_append1 [simp]:
  "size xs < size ys \<Longrightarrow> m(xs@[x] [\<mapsto>] ys) = m(xs [\<mapsto>] ys)(x \<mapsto> ys!size xs)"
proof (induct xs arbitrary: ys m)
  case Nil
  then show ?case
    by (auto simp: neq_Nil_conv)
next
  case (Cons a xs)
  then show ?case
    by (cases ys) auto
qed

lemma map_upds_list_update2_drop [simp]:
  "size xs \<le> i \<Longrightarrow> m(xs[\<mapsto>]ys[i:=y]) = m(xs[\<mapsto>]ys)"
proof (induct xs arbitrary: m ys i)
  case Nil
  then show ?case
    by auto
next
  case (Cons a xs)
  then show ?case
    by (cases ys) (use Cons in \<open>auto split: nat.split\<close>)
qed

text \<open>Something weirdly sensitive about this proof, which needs only four lines in apply style\<close>
lemma map_upd_upds_conv_if:
  "(f(x\<mapsto>y))(xs [\<mapsto>] ys) =
   (if x \<in> set(take (length ys) xs) then f(xs [\<mapsto>] ys)
                                    else (f(xs [\<mapsto>] ys))(x\<mapsto>y))"
proof (induct xs arbitrary: x y ys f)
  case (Cons a xs)
  show ?case
  proof (cases ys)
    case (Cons z zs)
    then show ?thesis
      using Cons.hyps
      apply (auto split: if_split simp: fun_upd_twist)
      using Cons.hyps apply fastforce+
      done
  qed auto
qed auto

lemma map_upds_twist [simp]:
  "a \<notin> set as \<Longrightarrow> m(a\<mapsto>b)(as[\<mapsto>]bs) = m(as[\<mapsto>]bs)(a\<mapsto>b)"
using set_take_subset by (fastforce simp add: map_upd_upds_conv_if)

lemma map_upds_apply_nontin [simp]:
  "x \<notin> set xs \<Longrightarrow> (f(xs[\<mapsto>]ys)) x = f x"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma fun_upds_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs@zs[\<mapsto>]ys) = m(xs[\<mapsto>]ys)"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma fun_upds_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs[\<mapsto>]ys@zs) = m(xs[\<mapsto>]ys)"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma restrict_map_upds[simp]:
  "\<lbrakk> length xs = length ys; set xs \<subseteq> D \<rbrakk>
    \<Longrightarrow> m(xs [\<mapsto>] ys)|`D = (m|`(D - set xs))(xs [\<mapsto>] ys)"
proof (induct xs arbitrary: m ys)
  case (Cons a xs)
  then show ?case
  proof (cases ys)
    case (Cons z zs)
    with Cons.hyps Cons.prems show ?thesis
      apply (simp add: insert_absorb flip: Diff_insert)
      apply (auto simp add: map_upd_upds_conv_if)
      done
  qed auto
qed auto

subsection \<open>@{term [source] dom}\<close>

lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
  by (auto simp: dom_def)

lemma domI: "m a = Some b \<Longrightarrow> a \<in> dom m"
  by (simp add: dom_def)
(* declare domI [intro]? *)

lemma domD: "a \<in> dom m \<Longrightarrow> \<exists>b. m a = Some b"
  by (cases "m a") (auto simp add: dom_def)

lemma domIff [iff, simp del, code_unfold]: "a \<in> dom m \<longleftrightarrow> m a \<noteq> None"
  by (simp add: dom_def)

lemma dom_empty [simp]: "dom empty = {}"
  by (simp add: dom_def)

lemma dom_fun_upd [simp]:
  "dom(f(x := y)) = (if y = None then dom f - {x} else insert x (dom f))"
  by (auto simp: dom_def)

lemma dom_if:
  "dom (\<lambda>x. if P x then f x else g x) = dom f \<inter> {x. P x} \<union> dom g \<inter> {x. \<not> P x}"
  by (auto split: if_splits)

lemma dom_map_of_conv_image_fst:
  "dom (map_of xys) = fst ` set xys"
  by (induct xys) (auto simp add: dom_if)

lemma dom_map_of_zip [simp]: "length xs = length ys \<Longrightarrow> dom (map_of (zip xs ys)) = set xs"
  by (induct rule: list_induct2) (auto simp: dom_if)

lemma finite_dom_map_of: "finite (dom (map_of l))"
  by (induct l) (auto simp: dom_def insert_Collect [symmetric])

lemma dom_map_upds [simp]:
  "dom(m(xs[\<mapsto>]ys)) = set(take (length ys) xs) \<union> dom m"
proof (induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by (cases ys) (auto simp: map_upd_upds_conv_if)
qed auto

lemma dom_map_add [simp]: "dom (m ++ n) = dom n \<union> dom m"
  by (auto simp: dom_def)

lemma dom_override_on [simp]:
  "dom (override_on f g A) =
    (dom f  - {a. a \<in> A - dom g}) \<union> {a. a \<in> A \<inter> dom g}"
  by (auto simp: dom_def override_on_def)

lemma map_add_dom_app_simps:
  "m \<in> dom l2 \<Longrightarrow> (l1 ++ l2) m = l2 m"
  "m \<notin> dom l1 \<Longrightarrow> (l1 ++ l2) m = l2 m"
  "m \<notin> dom l2 \<Longrightarrow> (l1 ++ l2) m = l1 m"
  by (auto simp add: map_add_def split: option.split_asm)

lemma dom_const [simp]:
  "dom (\<lambda>x. Some (f x)) = UNIV"
  by auto

(* Due to John Matthews - could be rephrased with dom *)
lemma finite_map_freshness:
  "finite (dom (f :: 'a \<rightharpoonup> 'b)) \<Longrightarrow> \<not> finite (UNIV :: 'a set) \<Longrightarrow>
   \<exists>x. f x = None"
  by (bestsimp dest: ex_new_if_finite)

lemma dom_minus:
  "f x = None \<Longrightarrow> dom f - insert x A = dom f - A"
  unfolding dom_def by simp

lemma insert_dom:
  "f x = Some y \<Longrightarrow> insert x (dom f) = dom f"
  unfolding dom_def by auto

lemma map_of_map_keys:
  "set xs = dom m \<Longrightarrow> map_of (map (\<lambda>k. (k, the (m k))) xs) = m"
  by (rule ext) (auto simp add: map_of_map_restrict restrict_map_def)

lemma map_of_eqI:
  assumes set_eq: "set (map fst xs) = set (map fst ys)"
  assumes map_eq: "\<forall>k\<in>set (map fst xs). map_of xs k = map_of ys k"
  shows "map_of xs = map_of ys"
proof (rule ext)
  fix k show "map_of xs k = map_of ys k"
  proof (cases "map_of xs k")
    case None
    then have "k \<notin> set (map fst xs)" by (simp add: map_of_eq_None_iff)
    with set_eq have "k \<notin> set (map fst ys)" by simp
    then have "map_of ys k = None" by (simp add: map_of_eq_None_iff)
    with None show ?thesis by simp
  next
    case (Some v)
    then have "k \<in> set (map fst xs)" by (auto simp add: dom_map_of_conv_image_fst [symmetric])
    with map_eq show ?thesis by auto
  qed
qed

lemma map_of_eq_dom:
  assumes "map_of xs = map_of ys"
  shows "fst ` set xs = fst ` set ys"
proof -
  from assms have "dom (map_of xs) = dom (map_of ys)" by simp
  then show ?thesis by (simp add: dom_map_of_conv_image_fst)
qed

lemma finite_set_of_finite_maps:
  assumes "finite A" "finite B"
  shows "finite {m. dom m = A \<and> ran m \<subseteq> B}" (is "finite ?S")
proof -
  let ?S' = "{m. \<forall>x. (x \<in> A \<longrightarrow> m x \<in> Some ` B) \<and> (x \<notin> A \<longrightarrow> m x = None)}"
  have "?S = ?S'"
  proof
    show "?S \<subseteq> ?S'" by (auto simp: dom_def ran_def image_def)
    show "?S' \<subseteq> ?S"
    proof
      fix m assume "m \<in> ?S'"
      hence 1: "dom m = A" by force
      hence 2: "ran m \<subseteq> B" using \<open>m \<in> ?S'\<close> by (auto simp: dom_def ran_def)
      from 1 2 show "m \<in> ?S" by blast
    qed
  qed
  with assms show ?thesis by(simp add: finite_set_of_finite_funs)
qed

subsection \<open>@{term [source] ran}\<close>

lemma ranI: "m a = Some b \<Longrightarrow> b \<in> ran m"
  by (auto simp: ran_def)
(* declare ranI [intro]? *)

lemma ran_empty [simp]: "ran empty = {}"
  by (auto simp: ran_def)

lemma ran_map_upd [simp]:  "m a = None \<Longrightarrow> ran(m(a\<mapsto>b)) = insert b (ran m)"
  unfolding ran_def
  by force

lemma ran_map_add:
  assumes "dom m1 \<inter> dom m2 = {}"
  shows "ran (m1 ++ m2) = ran m1 \<union> ran m2"
proof
  show "ran (m1 ++ m2) \<subseteq> ran m1 \<union> ran m2"
    unfolding ran_def by auto
next
  show "ran m1 \<union> ran m2 \<subseteq> ran (m1 ++ m2)"
  proof -
    have "(m1 ++ m2) x = Some y" if "m1 x = Some y" for x y
      using assms map_add_comm that by fastforce
    moreover have "(m1 ++ m2) x = Some y" if "m2 x = Some y" for x y
      using assms that by auto
    ultimately show ?thesis
      unfolding ran_def by blast
  qed
qed

lemma finite_ran:
  assumes "finite (dom p)"
  shows "finite (ran p)"
proof -
  have "ran p = (\<lambda>x. the (p x)) ` dom p"
    unfolding ran_def by force
  from this \<open>finite (dom p)\<close> show ?thesis by auto
qed

lemma ran_distinct:
  assumes dist: "distinct (map fst al)"
  shows "ran (map_of al) = snd ` set al"
  using assms
proof (induct al)
  case Nil
  then show ?case by simp
next
  case (Cons kv al)
  then have "ran (map_of al) = snd ` set al" by simp
  moreover from Cons.prems have "map_of al (fst kv) = None"
    by (simp add: map_of_eq_None_iff)
  ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed

lemma ran_map_of_zip:
  assumes "length xs = length ys" "distinct xs"
  shows "ran (map_of (zip xs ys)) = set ys"
using assms by (simp add: ran_distinct set_map[symmetric])

lemma ran_map_option: "ran (\<lambda>x. map_option f (m x)) = f ` ran m"
  by (auto simp add: ran_def)

subsection \<open>\<open>map_le\<close>\<close>

lemma map_le_empty [simp]: "empty \<subseteq>\<^sub>m g"
  by (simp add: map_le_def)

lemma upd_None_map_le [simp]: "f(x := None) \<subseteq>\<^sub>m f"
  by (force simp add: map_le_def)

lemma map_le_upd[simp]: "f \<subseteq>\<^sub>m g ==> f(a := b) \<subseteq>\<^sub>m g(a := b)"
  by (fastforce simp add: map_le_def)

lemma map_le_imp_upd_le [simp]: "m1 \<subseteq>\<^sub>m m2 \<Longrightarrow> m1(x := None) \<subseteq>\<^sub>m m2(x \<mapsto> y)"
  by (force simp add: map_le_def)

lemma map_le_upds [simp]:
  "f \<subseteq>\<^sub>m g \<Longrightarrow> f(as [\<mapsto>] bs) \<subseteq>\<^sub>m g(as [\<mapsto>] bs)"
proof (induct as arbitrary: f g bs)
  case (Cons a as)
  then show ?case
    by (cases bs) (use Cons in auto)
qed auto

lemma map_le_implies_dom_le: "(f \<subseteq>\<^sub>m g) \<Longrightarrow> (dom f \<subseteq> dom g)"
  by (fastforce simp add: map_le_def dom_def)

lemma map_le_refl [simp]: "f \<subseteq>\<^sub>m f"
  by (simp add: map_le_def)

lemma map_le_trans[trans]: "\<lbrakk> m1 \<subseteq>\<^sub>m m2; m2 \<subseteq>\<^sub>m m3\<rbrakk> \<Longrightarrow> m1 \<subseteq>\<^sub>m m3"
  by (auto simp add: map_le_def dom_def)

lemma map_le_antisym: "\<lbrakk> f \<subseteq>\<^sub>m g; g \<subseteq>\<^sub>m f \<rbrakk> \<Longrightarrow> f = g"
  unfolding map_le_def
  by (metis ext domIff)

lemma map_le_map_add [simp]: "f \<subseteq>\<^sub>m g ++ f"
  by (fastforce simp: map_le_def)

lemma map_le_iff_map_add_commute: "f \<subseteq>\<^sub>m f ++ g \<longleftrightarrow> f ++ g = g ++ f"
  by (fastforce simp: map_add_def map_le_def fun_eq_iff split: option.splits)

lemma map_add_le_mapE: "f ++ g \<subseteq>\<^sub>m h \<Longrightarrow> g \<subseteq>\<^sub>m h"
  by (fastforce simp: map_le_def map_add_def dom_def)

lemma map_add_le_mapI: "\<lbrakk> f \<subseteq>\<^sub>m h; g \<subseteq>\<^sub>m h \<rbrakk> \<Longrightarrow> f ++ g \<subseteq>\<^sub>m h"
  by (auto simp: map_le_def map_add_def dom_def split: option.splits)

lemma map_add_subsumed1: "f \<subseteq>\<^sub>m g \<Longrightarrow> f++g = g"
by (simp add: map_add_le_mapI map_le_antisym)

lemma map_add_subsumed2: "f \<subseteq>\<^sub>m g \<Longrightarrow> g++f = g"
by (metis map_add_subsumed1 map_le_iff_map_add_commute)

lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs by (auto split: if_split_asm)
next
  assume ?lhs
  then obtain v where v: "f x = Some v" by auto
  show ?rhs
  proof
    show "f = [x \<mapsto> v]"
    proof (rule map_le_antisym)
      show "[x \<mapsto> v] \<subseteq>\<^sub>m f"
        using v by (auto simp add: map_le_def)
      show "f \<subseteq>\<^sub>m [x \<mapsto> v]"
        using \<open>dom f = {x}\<close> \<open>f x = Some v\<close> by (auto simp add: map_le_def)
    qed
  qed
qed

lemma map_add_eq_empty_iff[simp]:
  "(f++g = empty) \<longleftrightarrow> f = empty \<and> g = empty"
by (metis map_add_None)

lemma empty_eq_map_add_iff[simp]:
  "(empty = f++g) \<longleftrightarrow> f = empty \<and> g = empty"
by(subst map_add_eq_empty_iff[symmetric])(rule eq_commute)

subsection \<open>Various\<close>

lemma set_map_of_compr:
  assumes distinct: "distinct (map fst xs)"
  shows "set xs = {(k, v). map_of xs k = Some v}"
  using assms
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  obtain k v where "x = (k, v)" by (cases x) blast
  with Cons.prems have "k \<notin> dom (map_of xs)"
    by (simp add: dom_map_of_conv_image_fst)
  then have *: "insert (k, v) {(k, v). map_of xs k = Some v} =
    {(k', v'). (map_of xs(k \<mapsto> v)) k' = Some v'}"
    by (auto split: if_splits)
  from Cons have "set xs = {(k, v). map_of xs k = Some v}" by simp
  with * \<open>x = (k, v)\<close> show ?case by simp
qed

lemma eq_key_imp_eq_value:
  "v1 = v2"
  if "distinct (map fst xs)" "(k, v1) \<in> set xs" "(k, v2) \<in> set xs"
proof -
  from that have "inj_on fst (set xs)"
    by (simp add: distinct_map)
  moreover have "fst (k, v1) = fst (k, v2)"
    by simp
  ultimately have "(k, v1) = (k, v2)"
    by (rule inj_onD) (fact that)+
  then show ?thesis
    by simp
qed

lemma map_of_inject_set:
  assumes distinct: "distinct (map fst xs)" "distinct (map fst ys)"
  shows "map_of xs = map_of ys \<longleftrightarrow> set xs = set ys" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  moreover from \<open>distinct (map fst xs)\<close> have "set xs = {(k, v). map_of xs k = Some v}"
    by (rule set_map_of_compr)
  moreover from \<open>distinct (map fst ys)\<close> have "set ys = {(k, v). map_of ys k = Some v}"
    by (rule set_map_of_compr)
  ultimately show ?rhs by simp
next
  assume ?rhs show ?lhs
  proof
    fix k
    show "map_of xs k = map_of ys k"
    proof (cases "map_of xs k")
      case None
      with \<open>?rhs\<close> have "map_of ys k = None"
        by (simp add: map_of_eq_None_iff)
      with None show ?thesis by simp
    next
      case (Some v)
      with distinct \<open>?rhs\<close> have "map_of ys k = Some v"
        by simp
      with Some show ?thesis by simp
    qed
  qed
qed

hide_const (open) Map.empty

end


(* Author: Tobias Nipkow *)

section \<open>Unbalanced Tree Implementation of Set\<close>

theory Tree_Set
imports
  Tree
  Cmp
  Set_Specs
begin

definition empty :: "'a tree" where
"empty = Leaf"

fun isin :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node l a r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow> isin r x)"

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x Leaf = Node Leaf x Leaf" |
"insert x (Node l a r) =
  (case cmp x a of
     LT \<Rightarrow> Node (insert x l) a r |
     EQ \<Rightarrow> Node l a r |
     GT \<Rightarrow> Node l a (insert x r))"

text \<open>Deletion by replacing:\<close>

fun split_min :: "'a tree \<Rightarrow> 'a * 'a tree" where
"split_min (Node l a r) =
  (if l = Leaf then (a,r) else let (x,l') = split_min l in (x, Node l' a r))"

fun delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete x Leaf = Leaf" |
"delete x (Node l a r) =
  (case cmp x a of
     LT \<Rightarrow>  Node (delete x l) a r |
     GT \<Rightarrow>  Node l a (delete x r) |
     EQ \<Rightarrow> if r = Leaf then l else let (a',r') = split_min r in Node l a' r')"

text \<open>Deletion by joining:\<close>

fun join :: "('a::linorder)tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"join t Leaf = t" |
"join Leaf t = t" |
"join (Node t1 a t2) (Node t3 b t4) =
  (case join t2 t3 of
     Leaf \<Rightarrow> Node t1 a (Node Leaf b t4) |
     Node u2 x u3 \<Rightarrow> Node (Node t1 a u2) x (Node u3 b t4))"

fun delete2 :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete2 x Leaf = Leaf" |
"delete2 x (Node l a r) =
  (case cmp x a of
     LT \<Rightarrow>  Node (delete2 x l) a r |
     GT \<Rightarrow>  Node l a (delete2 x r) |
     EQ \<Rightarrow> join l r)"

subsection "Functional Correctness Proofs"

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set (inorder t))"
by (induction t) (auto simp: isin_simps)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by(induction t) (auto simp: ins_list_simps)

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by(induction t arbitrary: t' rule: split_min.induct)
  (auto simp: sorted_lems split: prod.splits if_splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(induction t) (auto simp: del_list_simps split_minD split: prod.splits)

interpretation S: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed (rule TrueI)+

lemma inorder_join:
  "inorder(join l r) = inorder l @ inorder r"
by(induction l r rule: join.induct) (auto split: tree.split)

lemma inorder_delete2:
  "sorted(inorder t) \<Longrightarrow> inorder(delete2 x t) = del_list x (inorder t)"
by(induction t) (auto simp: inorder_join del_list_simps)

interpretation S2: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete2
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete2)
qed (rule TrueI)+

end


           (*-------------------------------------------*
            |       Uniform Candy Distribution          |
            |                                           |
            |           November 2007 for Isabelle 2005 |
            |           November 2008 for Isabelle 2008 |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory UCD_data1
imports CSP_F
begin

(*****************************************************************

         1. Data part

 *****************************************************************)

(* line and circ *)

definition
  fill       :: "nat => nat"
  where
  fill_def     : "fill n == if even n then n else n+1"

definition
  allEven    :: "nat list => bool"
  where
  allEven_def  : "allEven s == (ALL s:set s. even s)"

primrec
  lineNext   :: "nat list => nat => nat list"
where
  "lineNext  ([]) = (%x. [])"
 |"lineNext (n#s) = (%x. if (s=[]) then [fill(n div 2 + x)]
                         else (fill(n div 2 + hd(s) div 2))#(lineNext s x))"

definition
  circNext   :: "nat list => nat list"
where
  circNext_def : "circNext s == (if s=[] then [] else lineNext s (hd s div 2))"

primrec
  circNexts  :: "nat => nat list => nat list"
where
  "circNexts      0  = (%s. s)"
 |"circNexts (Suc N) = (%s. circNexts N (circNext s))"

(* max and min *)

primrec
  maxList        :: "nat list => nat"
where
  "maxList ([])  = 0"
 |"maxList (n#s) = (if (maxList(s) < n) then n else maxList(s))"

primrec
  minList        :: "nat list => nat"
where
  "minList ([])  = 0"
 |"minList (n#s) = (if (s=[]) then n
                    else if (n < minList(s)) then n else minList(s))"

primrec
  howMany        :: "nat => nat list => nat"
where
  "howMany m ([])  = 0"
 |"howMany m (n#s) = (if (m=n) then (Suc (howMany m s)) else howMany m s)"

definition
  stableList     :: "nat list => bool"
where
  stableList_def: "stableList s == ALL n:set s. n = minList s"

primrec
  makeStableList :: "nat => nat => nat list"
where
  "makeStableList 0 = (%n. [])"
 |"makeStableList (Suc l) = (%n. n#makeStableList l n)"

(* ------ test ------ *)

lemma lineNext_test:
  "lineNext [4, 2, 10] 2 = [4, 6, 8]"
by (simp add: fill_def)

lemma circNext_test:
  "circNext [4, 2, 10] = [4, 6, 8]"
by (simp add: circNext_def fill_def)

lemma maxList_test:
  "maxList [4, 2, 10, 1, 5] = 10"
by (simp)

lemma minList_test:
  "minList [4, 2, 10, 1, 5] = 1"
by (simp)

lemma howMany_test:
  "howMany 2 [4, 2, 10, 2, 5, 2] = 3"
by (simp)

lemma makeStableList_test:
  "makeStableList (Suc (Suc (Suc 0))) 5 = [5, 5, 5]"
by (simp)

(* ------------------------------------------------- *
                convenient lemmas
 * ------------------------------------------------- *)

lemma not_nil_EX: "(s ~= []) = (EX a t. s=a#t)"
by (induct_tac s, auto)

lemma hd_in_list[simp]: "s ~= [] --> hd s : set s"
by (induct_tac s, auto)

lemma nth_hd: "s ~= [] --> s!0 = hd s"
by (induct_tac s, auto)

lemma nth_last: "Suc i = length s ==> (s ! i = last s)"
apply (insert list_last_nil_or_unnil)
apply (drule_tac x="s" in spec)
apply (auto)
done

lemma list_not_nil: "(s ~= []) = (EX a t. s = a#t)"
by (induct_tac s, auto)

lemma even_EX: "(even n) = (EX m. n = (2::nat)*m)"
apply (auto elim: evenE)
(* for Isabelle 2013
apply (simp add: even_nat_equiv_def2)
apply (auto)
apply (rule_tac x="y" in exI, simp)
apply (rule_tac x="m" in exI, simp)
*)
done

lemma less_Suc: "(n < Suc N) = (n=0 | (EX m. n = Suc m & m < N))"
by (induct_tac n, auto)

lemma zero_less_EX: "(0 < n) = (EX m. n = Suc m)"
by (induct_tac n, auto)

lemma in_set_nth: "n:set s = (EX i. i<length s & n = s!i)"
apply (induct_tac s, auto)
apply (auto simp add: less_Suc)
done

lemma list_length_more_one: "(Suc 0 < length s) = (s ~= [] & tl s ~= [])"
by (induct_tac s, auto)

(* ------------------------------------------------- *
               lemmas on line and circ
 * ------------------------------------------------- *)

(* [] *)

lemma allEven_nil[simp]: "allEven []"
by (simp add: allEven_def)

lemma lineNext_nil_iff[simp]: "(lineNext s x = []) = (s = [])"
by (induct_tac s, auto)

lemma circNext_nil_iff[simp]: "(circNext s = []) = (s = [])"
by (simp add: circNext_def)

lemma tl_lineNext_nil_iff[simp]: "(tl (lineNext s x) = []) = (tl s = [])"
by (induct_tac s, auto)

lemma tl_circNext_nil_iff[simp]: "(tl (circNext s) = []) = (tl s = [])"
by (simp add: circNext_def)

lemma circNext_nil[simp]: "circNext [] = []"
by (simp)

lemma circNexts_nil_iff[simp]: "ALL s. (circNexts N s = []) = (s = [])"
by (induct_tac N, auto)

lemma circNexts_nil[simp]: "ALL s. (circNexts N [] = [])"
by (induct_tac N, auto)

(* length *)

lemma length_lineNext[simp]: "length (lineNext s x) = length s"
by (induct_tac s, auto)

lemma length_circNext[simp]: "length (circNext s) = length s"
by (simp add: circNext_def)

lemma length_circNexts[simp]: "ALL s. length (circNexts N s) = length s"
by (induct_tac N, auto)

(* even *)

lemma even_fill: "even (fill n)"
by (auto simp add: allEven_def fill_def)

lemma fill_div_times[simp]: "fill n div 2 * 2 = fill n"
apply (insert even_fill[of n])
apply (simp add: even_EX)
(* apply (force) *)
done

lemma lineNext_even[simp]: "allEven (lineNext s nn)"
apply (induct_tac s)
apply (auto simp add: allEven_def fill_def)
done

lemma circNext_even[simp]: "allEven (circNext s)"
by (simp add: circNext_def)

lemma circNexts_even_lm: "ALL s. allEven s --> allEven (circNexts N s)"
by (induct_tac N, auto)

lemma circNexts_even[simp]: "allEven s ==> allEven (circNexts N s)"
by (simp add: circNexts_even_lm)

(* sum *)

lemma circNexts_sum:
   "ALL s. circNexts (N1 + N2) s = circNexts N1 (circNexts N2 s)"
by (induct_tac N2, auto)

(* ------------------------------------------------- *
               lemmas on min and max
 * ------------------------------------------------- *)

(* max and min *)

lemma maxList_max[simp]: "ALL n:set s. n <= maxList s"
by (induct_tac s, auto)

lemma maxList_max_nth[simp]: "ALL i. i<length s --> s!i <= maxList s"
by (induct_tac s, auto)

lemma minList_min[simp]: "ALL n:set s. minList s <= n"
by (induct_tac s, auto)

lemma maxList_min_nth[simp]: "ALL i. i<length s --> minList s <= s!i"
by (induct_tac s, auto)

(* exist *)

lemma maxList_exist: "s ~= [] --> (maxList s : set s)"
by (induct_tac s, auto)

lemma maxList_exist_nth: "s ~= [] --> (EX i. i<length s & s!i = maxList s)"
by (induct_tac s, auto)

lemma minList_exist: "s ~= [] --> (minList s : set s)"
by (induct_tac s, auto)

lemma minList_exist_nth: "s ~= [] --> (EX i. i<length s & s!i = minList s)"
by (induct_tac s, auto)

(* basic *)

lemma minList_le_maxList: "minList s <= maxList s"
by (induct_tac s, auto)

lemma maxList_single[simp]: "maxList[n] = n"
by (simp)

lemma minList_single[simp]: "minList[n] = n"
by (simp)

lemma minList_le_forall:
  "t ~= [] --> ((m <= minList t) = (ALL n:(set t). m<=n))"
by (induct_tac t, auto)

lemma minList_less_forall:
  "t ~= [] --> ((m < minList t) = (ALL n:(set t). m<n))"
by (induct_tac t, auto)

lemma maxList_le_forall:
  "(maxList t <= m) = (ALL n:set t. n <= m)"
by (induct_tac t, auto)

lemma maxList_less_forall:
  "t ~= [] --> (maxList t < m) = (ALL n:set t. n < m)"
by (induct_tac t, auto)

(* fill *)

lemma even_le_fill[simp]: "even n ==> (fill m <= n) = (m <= n)"
apply (simp add: fill_def)
apply (simp add: even_EX)
apply (elim conjE exE)
apply (auto)
apply (drule_tac x="ma" in spec)
apply (auto)
done

lemma even_fill_le: "n <= m ==> (n <= fill m)"
by (simp add: fill_def)

lemma even_fill_less[simp]: "even n ==> (n < fill m) = (n < m)"
apply (simp add: fill_def)
apply (simp add: even_EX)
apply (elim conjE exE)
apply (auto)
apply (drule_tac x="ma" in spec)
apply (auto)
done

(* even *)

lemma allEven_maxList[simp]: "(ALL s:set s. even s) ==> even (maxList s)"
apply (case_tac "s=[]", simp)
apply (insert maxList_exist[of s], simp)
done

lemma allEven_minList[simp]: "(ALL s:set s. even s) ==> even (minList s)"
apply (case_tac "s=[]", simp)
apply (insert minList_exist[of s], simp)
done

lemma alleven_hd: "allEven (n#s) = (even n & allEven(s))"
by (simp add: allEven_def)

lemma allEven_div[simp]: "[| s ~= [] ; allEven s |] ==> 2 * (hd s div 2) = hd s"
apply (simp add: allEven_def even_EX)
(*
apply (drule_tac x="hd s" in bspec)
apply (auto)
*)
done

lemma allEven_hd: "[| s ~= [] ; allEven s |] ==> even (hd s)"
by (auto simp add: allEven_def)

(* stable *)

lemma stable_min_max:
  "stableList s = (minList s = maxList s)"
apply (simp add: stableList_def)
apply (rule)

 (* => *)
 apply (rule order_antisym)
 apply (simp add: minList_le_maxList)
 apply (simp only: maxList_le_forall)
 apply (force)

 (* <= *)
 apply (intro ballI)
 apply (erule order_antisymE)
  apply (simp only: maxList_le_forall)
  apply (drule_tac x="n" in bspec)
  apply (simp)
  apply (rule order_antisym)
  apply (simp_all)
done

lemma stable_lineNext_lm:
  "(ALL n:set s. n=2*N) --> (lineNext s N = s)"
apply (induct_tac s)
apply (simp)
apply (simp add: allEven_def)
apply (auto simp add: even_EX)
apply (simp add: fill_def)
apply (drule_tac x="hd list" in bspec)
apply (simp_all add: fill_def)
done

lemma stable_lineNext:
  "[| allEven s ; stableList s |] ==> lineNext s (hd s div 2) = s"
apply (case_tac "s=[]", simp)
apply (insert stable_lineNext_lm[of s "(minList s) div 2"])
(* modified for Isabelle 2016 *)
apply (drule mp)
apply (simp add: allEven_def stableList_def)
apply (simp add: allEven_def stableList_def)
apply (auto simp add: even_EX)
apply (rotate_tac 1)
apply (drule_tac x="hd s" in bspec, simp)
apply (simp)
done

lemma stable_circNext:
  "[| allEven s ; stableList s |] ==> circNext s = s"
by (simp add: circNext_def stable_lineNext)

lemma stable_circNexts:
  "[| allEven s ; stableList s |] ==> circNexts N s = s"
apply (induct_tac N)
by (simp_all add: stable_circNext)

(* howMany *)

lemma howMany_zero:
   "(howMany m s = 0) = (ALL n:(set s). m ~= n)"
by (induct_tac s, auto)

lemma less_minList_howMany_zero:
   "[| s ~= [] ; M < minList s |] ==> howMany M s = 0"
apply (simp add: howMany_zero)
apply (simp add: minList_less_forall)
apply (auto)
done

(* makeStableList *)

lemma makeStableList_nil[simp]: "(makeStableList l n = []) = (l=0)"
by (induct_tac l, auto)

lemma tl_makeStableList_nil[simp]: "(tl (makeStableList l n) = []) = (l <= Suc 0)"
by (induct_tac l, auto)

lemma makeStableList_hd[simp]: "0<l --> hd (makeStableList l n) = n"
by (induct_tac l, auto)

lemma set_makeStableList[simp]: "0<l --> set (makeStableList l n) = {n}"
by (induct_tac l, auto)

lemma stableList_makeStableList_lm: "stableList (makeStableList l n)"
by (induct_tac l, auto simp add: stableList_def)

lemma stableList_makeStableList[simp]:
  "s = makeStableList l n ==> stableList s"
by (simp add: stableList_makeStableList_lm)

lemma allEven_makeStableList[simp]: "even n ==> allEven (makeStableList l n)"
by (induct_tac l, auto simp add: allEven_def)

lemma makeStableList_hd_stableList_if:
   "ALL s. (length s = l & stableList s) --> s = makeStableList l (hd s)"
apply (induct_tac l, auto)
apply (case_tac "s=[]", simp)
apply (auto simp add: not_nil_EX)
apply (case_tac "t=[]", simp)
apply (auto simp add: not_nil_EX stableList_def)
apply (drule_tac x="a # ta" in spec)
apply (auto simp add: stableList_def)
done

lemma makeStableList_hd_stableList_only_if:
   "ALL s. s=makeStableList l (hd s) --> length s = l"
apply (induct_tac l)
apply (simp)
apply (intro allI impI)
apply (simp)
apply (case_tac "s=[]", simp)
apply (simp add: not_nil_EX)
apply (elim conjE exE)
apply (drule_tac x="t" in spec)
apply (simp)
apply (drule mp)
apply (case_tac "n=0", simp)
apply (simp_all)
done

lemma makeStableList_hd_stableList:
   "(s=makeStableList l (hd s)) = (length s = l & stableList s)"
apply (rule)
apply (simp add: makeStableList_hd_stableList_only_if)
apply (simp add: makeStableList_hd_stableList_if)
done

(* ------------------------------------------------- *
             lemmas on line, min and max
 * ------------------------------------------------- *)

(* line max <= *)

lemma lineNext_max_le_lm:
  "ALL n.
   (s ~= [] & allEven s & even M & (ALL n:set s. n <= M) & 2*nn <= M &
    n:set (lineNext s nn))
    --> n <= M"
apply (induct_tac s)
apply (simp)

apply (intro allI ballI impI)
apply (simp)
apply (case_tac "list = []")
 apply (simp)
 apply (simp add: even_EX allEven_def)
 apply (force)

 apply (simp add: allEven_def even_EX)
 apply (elim disjE conjE exE)
  apply (rotate_tac 1)
  apply (drule_tac x="hd list" in bspec, simp)
  apply (drule_tac x="hd list" in bspec, simp)
  apply (auto)
done

lemma lineNext_max_le:
   "[| s ~= [] ; allEven s ; even M ; ALL n:set s. n <= M ; 2*nn <= M ;
       n:set (lineNext s nn) |]
    ==> n <= M"
apply (insert lineNext_max_le_lm[of s M nn])
apply (drule_tac x="n" in spec)
apply (drule mp)
apply (simp_all)
done

lemma lineNext_maxList_le:
   "[| s ~= [] ; allEven s ; 2*nn <= maxList s ; n:set (lineNext s nn) |]
    ==> n <= maxList s"
apply (rule lineNext_max_le)
apply (simp_all add: allEven_def)
done

(* line min <= *)

lemma lineNext_min_le_lm:
  "ALL n.
   (s ~= [] & allEven s & even M & (ALL n:set s. M <= n) & M <= 2*nn &
    n:set (lineNext s nn))
   --> M <= n"
apply (induct_tac s)
apply (simp)

apply (intro allI ballI impI)
apply (simp)
apply (case_tac "list = []")
 apply (simp)
 apply (simp add: even_EX allEven_def)
 apply (elim conjE exE)
 apply (simp add: fill_def)

 apply (simp add: allEven_def even_EX)
 apply (elim disjE conjE exE)
  apply (rotate_tac 1)
  apply (drule_tac x="hd list" in bspec, simp)
  apply (drule_tac x="hd list" in bspec, simp)
  apply (auto)
  apply (simp add: fill_def)
done

lemma lineNext_min_le:
   "[| s ~= [] ; allEven s ; even M ; ALL n:set s. M <= n ; M <= 2*nn ;
       n:set (lineNext s nn) |]
    ==> M <= n"
apply (insert lineNext_min_le_lm[of s M nn])
apply (drule_tac x="n" in spec)
apply (drule mp)
apply (simp_all)
done

lemma lineNext_minList_le:
   "[| s ~= [] ; allEven s ; minList s <= 2*nn ;
       n:set (lineNext s nn) |]
    ==> minList s <= n"
apply (rule lineNext_min_le)
apply (simp_all add: allEven_def)
done

(* line min < *)

lemma lineNext_min_less_lm:
  "ALL i.
   (s ~= [] & allEven s & even M & (ALL n:set s. M <= n) & M <= 2*nn &
    Suc i < length s & s!i = M & M < s!(Suc i))
    --> M < (lineNext s nn) ! i"
apply (induct_tac s)
apply (simp)
apply (intro ballI allI impI)
apply (elim conjE exE)
apply (simp)
apply (insert nat_zero_or_Suc)
apply (rotate_tac -1)
apply (drule_tac x="i" in spec)
apply (elim disjE conjE exE)
apply (simp add: nth_hd)
apply (simp add: allEven_def even_EX)
apply (elim conjE exE)
apply (simp)
apply (rotate_tac -2)
apply (drule_tac x="hd list" in bspec, simp)
apply (elim conjE exE)
apply (simp)

apply (auto simp add: allEven_def)
done

lemma lineNext_min_less:
  "[| s ~= [] ; allEven s ; even M ; ALL n:set s. M <= n ; M <= 2*nn ;
      Suc i < length s ; s!i = M ; M < s!(Suc i) |]
    ==> M < (lineNext s nn) ! i"
by (insert lineNext_min_less_lm[of s M nn], simp)

lemma lineNext_minList_less:
  "[| s ~= [] ; allEven s ; minList s <= 2*nn ;
      Suc i < length s ; s!i = minList s ; minList s < s!(Suc i) |]
    ==> minList s < (lineNext s nn) ! i"
apply (rule lineNext_min_less)
apply (simp_all add: allEven_def)
done

(* last *)

lemma lineNext_min_less_last_sublm:
  "s ~= [] & last s < a --> last s < last (lineNext s a)"
by (induct_tac s, auto simp add: fill_def)

lemma lineNext_min_less_last_lm:
  "(s ~= [] & allEven s & (ALL n:set s. M <= n)
    & M = last s & M < 2*nn )
        --> last s < last (lineNext s nn)"
apply (induct_tac s)
apply (simp_all add: lineNext_min_less_last_sublm)
apply (intro conjI impI)
apply (simp_all)
apply (simp add: allEven_def even_EX)
apply (elim conjE exE)
apply (simp add: fill_def)
apply (auto simp add: allEven_def)
done

lemma lineNext_min_less_last:
  "[| s ~= [] ; allEven s ; ALL n:set s. M <= n ;
      last s = M ; M < 2*nn |]
   ==> M < last (lineNext s nn)"
by (insert lineNext_min_less_last_lm[of s M nn], simp)

lemma lineNext_minList_less_last:
  "[| s ~= [] ; allEven s ; last s = minList s ; minList s < 2*nn |]
   ==> minList s < last (lineNext s nn)"
by (simp add: lineNext_min_less_last)

(* other less *)

lemma lineNext_min_other_less_lm:
  "ALL i.
   (s ~= [] & allEven s & even M & (ALL n:set s. M <= n) & M <= 2*nn &
    i < length s & M < s!i)
    --> M < (lineNext s nn) ! i"
apply (induct_tac s)
apply (simp_all)
apply (intro conjI impI)
apply (simp add: fill_def)
apply (simp add: allEven_def even_EX)
apply (elim conjE exE)
apply (simp)

apply (intro allI impI)
apply (simp)
apply (insert nat_zero_or_Suc)
apply (rotate_tac -1)
apply (drule_tac x="i" in spec)
apply (elim disjE conjE exE)
apply (simp)
apply (simp add: allEven_def even_EX)
apply (elim conjE exE)
apply (rotate_tac -3)
apply (drule_tac x="hd list" in bspec, simp)
apply (drule_tac x="hd list" in bspec, simp)
apply (elim conjE exE)
apply (simp)

apply (simp add: allEven_def)
done

lemma lineNext_min_other_less:
  "[| s ~= [] ; allEven s ; even M ; ALL n:set s. M <= n ; M <= 2*nn ;
      i < length s ; M < s!i |]
   ==> M < (lineNext s nn) ! i"
by (simp add: lineNext_min_other_less_lm)

lemma lineNext_minList_other_less:
  "[| s ~= [] ; allEven s ; minList s <= 2*nn ;
      i < length s ; minList s < s!i |]
   ==> minList s < (lineNext s nn) ! i"
apply (rule lineNext_min_other_less)
apply (simp_all add: allEven_def)
done

(* ------------------------------------------------- *
              lemmas on circ, min and max
 * ------------------------------------------------- *)

(* max le *)

lemma circNext_maxList_le:
  "[| s ~= [] ; allEven s ; n:set (circNext s) |]
   ==> n <= maxList s"
apply (simp add: circNext_def)
apply (rule lineNext_maxList_le[of _ "(hd s div 2)"])
apply (simp_all)
done

lemma maxList_circNext_le:
  "[| s ~= [] ; allEven s |]
   ==> maxList (circNext s) <= maxList s"
apply (simp add: maxList_le_forall)
apply (auto simp add: circNext_maxList_le)
done

(* min le *)

lemma circNext_minList_le:
  "[| s ~= [] ; allEven s ; n:set (circNext s) |]
   ==> minList s <= n"
apply (simp add: circNext_def)
apply (rule lineNext_minList_le[of _ "(hd s div 2)"])
apply (simp_all)
done

lemma minList_circNext_le:
  "[| s ~= [] ; allEven s |]
   ==> minList s <= minList (circNext s)"
apply (simp add: minList_le_forall)
apply (auto simp add: circNext_minList_le)
done

(* min less *)

lemma circNext_minList_less:
  "[| s ~= [] ; allEven s ;
      i<length s ; s!i=minList s ;
      (Suc i = length s & minList s < hd s) |
      (Suc i < length s & minList s < s ! Suc i) |]
   ==> minList s < (circNext s)!i"
apply (simp add: circNext_def)
apply (case_tac "Suc i < length s")
apply (insert lineNext_minList_less[of s "(hd s div 2)" i])
apply (simp add: allEven_def even_EX)

apply (case_tac "Suc i = length s")
apply (insert lineNext_minList_less_last[of s "(hd s div 2)"])
apply (simp add: nth_last)

apply (auto)
done

lemma circNext_minList_other_less:
  "[| s ~= [] ; allEven s ; i<length s ; minList s < s!i |]
   ==> minList s < (circNext s)!i"
apply (simp add: circNext_def)
apply (rule lineNext_minList_other_less)
apply (auto)
done

(* ------------------------------------------------- *
            lemmas on circNexts, min, and max
 * ------------------------------------------------- *)

lemma maxList_circNexts_le_lm:
  "ALL s. (s ~= [] & allEven s)
    --> maxList (circNexts N s) <= maxList s"
apply (induct_tac N)
apply (auto)
apply (drule_tac x="circNext s" in spec)
apply (simp)
apply (rule order_trans)
apply (simp)
apply (simp add: maxList_circNext_le)
done

lemma maxList_circNexts_le:
  "[| s ~= [] ; allEven s |]
   ==> maxList (circNexts N s) <= maxList s"
by (simp add: maxList_circNexts_le_lm)

lemma minList_circNexts_le_lm:
  "ALL s. (s ~= [] & allEven s)
    --> minList s <= minList (circNexts N s)"
apply (induct_tac N)
apply (auto)
apply (drule_tac x="circNext s" in spec)
apply (simp)
apply (rule order_trans)
apply (simp_all)
apply (simp add: minList_circNext_le)
done

lemma minList_circNexts_le:
  "[| s ~= [] ; allEven s |]
   ==> minList s <= minList (circNexts N s)"
by (simp add: minList_circNexts_le_lm)

(* ----------------------------------------------------------- *
           to get the assumption of circ_minList_less
 * ----------------------------------------------------------- *)

declare minList.simps [simp del]

lemma unstable_exists_diff_one_lm:
  "ALL j. (j<length s & minList s < s!j) -->
   (EX i. i<length s & s ! i = minList s &
         ((Suc i = length s & minList s < hd s) |
          (Suc i < length s & minList s < s ! Suc i)))"
apply (induct_tac s)
apply (simp)

apply (intro allI impI)
apply (simp add: less_Suc)
apply (elim disjE conjE exE)

 (* 1 *)
 apply (subgoal_tac "minList (a # list) = minList list")      (* sub1 *)
  apply (simp)
  apply (case_tac "EX j. j<length list & minList list < list ! j")
   apply (simp)
   apply (elim exE)
   apply (rule_tac x="Suc i" in exI)
   apply (simp)
   apply (case_tac "list=[]")
    apply (force)
    apply (force)

   (* ~ EX j. j<length list & minList list < list ! j *)

   apply (rule_tac x="length list " in exI)
   apply (simp)
   apply (case_tac "list=[]", simp)
   apply (rule conjI)
    apply (rule disjI2)
    apply (rule_tac x="length list - 1" in exI)
    apply (force)
    apply (subgoal_tac "EX i. length list = Suc i")   (* sub2 *)
    apply (elim exE)
     apply (simp)
     apply (drule_tac x="i" in spec)
     apply (simp)

     apply (simp add: not_less)           (* <--- Isabelle 2008 *)
     (* apply (fold le_def)                  <--- Isabelle 2005 *)
     apply (rule le_antisym)              (* <--- Isabelle 2009-1 *)
     (* apply (rule le_anti_sym)             <--- Isabelle 2009 *)
     apply (simp)
     apply (simp)
   (* sub2 *)
    apply (rule_tac x="length list - 1" in exI)
    apply (simp)
 (* sub1 *)
  apply (case_tac "list=[]")
  apply (simp add: minList.simps)
  apply (simp add: minList.simps)
  apply (force)

 (* 2 *)
 apply (case_tac "minList list < a")
  apply (subgoal_tac "minList (a # list) = minList list")      (* sub3 *)
   apply (drule mp, force)
   apply (elim conjE exE)
   apply (rule_tac x="Suc i" in exI)
   apply (force)

 (* sub3 *)
  apply (case_tac "list=[]")
  apply (simp add: minList.simps)
  apply (simp add: minList.simps)

 apply (case_tac "minList list = a")
  apply (subgoal_tac "minList (a # list) = minList list")      (* sub4 *)
   apply (drule mp, force)
   apply (elim disjE conjE exE)
    apply (rule_tac x="0" in exI)
    apply (case_tac "list=[]")
    apply (simp)
    apply (simp add: nth_hd)

    apply (rule_tac x="Suc i" in exI)
    apply (simp)

 (* sub4 *)
  apply (case_tac "list=[]")
  apply (simp add: minList.simps)
  apply (simp add: minList.simps)

 apply (case_tac "a < minList list")
  apply (subgoal_tac "minList (a # list) = a")      (* sub5 *)
   apply (rule_tac x="0" in exI)
   apply (case_tac "list=[]")
   apply (simp)
   apply (simp add: nth_hd)
   apply (rotate_tac -3)
   apply (erule contrapos_pp)
   apply (simp add: not_less)           (* <--- Isabelle 2008 *)
 (* apply (fold le_def)                  <--- Isabelle 2005 *)
   apply (subgoal_tac "minList list <= hd list")
   apply (rule order_trans)
   apply (simp (no_asm_simp))
   apply (simp)
   apply (simp)

 (* sub5 *)
  apply (case_tac "list=[]")
  apply (simp add: minList.simps)
  apply (simp add: minList.simps)

apply (simp)
done

declare minList.simps [simp add]

lemma unstable_exists_diff_one:
  "[| j<length s ; minList s < s!j |] ==>
   EX i. i<length s & s ! i = minList s &
         ((Suc i = length s & minList s < hd s) |
          (Suc i < length s & minList s < s ! Suc i))"
apply (insert unstable_exists_diff_one_lm[of s])
apply (drule_tac x="j" in spec)
apply (simp)
done

(* --- to increase the minList --- *)

lemma unstable_circNext_minList_less:
  "[| s ~= [] ; allEven s ; j < length s & minList s < s!j |]
   ==> EX i. i < length s & s!i=minList s & minList s < (circNext s)!i"
apply (insert unstable_exists_diff_one[of j s])
apply (simp)
apply (elim conjE exE)
apply (rule_tac x="i" in exI)
apply (simp add: circNext_minList_less)
done

(* ----------------------------------------------------------- *
                to decrease howMany (minList s)
 * ----------------------------------------------------------- *)

lemma Suc_length_list_EX:
 "(Suc (length s) = length t) = (EX b u. t = b#u & length s = length u)"
apply (induct_tac t)
apply (auto)
done

(*** howMany <= ***)

lemma howMany_le_lm:
  "ALL s t j. (length s = length t &
              (ALL i. (i<length t & M ~= s!i) --> M ~= t!i))
   --> howMany M t <= howMany M s"
apply (rule)
apply (induct_tac s)
apply (simp)
apply (intro allI impI)
apply (simp add: Suc_length_list_EX)
apply (elim conjE exE)
apply (drule_tac x="u" in spec)
apply (auto)
done

lemma howMany_le:
  "[| length s = length t ;
      !!i. [| i<length t ; M ~= s!i |] ==> M ~= t!i |]
   ==> howMany M t <= howMany M s"
by (simp add: howMany_le_lm)

(*** howMany < ***)

lemma howMany_less_lm:
  "ALL s t j. (length s = length t &
              (ALL i. (i<length t & M ~= s!i) --> M ~= t!i) &
               j < length t & s!j=M & M<t!j)
   --> howMany M t < howMany M s"
apply (rule)
apply (induct_tac s)
apply (simp)
apply (intro allI impI)
 apply (simp add: Suc_length_list_EX)
 apply (elim conjE exE)
 apply (intro conjI impI)

 (* new hd s = M *)
  apply (case_tac "j=0")
   apply (simp add: less_Suc_eq_le)
   apply (rule howMany_le)
   apply (simp)
   apply (drule_tac x="Suc i" in spec)
   apply (simp)

  (* j~=0 *)
   apply (drule_tac x="u" in spec)
   apply (drule mp)
    apply (simp)
    apply (intro conjI allI impI)
     apply (drule_tac x="Suc i" in spec)
     apply (simp)

     apply (simp add: zero_less_EX)
     apply (elim exE)
     apply (rule_tac x="m" in exI)
     apply (simp)
    apply (force)

 (* new hd s ~= M *)
 apply (simp add: less_Suc)
 apply (elim disjE conjE exE, simp)
 apply (drule_tac x="u" in spec)

 apply (drule mp)
  apply (simp)
   apply (intro conjI allI impI)
   apply (drule_tac x="Suc i" in spec)
   apply (simp)

   apply (rule_tac x="m" in exI)
   apply (simp)
  apply (force)
done

lemma howMany_less:
  "[| length s = length t ;
      ALL i. (i<length t & M ~= s!i) --> M ~= t!i ;
      EX j. j < length t & s!j=M & M<t!j |]
   ==> howMany M t < howMany M s"
apply (insert howMany_less_lm[of M])
apply (drule_tac x="s" in spec)
apply (drule_tac x="t" in spec)
apply (erule exE)
apply (rotate_tac -2)
apply (drule_tac x="j" in spec)
apply (simp)
done

(*** howMany circNext ***)

lemma howMany_circNext_less:
  "[| s ~= [] ; allEven s ; j < length s ; minList s < s!j |]
   ==> howMany (minList s) (circNext s) < howMany (minList s) s"
apply (rule howMany_less)
apply (simp_all)
apply (intro allI impI)
 apply (elim conjE)
 apply (subgoal_tac "minList s < circNext s ! i", simp)
 apply (rule circNext_minList_other_less)
 apply (simp_all)
 apply (simp add: order_less_le)
 apply (rule unstable_circNext_minList_less[of s j])
 apply (simp_all)
done

(* ----------------------------------------------------------- *
                     to increase minList
 * ----------------------------------------------------------- *)

lemma minList_circNext_less_lm:
  "ALL k s. (s ~= [] & allEven s & i < length s & minList s < s!i &
           howMany (minList s) s <= k)
   --> (EX N. minList s < minList (circNexts N s))"
apply (rule)
apply (induct_tac k)
apply (intro allI impI)

(* k=0 *)
 apply (rule_tac x="0" in exI)
 apply (simp add: howMany_zero)
 apply (elim conjE)
 apply (drule_tac x="minList s" in bspec)
 apply (simp_all add: minList_exist)

(* step *)
apply (intro allI impI)
apply (drule_tac x="circNext s" in spec)
apply (simp)

 apply (case_tac "minList (circNext s) = minList s ")
 apply (drule mp)
  apply (simp)
  apply (elim conjE exE)
  apply (simp add: circNext_minList_other_less)
  apply (subgoal_tac "howMany (minList s) (circNext s) < howMany (minList s) s")
   apply (force)
  apply (simp add: howMany_circNext_less)
 apply (simp)
 apply (elim conjE exE)
 apply (rule_tac x="Suc N" in exI)
 apply (simp)

 (* minList (circNext s) ~= minList s *)
apply (rule_tac x="Suc 0" in exI)
apply (simp add: order_less_le minList_circNext_le)
done

lemma minList_circNext_less:
  "[| s ~= [] ; allEven s ; i < length s ; minList s < s!i |]
   ==> (EX N. minList s < minList (circNexts N s))"
apply (insert minList_circNext_less_lm[of i])
apply (erule exchange_forall_orderE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="howMany (minList s) s" in spec)
apply (simp)
done

(* ----------------------------------------------------------- *
                    eventually stable
 * ----------------------------------------------------------- *)

lemma circNexts_eventually_stable_lm:
  "ALL k s i.
   (s ~= [] & allEven s & i < length s & minList s < s!i &
    maxList s <= minList s + k)
   --> (EX N. stableList(circNexts N s))"
apply (simp add: stable_min_max)
apply (rule)
apply (induct_tac k)

(* base *)
 apply (intro allI impI)
 apply (rule_tac x="0" in exI)
 apply (rule order_antisym)
 apply (simp add: minList_le_maxList)
 apply (force)

(* step *)
 apply (intro allI impI)
 apply (subgoal_tac "(EX N. minList s < minList (circNexts N s))")
 apply (elim exE conjE)
 apply (case_tac "N=0", simp)
 apply (case_tac "EX i. i < length s & minList (circNexts N s) < circNexts N s ! i")
  apply (elim exE conjE)
  apply (drule_tac x="circNexts N s" in spec)
  apply (simp)

  apply (drule mp)
   apply (rule_tac x="ia" in exI)
   apply (simp)
   apply (rule order_trans)
    apply (rule maxList_circNexts_le)
    apply (simp_all)
  apply (erule exE)
  apply (rule_tac x="Na + N" in exI)
  apply (simp add: circNexts_sum)

 (* ~ EX i. i < length s & minList (circNexts N s) < circNexts N s ! i *)
 apply (simp add: not_less)           (* <--- Isabelle 2008 *)
(* apply (fold le_def)                  <--- Isabelle 2005 *)
 apply (rule_tac x="N" in exI)
 apply (rule order_antisym)
  apply (simp add: minList_le_maxList)
  apply (simp add: maxList_le_forall)
  apply (intro ballI impI)
  apply (simp add: in_set_nth)
  apply (elim conjE exE)
  apply (rotate_tac -3)
  apply (drule_tac x="ia" in spec)
  apply (simp)

apply (elim conjE exE)
apply (simp add: minList_circNext_less)
done

lemma circNexts_eventually_stable:
  "[| s ~= [] ; allEven s |] ==> EX N. stableList(circNexts N s)"

apply (case_tac "ALL i. i < length s --> minList s = s!i")
 apply (rule_tac x="0" in exI)
 apply (simp add: stable_min_max)
 apply (rule order_antisym)
  apply (simp add: minList_le_maxList)
  apply (simp add: maxList_le_forall)
  apply (intro ballI impI)
  apply (simp add: in_set_nth)
  apply (force)

 (* ~ (ALL i. i < length s --> minList s = s!i) *)
apply (simp)
apply (elim conjE exE)
apply (insert circNexts_eventually_stable_lm)
apply (erule exchange_forall_orderE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="maxList s - minList s" in spec)
apply (drule_tac x="i" in spec)
apply (simp add: minList_le_maxList)
apply (simp add: order_less_le)
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_83
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
"zip (nil2) z = nil2"
| "zip (cons2 z2 x2) (nil2) = nil2"
| "zip (cons2 z2 x2) (cons2 x3 x4) =
     cons2 (pair2 z2 x3) (zip x2 x4)"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

fun len :: "'a list => Nat" where
"len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

theorem property0 :
  "((zip (x xs ys) zs) =
      (x (zip xs (take (len xs) zs)) (zip ys (drop (len xs) zs))))"
  oops

end