(*  Title:      HOL/Groups.thy
    Author:     Gertrud Bauer
    Author:     Steven Obua
    Author:     Lawrence C Paulson
    Author:     Markus Wenzel
    Author:     Jeremy Avigad
*)

section \<open>Groups, also combined with orderings\<close>

theory Groups
  imports Orderings
begin

subsection \<open>Dynamic facts\<close>

named_theorems ac_simps "associativity and commutativity simplification rules"
  and algebra_simps "algebra simplification rules for rings"
  and algebra_split_simps "algebra simplification rules for rings, with potential goal splitting"
  and field_simps "algebra simplification rules for fields"
  and field_split_simps "algebra simplification rules for fields, with potential goal splitting"

text \<open>
  The rewrites accumulated in \<open>algebra_simps\<close> deal with the classical
  algebraic structures of groups, rings and family. They simplify terms by
  multiplying everything out (in case of a ring) and bringing sums and
  products into a canonical form (by ordered rewriting). As a result it
  decides group and ring equalities but also helps with inequalities.

  Of course it also works for fields, but it knows nothing about
  multiplicative inverses or division. This is catered for by \<open>field_simps\<close>.

  Facts in \<open>field_simps\<close> multiply with denominators in (in)equations if they
  can be proved to be non-zero (for equations) or positive/negative (for
  inequalities). Can be too aggressive and is therefore separate from the more
  benign \<open>algebra_simps\<close>.

  Collections \<open>algebra_split_simps\<close> and \<open>field_split_simps\<close>
  correspond to \<open>algebra_simps\<close> and \<open>field_simps\<close>
  but contain more aggresive rules that may lead to goal splitting.
\<close>

subsection \<open>Abstract structures\<close>

text \<open>
  These locales provide basic structures for interpretation into bigger
  structures; extensions require careful thinking, otherwise undesired effects
  may occur due to interpretation.
\<close>

locale semigroup =
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<^bold>*" 70)
  assumes assoc [ac_simps]: "a \<^bold>* b \<^bold>* c = a \<^bold>* (b \<^bold>* c)"

locale abel_semigroup = semigroup +
  assumes commute [ac_simps]: "a \<^bold>* b = b \<^bold>* a"
begin

lemma left_commute [ac_simps]: "b \<^bold>* (a \<^bold>* c) = a \<^bold>* (b \<^bold>* c)"
proof -
  have "(b \<^bold>* a) \<^bold>* c = (a \<^bold>* b) \<^bold>* c"
    by (simp only: commute)
  then show ?thesis
    by (simp only: assoc)
qed

end

locale monoid = semigroup +
  fixes z :: 'a ("\<^bold>1")
  assumes left_neutral [simp]: "\<^bold>1 \<^bold>* a = a"
  assumes right_neutral [simp]: "a \<^bold>* \<^bold>1 = a"

locale comm_monoid = abel_semigroup +
  fixes z :: 'a ("\<^bold>1")
  assumes comm_neutral: "a \<^bold>* \<^bold>1 = a"
begin

sublocale monoid
  by standard (simp_all add: commute comm_neutral)

end

locale group = semigroup +
  fixes z :: 'a ("\<^bold>1")
  fixes inverse :: "'a \<Rightarrow> 'a"
  assumes group_left_neutral: "\<^bold>1 \<^bold>* a = a"
  assumes left_inverse [simp]:  "inverse a \<^bold>* a = \<^bold>1"
begin

lemma left_cancel: "a \<^bold>* b = a \<^bold>* c \<longleftrightarrow> b = c"
proof
  assume "a \<^bold>* b = a \<^bold>* c"
  then have "inverse a \<^bold>* (a \<^bold>* b) = inverse a \<^bold>* (a \<^bold>* c)" by simp
  then have "(inverse a \<^bold>* a) \<^bold>* b = (inverse a \<^bold>* a) \<^bold>* c"
    by (simp only: assoc)
  then show "b = c" by (simp add: group_left_neutral)
qed simp

sublocale monoid
proof
  fix a
  have "inverse a \<^bold>* a = \<^bold>1" by simp
  then have "inverse a \<^bold>* (a \<^bold>* \<^bold>1) = inverse a \<^bold>* a"
    by (simp add: group_left_neutral assoc [symmetric])
  with left_cancel show "a \<^bold>* \<^bold>1 = a"
    by (simp only: left_cancel)
qed (fact group_left_neutral)

lemma inverse_unique:
  assumes "a \<^bold>* b = \<^bold>1"
  shows "inverse a = b"
proof -
  from assms have "inverse a \<^bold>* (a \<^bold>* b) = inverse a"
    by simp
  then show ?thesis
    by (simp add: assoc [symmetric])
qed

lemma inverse_neutral [simp]: "inverse \<^bold>1 = \<^bold>1"
  by (rule inverse_unique) simp

lemma inverse_inverse [simp]: "inverse (inverse a) = a"
  by (rule inverse_unique) simp

lemma right_inverse [simp]: "a \<^bold>* inverse a = \<^bold>1"
proof -
  have "a \<^bold>* inverse a = inverse (inverse a) \<^bold>* inverse a"
    by simp
  also have "\<dots> = \<^bold>1"
    by (rule left_inverse)
  then show ?thesis by simp
qed

lemma inverse_distrib_swap: "inverse (a \<^bold>* b) = inverse b \<^bold>* inverse a"
proof (rule inverse_unique)
  have "a \<^bold>* b \<^bold>* (inverse b \<^bold>* inverse a) =
    a \<^bold>* (b \<^bold>* inverse b) \<^bold>* inverse a"
    by (simp only: assoc)
  also have "\<dots> = \<^bold>1"
    by simp
  finally show "a \<^bold>* b \<^bold>* (inverse b \<^bold>* inverse a) = \<^bold>1" .
qed

lemma right_cancel: "b \<^bold>* a = c \<^bold>* a \<longleftrightarrow> b = c"
proof
  assume "b \<^bold>* a = c \<^bold>* a"
  then have "b \<^bold>* a \<^bold>* inverse a= c \<^bold>* a \<^bold>* inverse a"
    by simp
  then show "b = c"
    by (simp add: assoc)
qed simp

end

subsection \<open>Generic operations\<close>

class zero =
  fixes zero :: 'a  ("0")

class one =
  fixes one  :: 'a  ("1")

hide_const (open) zero one

lemma Let_0 [simp]: "Let 0 f = f 0"
  unfolding Let_def ..

lemma Let_1 [simp]: "Let 1 f = f 1"
  unfolding Let_def ..

setup \<open>
  Reorient_Proc.add
    (fn Const(\<^const_name>\<open>Groups.zero\<close>, _) => true
      | Const(\<^const_name>\<open>Groups.one\<close>, _) => true
      | _ => false)
\<close>

simproc_setup reorient_zero ("0 = x") = Reorient_Proc.proc
simproc_setup reorient_one ("1 = x") = Reorient_Proc.proc

typed_print_translation \<open>
  let
    fun tr' c = (c, fn ctxt => fn T => fn ts =>
      if null ts andalso Printer.type_emphasis ctxt T then
        Syntax.const \<^syntax_const>\<open>_constrain\<close> $ Syntax.const c $
          Syntax_Phases.term_of_typ ctxt T
      else raise Match);
  in map tr' [\<^const_syntax>\<open>Groups.one\<close>, \<^const_syntax>\<open>Groups.zero\<close>] end
\<close> \<comment> \<open>show types that are presumably too general\<close>

class plus =
  fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "+" 65)

class minus =
  fixes minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "-" 65)

class uminus =
  fixes uminus :: "'a \<Rightarrow> 'a"  ("- _" [81] 80)

class times =
  fixes times :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "*" 70)

subsection \<open>Semigroups and Monoids\<close>

class semigroup_add = plus +
  assumes add_assoc [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
    "(a + b) + c = a + (b + c)"
begin

sublocale add: semigroup plus
  by standard (fact add_assoc)

end

hide_fact add_assoc

class ab_semigroup_add = semigroup_add +
  assumes add_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
    "a + b = b + a"
begin

sublocale add: abel_semigroup plus
  by standard (fact add_commute)

declare add.left_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]

lemmas add_ac = add.assoc add.commute add.left_commute

end

hide_fact add_commute

lemmas add_ac = add.assoc add.commute add.left_commute

class semigroup_mult = times +
  assumes mult_assoc [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
    "(a * b) * c = a * (b * c)"
begin

sublocale mult: semigroup times
  by standard (fact mult_assoc)

end

hide_fact mult_assoc

class ab_semigroup_mult = semigroup_mult +
  assumes mult_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
    "a * b = b * a"
begin

sublocale mult: abel_semigroup times
  by standard (fact mult_commute)

declare mult.left_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]

lemmas mult_ac = mult.assoc mult.commute mult.left_commute

end

hide_fact mult_commute

lemmas mult_ac = mult.assoc mult.commute mult.left_commute

class monoid_add = zero + semigroup_add +
  assumes add_0_left: "0 + a = a"
    and add_0_right: "a + 0 = a"
begin

sublocale add: monoid plus 0
  by standard (fact add_0_left add_0_right)+

end

lemma zero_reorient: "0 = x \<longleftrightarrow> x = 0"
  by (fact eq_commute)

class comm_monoid_add = zero + ab_semigroup_add +
  assumes add_0: "0 + a = a"
begin

subclass monoid_add
  by standard (simp_all add: add_0 add.commute [of _ 0])

sublocale add: comm_monoid plus 0
  by standard (simp add: ac_simps)

end

class monoid_mult = one + semigroup_mult +
  assumes mult_1_left: "1 * a  = a"
    and mult_1_right: "a * 1 = a"
begin

sublocale mult: monoid times 1
  by standard (fact mult_1_left mult_1_right)+

end

lemma one_reorient: "1 = x \<longleftrightarrow> x = 1"
  by (fact eq_commute)

class comm_monoid_mult = one + ab_semigroup_mult +
  assumes mult_1: "1 * a = a"
begin

subclass monoid_mult
  by standard (simp_all add: mult_1 mult.commute [of _ 1])

sublocale mult: comm_monoid times 1
  by standard (simp add: ac_simps)

end

class cancel_semigroup_add = semigroup_add +
  assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
  assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"
begin

lemma add_left_cancel [simp]: "a + b = a + c \<longleftrightarrow> b = c"
  by (blast dest: add_left_imp_eq)

lemma add_right_cancel [simp]: "b + a = c + a \<longleftrightarrow> b = c"
  by (blast dest: add_right_imp_eq)

end

class cancel_ab_semigroup_add = ab_semigroup_add + minus +
  assumes add_diff_cancel_left' [simp]: "(a + b) - a = b"
  assumes diff_diff_add [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
    "a - b - c = a - (b + c)"
begin

lemma add_diff_cancel_right' [simp]: "(a + b) - b = a"
  using add_diff_cancel_left' [of b a] by (simp add: ac_simps)

subclass cancel_semigroup_add
proof
  fix a b c :: 'a
  assume "a + b = a + c"
  then have "a + b - a = a + c - a"
    by simp
  then show "b = c"
    by simp
next
  fix a b c :: 'a
  assume "b + a = c + a"
  then have "b + a - a = c + a - a"
    by simp
  then show "b = c"
    by simp
qed

lemma add_diff_cancel_left [simp]: "(c + a) - (c + b) = a - b"
  unfolding diff_diff_add [symmetric] by simp

lemma add_diff_cancel_right [simp]: "(a + c) - (b + c) = a - b"
  using add_diff_cancel_left [symmetric] by (simp add: ac_simps)

lemma diff_right_commute: "a - c - b = a - b - c"
  by (simp add: diff_diff_add add.commute)

end

class cancel_comm_monoid_add = cancel_ab_semigroup_add + comm_monoid_add
begin

lemma diff_zero [simp]: "a - 0 = a"
  using add_diff_cancel_right' [of a 0] by simp

lemma diff_cancel [simp]: "a - a = 0"
proof -
  have "(a + 0) - (a + 0) = 0"
    by (simp only: add_diff_cancel_left diff_zero)
  then show ?thesis by simp
qed

lemma add_implies_diff:
  assumes "c + b = a"
  shows "c = a - b"
proof -
  from assms have "(b + c) - (b + 0) = a - b"
    by (simp add: add.commute)
  then show "c = a - b" by simp
qed

lemma add_cancel_right_right [simp]: "a = a + b \<longleftrightarrow> b = 0"
  (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?Q
  then show ?P by simp
next
  assume ?P
  then have "a - a = a + b - a" by simp
  then show ?Q by simp
qed

lemma add_cancel_right_left [simp]: "a = b + a \<longleftrightarrow> b = 0"
  using add_cancel_right_right [of a b] by (simp add: ac_simps)

lemma add_cancel_left_right [simp]: "a + b = a \<longleftrightarrow> b = 0"
  by (auto dest: sym)

lemma add_cancel_left_left [simp]: "b + a = a \<longleftrightarrow> b = 0"
  by (auto dest: sym)

end

class comm_monoid_diff = cancel_comm_monoid_add +
  assumes zero_diff [simp]: "0 - a = 0"
begin

lemma diff_add_zero [simp]: "a - (a + b) = 0"
proof -
  have "a - (a + b) = (a + 0) - (a + b)"
    by simp
  also have "\<dots> = 0"
    by (simp only: add_diff_cancel_left zero_diff)
  finally show ?thesis .
qed

end

subsection \<open>Groups\<close>

class group_add = minus + uminus + monoid_add +
  assumes left_minus: "- a + a = 0"
  assumes add_uminus_conv_diff [simp]: "a + (- b) = a - b"
begin

lemma diff_conv_add_uminus: "a - b = a + (- b)"
  by simp

sublocale add: group plus 0 uminus
  by standard (simp_all add: left_minus)

lemma minus_unique: "a + b = 0 \<Longrightarrow> - a = b"
  by (fact add.inverse_unique)

lemma minus_zero: "- 0 = 0"
  by (fact add.inverse_neutral)

lemma minus_minus: "- (- a) = a"
  by (fact add.inverse_inverse)

lemma right_minus: "a + - a = 0"
  by (fact add.right_inverse)

lemma diff_self [simp]: "a - a = 0"
  using right_minus [of a] by simp

subclass cancel_semigroup_add
  by standard (simp_all add: add.left_cancel add.right_cancel)

lemma minus_add_cancel [simp]: "- a + (a + b) = b"
  by (simp add: add.assoc [symmetric])

lemma add_minus_cancel [simp]: "a + (- a + b) = b"
  by (simp add: add.assoc [symmetric])

lemma diff_add_cancel [simp]: "a - b + b = a"
  by (simp only: diff_conv_add_uminus add.assoc) simp

lemma add_diff_cancel [simp]: "a + b - b = a"
  by (simp only: diff_conv_add_uminus add.assoc) simp

lemma minus_add: "- (a + b) = - b + - a"
  by (fact add.inverse_distrib_swap)

lemma right_minus_eq [simp]: "a - b = 0 \<longleftrightarrow> a = b"
proof
  assume "a - b = 0"
  have "a = (a - b) + b" by (simp add: add.assoc)
  also have "\<dots> = b" using \<open>a - b = 0\<close> by simp
  finally show "a = b" .
next
  assume "a = b"
  then show "a - b = 0" by simp
qed

lemma eq_iff_diff_eq_0: "a = b \<longleftrightarrow> a - b = 0"
  by (fact right_minus_eq [symmetric])

lemma diff_0 [simp]: "0 - a = - a"
  by (simp only: diff_conv_add_uminus add_0_left)

lemma diff_0_right [simp]: "a - 0 = a"
  by (simp only: diff_conv_add_uminus minus_zero add_0_right)

lemma diff_minus_eq_add [simp]: "a - - b = a + b"
  by (simp only: diff_conv_add_uminus minus_minus)

lemma neg_equal_iff_equal [simp]: "- a = - b \<longleftrightarrow> a = b"
proof
  assume "- a = - b"
  then have "- (- a) = - (- b)" by simp
  then show "a = b" by simp
next
  assume "a = b"
  then show "- a = - b" by simp
qed

lemma neg_equal_0_iff_equal [simp]: "- a = 0 \<longleftrightarrow> a = 0"
  by (subst neg_equal_iff_equal [symmetric]) simp

lemma neg_0_equal_iff_equal [simp]: "0 = - a \<longleftrightarrow> 0 = a"
  by (subst neg_equal_iff_equal [symmetric]) simp

text \<open>The next two equations can make the simplifier loop!\<close>

lemma equation_minus_iff: "a = - b \<longleftrightarrow> b = - a"
proof -
  have "- (- a) = - b \<longleftrightarrow> - a = b"
    by (rule neg_equal_iff_equal)
  then show ?thesis
    by (simp add: eq_commute)
qed

lemma minus_equation_iff: "- a = b \<longleftrightarrow> - b = a"
proof -
  have "- a = - (- b) \<longleftrightarrow> a = -b"
    by (rule neg_equal_iff_equal)
  then show ?thesis
    by (simp add: eq_commute)
qed

lemma eq_neg_iff_add_eq_0: "a = - b \<longleftrightarrow> a + b = 0"
proof
  assume "a = - b"
  then show "a + b = 0" by simp
next
  assume "a + b = 0"
  moreover have "a + (b + - b) = (a + b) + - b"
    by (simp only: add.assoc)
  ultimately show "a = - b"
    by simp
qed

lemma add_eq_0_iff2: "a + b = 0 \<longleftrightarrow> a = - b"
  by (fact eq_neg_iff_add_eq_0 [symmetric])

lemma neg_eq_iff_add_eq_0: "- a = b \<longleftrightarrow> a + b = 0"
  by (auto simp add: add_eq_0_iff2)

lemma add_eq_0_iff: "a + b = 0 \<longleftrightarrow> b = - a"
  by (auto simp add: neg_eq_iff_add_eq_0 [symmetric])

lemma minus_diff_eq [simp]: "- (a - b) = b - a"
  by (simp only: neg_eq_iff_add_eq_0 diff_conv_add_uminus add.assoc minus_add_cancel) simp

lemma add_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
    "a + (b - c) = (a + b) - c"
  by (simp only: diff_conv_add_uminus add.assoc)

lemma diff_add_eq_diff_diff_swap: "a - (b + c) = a - c - b"
  by (simp only: diff_conv_add_uminus add.assoc minus_add)

lemma diff_eq_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a - b = c \<longleftrightarrow> a = c + b"
  by auto

lemma eq_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a = c - b \<longleftrightarrow> a + b = c"
  by auto

lemma diff_diff_eq2 [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a - (b - c) = (a + c) - b"
  by (simp only: diff_conv_add_uminus add.assoc) simp

lemma diff_eq_diff_eq: "a - b = c - d \<Longrightarrow> a = b \<longleftrightarrow> c = d"
  by (simp only: eq_iff_diff_eq_0 [of a b] eq_iff_diff_eq_0 [of c d])

end

class ab_group_add = minus + uminus + comm_monoid_add +
  assumes ab_left_minus: "- a + a = 0"
  assumes ab_diff_conv_add_uminus: "a - b = a + (- b)"
begin

subclass group_add
  by standard (simp_all add: ab_left_minus ab_diff_conv_add_uminus)

subclass cancel_comm_monoid_add
proof
  fix a b c :: 'a
  have "b + a - a = b"
    by simp
  then show "a + b - a = b"
    by (simp add: ac_simps)
  show "a - b - c = a - (b + c)"
    by (simp add: algebra_simps)
qed

lemma uminus_add_conv_diff [simp]: "- a + b = b - a"
  by (simp add: add.commute)

lemma minus_add_distrib [simp]: "- (a + b) = - a + - b"
  by (simp add: algebra_simps)

lemma diff_add_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "(a - b) + c = (a + c) - b"
  by (simp add: algebra_simps)

lemma minus_diff_commute:
  "- b - a = - a - b"
  by (simp only: diff_conv_add_uminus add.commute)

end

subsection \<open>(Partially) Ordered Groups\<close>

text \<open>
  The theory of partially ordered groups is taken from the books:

    \<^item> \<^emph>\<open>Lattice Theory\<close> by Garret Birkhoff, American Mathematical Society, 1979
    \<^item> \<^emph>\<open>Partially Ordered Algebraic Systems\<close>, Pergamon Press, 1963

  Most of the used notions can also be looked up in
    \<^item> \<^url>\<open>http://www.mathworld.com\<close> by Eric Weisstein et. al.
    \<^item> \<^emph>\<open>Algebra I\<close> by van der Waerden, Springer
\<close>

class ordered_ab_semigroup_add = order + ab_semigroup_add +
  assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
begin

lemma add_right_mono: "a \<le> b \<Longrightarrow> a + c \<le> b + c"
  by (simp add: add.commute [of _ c] add_left_mono)

text \<open>non-strict, in both arguments\<close>
lemma add_mono: "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
  by (simp add: add.commute add_left_mono add_right_mono [THEN order_trans])

end

text \<open>Strict monotonicity in both arguments\<close>
class strict_ordered_ab_semigroup_add = ordered_ab_semigroup_add +
  assumes add_strict_mono: "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"

class ordered_cancel_ab_semigroup_add =
  ordered_ab_semigroup_add + cancel_ab_semigroup_add
begin

lemma add_strict_left_mono: "a < b \<Longrightarrow> c + a < c + b"
  by (auto simp add: less_le add_left_mono)

lemma add_strict_right_mono: "a < b \<Longrightarrow> a + c < b + c"
  by (simp add: add.commute [of _ c] add_strict_left_mono)

subclass strict_ordered_ab_semigroup_add
proof
  show "\<And>a b c d. \<lbrakk>a < b; c < d\<rbrakk> \<Longrightarrow> a + c < b + d"
    by (iprover intro: add_strict_left_mono add_strict_right_mono less_trans)
qed

lemma add_less_le_mono: "a < b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c < b + d"
  by (iprover intro: add_left_mono add_strict_right_mono less_le_trans)

lemma add_le_less_mono: "a \<le> b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
  by (iprover intro: add_strict_left_mono add_right_mono less_le_trans)

end

class ordered_ab_semigroup_add_imp_le = ordered_cancel_ab_semigroup_add +
  assumes add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
begin

lemma add_less_imp_less_left:
  assumes less: "c + a < c + b"
  shows "a < b"
proof -
  from less have le: "c + a \<le> c + b"
    by (simp add: order_le_less)
  have "a \<le> b"
    using add_le_imp_le_left [OF le] .
  moreover have "a \<noteq> b"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "a = b" by simp
    then have "c + a = c + b" by simp
    with less show "False" by simp
  qed
  ultimately show "a < b"
    by (simp add: order_le_less)
qed

lemma add_less_imp_less_right: "a + c < b + c \<Longrightarrow> a < b"
  by (rule add_less_imp_less_left [of c]) (simp add: add.commute)

lemma add_less_cancel_left [simp]: "c + a < c + b \<longleftrightarrow> a < b"
  by (blast intro: add_less_imp_less_left add_strict_left_mono)

lemma add_less_cancel_right [simp]: "a + c < b + c \<longleftrightarrow> a < b"
  by (blast intro: add_less_imp_less_right add_strict_right_mono)

lemma add_le_cancel_left [simp]: "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
  by (auto simp: dest: add_le_imp_le_left add_left_mono)

lemma add_le_cancel_right [simp]: "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
  by (simp add: add.commute [of a c] add.commute [of b c])

lemma add_le_imp_le_right: "a + c \<le> b + c \<Longrightarrow> a \<le> b"
  by simp

lemma max_add_distrib_left: "max x y + z = max (x + z) (y + z)"
  unfolding max_def by auto

lemma min_add_distrib_left: "min x y + z = min (x + z) (y + z)"
  unfolding min_def by auto

lemma max_add_distrib_right: "x + max y z = max (x + y) (x + z)"
  unfolding max_def by auto

lemma min_add_distrib_right: "x + min y z = min (x + y) (x + z)"
  unfolding min_def by auto

end

subsection \<open>Support for reasoning about signs\<close>

class ordered_comm_monoid_add = comm_monoid_add + ordered_ab_semigroup_add
begin

lemma add_nonneg_nonneg [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a + b"
  using add_mono[of 0 a 0 b] by simp

lemma add_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b \<le> 0"
  using add_mono[of a 0 b 0] by simp

lemma add_nonneg_eq_0_iff: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  using add_left_mono[of 0 y x] add_right_mono[of 0 x y] by auto

lemma add_nonpos_eq_0_iff: "x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  using add_left_mono[of y 0 x] add_right_mono[of x 0 y] by auto

lemma add_increasing: "0 \<le> a \<Longrightarrow> b \<le> c \<Longrightarrow> b \<le> a + c"
  using add_mono [of 0 a b c] by simp

lemma add_increasing2: "0 \<le> c \<Longrightarrow> b \<le> a \<Longrightarrow> b \<le> a + c"
  by (simp add: add_increasing add.commute [of a])

lemma add_decreasing: "a \<le> 0 \<Longrightarrow> c \<le> b \<Longrightarrow> a + c \<le> b"
  using add_mono [of a 0 c b] by simp

lemma add_decreasing2: "c \<le> 0 \<Longrightarrow> a \<le> b \<Longrightarrow> a + c \<le> b"
  using add_mono[of a b c 0] by simp

lemma add_pos_nonneg: "0 < a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < a + b"
  using less_le_trans[of 0 a "a + b"] by (simp add: add_increasing2)

lemma add_pos_pos: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a + b"
  by (intro add_pos_nonneg less_imp_le)

lemma add_nonneg_pos: "0 \<le> a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a + b"
  using add_pos_nonneg[of b a] by (simp add: add_commute)

lemma add_neg_nonpos: "a < 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b < 0"
  using le_less_trans[of "a + b" a 0] by (simp add: add_decreasing2)

lemma add_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> a + b < 0"
  by (intro add_neg_nonpos less_imp_le)

lemma add_nonpos_neg: "a \<le> 0 \<Longrightarrow> b < 0 \<Longrightarrow> a + b < 0"
  using add_neg_nonpos[of b a] by (simp add: add_commute)

lemmas add_sign_intros =
  add_pos_nonneg add_pos_pos add_nonneg_pos add_nonneg_nonneg
  add_neg_nonpos add_neg_neg add_nonpos_neg add_nonpos_nonpos

end

class strict_ordered_comm_monoid_add = comm_monoid_add + strict_ordered_ab_semigroup_add
begin

lemma pos_add_strict: "0 < a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
  using add_strict_mono [of 0 a b c] by simp

end

class ordered_cancel_comm_monoid_add = ordered_comm_monoid_add + cancel_ab_semigroup_add
begin

subclass ordered_cancel_ab_semigroup_add ..
subclass strict_ordered_comm_monoid_add ..

lemma add_strict_increasing: "0 < a \<Longrightarrow> b \<le> c \<Longrightarrow> b < a + c"
  using add_less_le_mono [of 0 a b c] by simp

lemma add_strict_increasing2: "0 \<le> a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
  using add_le_less_mono [of 0 a b c] by simp

end

class ordered_ab_semigroup_monoid_add_imp_le = monoid_add + ordered_ab_semigroup_add_imp_le
begin

lemma add_less_same_cancel1 [simp]: "b + a < b \<longleftrightarrow> a < 0"
  using add_less_cancel_left [of _ _ 0] by simp

lemma add_less_same_cancel2 [simp]: "a + b < b \<longleftrightarrow> a < 0"
  using add_less_cancel_right [of _ _ 0] by simp

lemma less_add_same_cancel1 [simp]: "a < a + b \<longleftrightarrow> 0 < b"
  using add_less_cancel_left [of _ 0] by simp

lemma less_add_same_cancel2 [simp]: "a < b + a \<longleftrightarrow> 0 < b"
  using add_less_cancel_right [of 0] by simp

lemma add_le_same_cancel1 [simp]: "b + a \<le> b \<longleftrightarrow> a \<le> 0"
  using add_le_cancel_left [of _ _ 0] by simp

lemma add_le_same_cancel2 [simp]: "a + b \<le> b \<longleftrightarrow> a \<le> 0"
  using add_le_cancel_right [of _ _ 0] by simp

lemma le_add_same_cancel1 [simp]: "a \<le> a + b \<longleftrightarrow> 0 \<le> b"
  using add_le_cancel_left [of _ 0] by simp

lemma le_add_same_cancel2 [simp]: "a \<le> b + a \<longleftrightarrow> 0 \<le> b"
  using add_le_cancel_right [of 0] by simp

subclass cancel_comm_monoid_add
  by standard auto

subclass ordered_cancel_comm_monoid_add
  by standard

end

class ordered_ab_group_add = ab_group_add + ordered_ab_semigroup_add
begin

subclass ordered_cancel_ab_semigroup_add ..

subclass ordered_ab_semigroup_monoid_add_imp_le
proof
  fix a b c :: 'a
  assume "c + a \<le> c + b"
  then have "(-c) + (c + a) \<le> (-c) + (c + b)"
    by (rule add_left_mono)
  then have "((-c) + c) + a \<le> ((-c) + c) + b"
    by (simp only: add.assoc)
  then show "a \<le> b" by simp
qed

lemma max_diff_distrib_left: "max x y - z = max (x - z) (y - z)"
  using max_add_distrib_left [of x y "- z"] by simp

lemma min_diff_distrib_left: "min x y - z = min (x - z) (y - z)"
  using min_add_distrib_left [of x y "- z"] by simp

lemma le_imp_neg_le:
  assumes "a \<le> b"
  shows "- b \<le> - a"
proof -
  from assms have "- a + a \<le> - a + b"
    by (rule add_left_mono)
  then have "0 \<le> - a + b"
    by simp
  then have "0 + (- b) \<le> (- a + b) + (- b)"
    by (rule add_right_mono)
  then show ?thesis
    by (simp add: algebra_simps)
qed

lemma neg_le_iff_le [simp]: "- b \<le> - a \<longleftrightarrow> a \<le> b"
proof
  assume "- b \<le> - a"
  then have "- (- a) \<le> - (- b)"
    by (rule le_imp_neg_le)
  then show "a \<le> b"
    by simp
next
  assume "a \<le> b"
  then show "- b \<le> - a"
    by (rule le_imp_neg_le)
qed

lemma neg_le_0_iff_le [simp]: "- a \<le> 0 \<longleftrightarrow> 0 \<le> a"
  by (subst neg_le_iff_le [symmetric]) simp

lemma neg_0_le_iff_le [simp]: "0 \<le> - a \<longleftrightarrow> a \<le> 0"
  by (subst neg_le_iff_le [symmetric]) simp

lemma neg_less_iff_less [simp]: "- b < - a \<longleftrightarrow> a < b"
  by (auto simp add: less_le)

lemma neg_less_0_iff_less [simp]: "- a < 0 \<longleftrightarrow> 0 < a"
  by (subst neg_less_iff_less [symmetric]) simp

lemma neg_0_less_iff_less [simp]: "0 < - a \<longleftrightarrow> a < 0"
  by (subst neg_less_iff_less [symmetric]) simp

text \<open>The next several equations can make the simplifier loop!\<close>

lemma less_minus_iff: "a < - b \<longleftrightarrow> b < - a"
proof -
  have "- (- a) < - b \<longleftrightarrow> b < - a"
    by (rule neg_less_iff_less)
  then show ?thesis by simp
qed

lemma minus_less_iff: "- a < b \<longleftrightarrow> - b < a"
proof -
  have "- a < - (- b) \<longleftrightarrow> - b < a"
    by (rule neg_less_iff_less)
  then show ?thesis by simp
qed

lemma le_minus_iff: "a \<le> - b \<longleftrightarrow> b \<le> - a"
  by (auto simp: order.order_iff_strict less_minus_iff)

lemma minus_le_iff: "- a \<le> b \<longleftrightarrow> - b \<le> a"
  by (auto simp add: le_less minus_less_iff)

lemma diff_less_0_iff_less [simp]: "a - b < 0 \<longleftrightarrow> a < b"
proof -
  have "a - b < 0 \<longleftrightarrow> a + (- b) < b + (- b)"
    by simp
  also have "\<dots> \<longleftrightarrow> a < b"
    by (simp only: add_less_cancel_right)
  finally show ?thesis .
qed

lemmas less_iff_diff_less_0 = diff_less_0_iff_less [symmetric]

lemma diff_less_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a - b < c \<longleftrightarrow> a < c + b"
proof (subst less_iff_diff_less_0 [of a])
  show "(a - b < c) = (a - (c + b) < 0)"
    by (simp add: algebra_simps less_iff_diff_less_0 [of _ c])
qed

lemma less_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a < c - b \<longleftrightarrow> a + b < c"
proof (subst less_iff_diff_less_0 [of "a + b"])
  show "(a < c - b) = (a + b - c < 0)"
    by (simp add: algebra_simps less_iff_diff_less_0 [of a])
qed

lemma diff_gt_0_iff_gt [simp]: "a - b > 0 \<longleftrightarrow> a > b"
  by (simp add: less_diff_eq)

lemma diff_le_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a - b \<le> c \<longleftrightarrow> a \<le> c + b"
  by (auto simp add: le_less diff_less_eq )

lemma le_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
  "a \<le> c - b \<longleftrightarrow> a + b \<le> c"
  by (auto simp add: le_less less_diff_eq)

lemma diff_le_0_iff_le [simp]: "a - b \<le> 0 \<longleftrightarrow> a \<le> b"
  by (simp add: algebra_simps)

lemmas le_iff_diff_le_0 = diff_le_0_iff_le [symmetric]

lemma diff_ge_0_iff_ge [simp]: "a - b \<ge> 0 \<longleftrightarrow> a \<ge> b"
  by (simp add: le_diff_eq)

lemma diff_eq_diff_less: "a - b = c - d \<Longrightarrow> a < b \<longleftrightarrow> c < d"
  by (auto simp only: less_iff_diff_less_0 [of a b] less_iff_diff_less_0 [of c d])

lemma diff_eq_diff_less_eq: "a - b = c - d \<Longrightarrow> a \<le> b \<longleftrightarrow> c \<le> d"
  by (auto simp only: le_iff_diff_le_0 [of a b] le_iff_diff_le_0 [of c d])

lemma diff_mono: "a \<le> b \<Longrightarrow> d \<le> c \<Longrightarrow> a - c \<le> b - d"
  by (simp add: field_simps add_mono)

lemma diff_left_mono: "b \<le> a \<Longrightarrow> c - a \<le> c - b"
  by (simp add: field_simps)

lemma diff_right_mono: "a \<le> b \<Longrightarrow> a - c \<le> b - c"
  by (simp add: field_simps)

lemma diff_strict_mono: "a < b \<Longrightarrow> d < c \<Longrightarrow> a - c < b - d"
  by (simp add: field_simps add_strict_mono)

lemma diff_strict_left_mono: "b < a \<Longrightarrow> c - a < c - b"
  by (simp add: field_simps)

lemma diff_strict_right_mono: "a < b \<Longrightarrow> a - c < b - c"
  by (simp add: field_simps)

end

locale group_cancel
begin

lemma add1: "(A::'a::comm_monoid_add) \<equiv> k + a \<Longrightarrow> A + b \<equiv> k + (a + b)"
  by (simp only: ac_simps)

lemma add2: "(B::'a::comm_monoid_add) \<equiv> k + b \<Longrightarrow> a + B \<equiv> k + (a + b)"
  by (simp only: ac_simps)

lemma sub1: "(A::'a::ab_group_add) \<equiv> k + a \<Longrightarrow> A - b \<equiv> k + (a - b)"
  by (simp only: add_diff_eq)

lemma sub2: "(B::'a::ab_group_add) \<equiv> k + b \<Longrightarrow> a - B \<equiv> - k + (a - b)"
  by (simp only: minus_add diff_conv_add_uminus ac_simps)

lemma neg1: "(A::'a::ab_group_add) \<equiv> k + a \<Longrightarrow> - A \<equiv> - k + - a"
  by (simp only: minus_add_distrib)

lemma rule0: "(a::'a::comm_monoid_add) \<equiv> a + 0"
  by (simp only: add_0_right)

end

ML_file \<open>Tools/group_cancel.ML\<close>

simproc_setup group_cancel_add ("a + b::'a::ab_group_add") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_add_conv\<close>

simproc_setup group_cancel_diff ("a - b::'a::ab_group_add") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_diff_conv\<close>

simproc_setup group_cancel_eq ("a = (b::'a::ab_group_add)") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_eq_conv\<close>

simproc_setup group_cancel_le ("a \<le> (b::'a::ordered_ab_group_add)") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_le_conv\<close>

simproc_setup group_cancel_less ("a < (b::'a::ordered_ab_group_add)") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_less_conv\<close>

class linordered_ab_semigroup_add =
  linorder + ordered_ab_semigroup_add

class linordered_cancel_ab_semigroup_add =
  linorder + ordered_cancel_ab_semigroup_add
begin

subclass linordered_ab_semigroup_add ..

subclass ordered_ab_semigroup_add_imp_le
proof
  fix a b c :: 'a
  assume le1: "c + a \<le> c + b"
  show "a \<le> b"
  proof (rule ccontr)
    assume *: "\<not> ?thesis"
    then have "b \<le> a" by (simp add: linorder_not_le)
    then have "c + b \<le> c + a" by (rule add_left_mono)
    then have "c + a = c + b"
      using le1 by (iprover intro: order.antisym)
    then have "a = b"
      by simp
    with * show False
      by (simp add: linorder_not_le [symmetric])
  qed
qed

end

class linordered_ab_group_add = linorder + ordered_ab_group_add
begin

subclass linordered_cancel_ab_semigroup_add ..

lemma equal_neg_zero [simp]: "a = - a \<longleftrightarrow> a = 0"
proof
  assume "a = 0"
  then show "a = - a" by simp
next
  assume A: "a = - a"
  show "a = 0"
  proof (cases "0 \<le> a")
    case True
    with A have "0 \<le> - a" by auto
    with le_minus_iff have "a \<le> 0" by simp
    with True show ?thesis by (auto intro: order_trans)
  next
    case False
    then have B: "a \<le> 0" by auto
    with A have "- a \<le> 0" by auto
    with B show ?thesis by (auto intro: order_trans)
  qed
qed

lemma neg_equal_zero [simp]: "- a = a \<longleftrightarrow> a = 0"
  by (auto dest: sym)

lemma neg_less_eq_nonneg [simp]: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
proof
  assume *: "- a \<le> a"
  show "0 \<le> a"
  proof (rule classical)
    assume "\<not> ?thesis"
    then have "a < 0" by auto
    with * have "- a < 0" by (rule le_less_trans)
    then show ?thesis by auto
  qed
next
  assume *: "0 \<le> a"
  then have "- a \<le> 0" by (simp add: minus_le_iff)
  from this * show "- a \<le> a" by (rule order_trans)
qed

lemma neg_less_pos [simp]: "- a < a \<longleftrightarrow> 0 < a"
  by (auto simp add: less_le)

lemma less_eq_neg_nonpos [simp]: "a \<le> - a \<longleftrightarrow> a \<le> 0"
  using neg_less_eq_nonneg [of "- a"] by simp

lemma less_neg_neg [simp]: "a < - a \<longleftrightarrow> a < 0"
  using neg_less_pos [of "- a"] by simp

lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
proof
  assume "a + a = 0"
  then have a: "- a = a" by (rule minus_unique)
  then show "a = 0" by (simp only: neg_equal_zero)
next
  assume "a = 0"
  then show "a + a = 0" by simp
qed

lemma double_zero_sym [simp]: "0 = a + a \<longleftrightarrow> a = 0"
  using double_zero [of a] by (simp only: eq_commute)

lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
proof
  assume "0 < a + a"
  then have "0 - a < a" by (simp only: diff_less_eq)
  then have "- a < a" by simp
  then show "0 < a" by simp
next
  assume "0 < a"
  with this have "0 + 0 < a + a"
    by (rule add_strict_mono)
  then show "0 < a + a" by simp
qed

lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: le_less)

lemma double_add_less_zero_iff_single_add_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
proof -
  have "\<not> a + a < 0 \<longleftrightarrow> \<not> a < 0"
    by (simp add: not_less)
  then show ?thesis by simp
qed

lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
proof -
  have "\<not> a + a \<le> 0 \<longleftrightarrow> \<not> a \<le> 0"
    by (simp add: not_le)
  then show ?thesis by simp
qed

lemma minus_max_eq_min: "- max x y = min (- x) (- y)"
  by (auto simp add: max_def min_def)

lemma minus_min_eq_max: "- min x y = max (- x) (- y)"
  by (auto simp add: max_def min_def)

end

class abs =
  fixes abs :: "'a \<Rightarrow> 'a"  ("\<bar>_\<bar>")

class sgn =
  fixes sgn :: "'a \<Rightarrow> 'a"

class ordered_ab_group_add_abs = ordered_ab_group_add + abs +
  assumes abs_ge_zero [simp]: "\<bar>a\<bar> \<ge> 0"
    and abs_ge_self: "a \<le> \<bar>a\<bar>"
    and abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
    and abs_minus_cancel [simp]: "\<bar>-a\<bar> = \<bar>a\<bar>"
    and abs_triangle_ineq: "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
begin

lemma abs_minus_le_zero: "- \<bar>a\<bar> \<le> 0"
  unfolding neg_le_0_iff_le by simp

lemma abs_of_nonneg [simp]:
  assumes nonneg: "0 \<le> a"
  shows "\<bar>a\<bar> = a"
proof (rule order.antisym)
  show "a \<le> \<bar>a\<bar>" by (rule abs_ge_self)
  from nonneg le_imp_neg_le have "- a \<le> 0" by simp
  from this nonneg have "- a \<le> a" by (rule order_trans)
  then show "\<bar>a\<bar> \<le> a" by (auto intro: abs_leI)
qed

lemma abs_idempotent [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
  by (rule order.antisym) (auto intro!: abs_ge_self abs_leI order_trans [of "- \<bar>a\<bar>" 0 "\<bar>a\<bar>"])

lemma abs_eq_0 [simp]: "\<bar>a\<bar> = 0 \<longleftrightarrow> a = 0"
proof -
  have "\<bar>a\<bar> = 0 \<Longrightarrow> a = 0"
  proof (rule order.antisym)
    assume zero: "\<bar>a\<bar> = 0"
    with abs_ge_self show "a \<le> 0" by auto
    from zero have "\<bar>-a\<bar> = 0" by simp
    with abs_ge_self [of "- a"] have "- a \<le> 0" by auto
    with neg_le_0_iff_le show "0 \<le> a" by auto
  qed
  then show ?thesis by auto
qed

lemma abs_zero [simp]: "\<bar>0\<bar> = 0"
  by simp

lemma abs_0_eq [simp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
proof -
  have "0 = \<bar>a\<bar> \<longleftrightarrow> \<bar>a\<bar> = 0" by (simp only: eq_ac)
  then show ?thesis by simp
qed

lemma abs_le_zero_iff [simp]: "\<bar>a\<bar> \<le> 0 \<longleftrightarrow> a = 0"
proof
  assume "\<bar>a\<bar> \<le> 0"
  then have "\<bar>a\<bar> = 0" by (rule order.antisym) simp
  then show "a = 0" by simp
next
  assume "a = 0"
  then show "\<bar>a\<bar> \<le> 0" by simp
qed

lemma abs_le_self_iff [simp]: "\<bar>a\<bar> \<le> a \<longleftrightarrow> 0 \<le> a"
proof -
  have "0 \<le> \<bar>a\<bar>"
    using abs_ge_zero by blast
  then have "\<bar>a\<bar> \<le> a \<Longrightarrow> 0 \<le> a"
    using order.trans by blast
  then show ?thesis
    using abs_of_nonneg eq_refl by blast
qed

lemma zero_less_abs_iff [simp]: "0 < \<bar>a\<bar> \<longleftrightarrow> a \<noteq> 0"
  by (simp add: less_le)

lemma abs_not_less_zero [simp]: "\<not> \<bar>a\<bar> < 0"
proof -
  have "x \<le> y \<Longrightarrow> \<not> y < x" for x y by auto
  then show ?thesis by simp
qed

lemma abs_ge_minus_self: "- a \<le> \<bar>a\<bar>"
proof -
  have "- a \<le> \<bar>-a\<bar>" by (rule abs_ge_self)
  then show ?thesis by simp
qed

lemma abs_minus_commute: "\<bar>a - b\<bar> = \<bar>b - a\<bar>"
proof -
  have "\<bar>a - b\<bar> = \<bar>- (a - b)\<bar>"
    by (simp only: abs_minus_cancel)
  also have "\<dots> = \<bar>b - a\<bar>" by simp
  finally show ?thesis .
qed

lemma abs_of_pos: "0 < a \<Longrightarrow> \<bar>a\<bar> = a"
  by (rule abs_of_nonneg) (rule less_imp_le)

lemma abs_of_nonpos [simp]:
  assumes "a \<le> 0"
  shows "\<bar>a\<bar> = - a"
proof -
  let ?b = "- a"
  have "- ?b \<le> 0 \<Longrightarrow> \<bar>- ?b\<bar> = - (- ?b)"
    unfolding abs_minus_cancel [of ?b]
    unfolding neg_le_0_iff_le [of ?b]
    unfolding minus_minus by (erule abs_of_nonneg)
  then show ?thesis using assms by auto
qed

lemma abs_of_neg: "a < 0 \<Longrightarrow> \<bar>a\<bar> = - a"
  by (rule abs_of_nonpos) (rule less_imp_le)

lemma abs_le_D1: "\<bar>a\<bar> \<le> b \<Longrightarrow> a \<le> b"
  using abs_ge_self by (blast intro: order_trans)

lemma abs_le_D2: "\<bar>a\<bar> \<le> b \<Longrightarrow> - a \<le> b"
  using abs_le_D1 [of "- a"] by simp

lemma abs_le_iff: "\<bar>a\<bar> \<le> b \<longleftrightarrow> a \<le> b \<and> - a \<le> b"
  by (blast intro: abs_leI dest: abs_le_D1 abs_le_D2)

lemma abs_triangle_ineq2: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>a - b\<bar>"
proof -
  have "\<bar>a\<bar> = \<bar>b + (a - b)\<bar>"
    by (simp add: algebra_simps)
  then have "\<bar>a\<bar> \<le> \<bar>b\<bar> + \<bar>a - b\<bar>"
    by (simp add: abs_triangle_ineq)
  then show ?thesis
    by (simp add: algebra_simps)
qed

lemma abs_triangle_ineq2_sym: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>b - a\<bar>"
  by (simp only: abs_minus_commute [of b] abs_triangle_ineq2)

lemma abs_triangle_ineq3: "\<bar>\<bar>a\<bar> - \<bar>b\<bar>\<bar> \<le> \<bar>a - b\<bar>"
  by (simp add: abs_le_iff abs_triangle_ineq2 abs_triangle_ineq2_sym)

lemma abs_triangle_ineq4: "\<bar>a - b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
proof -
  have "\<bar>a - b\<bar> = \<bar>a + - b\<bar>"
    by (simp add: algebra_simps)
  also have "\<dots> \<le> \<bar>a\<bar> + \<bar>- b\<bar>"
    by (rule abs_triangle_ineq)
  finally show ?thesis by simp
qed

lemma abs_diff_triangle_ineq: "\<bar>a + b - (c + d)\<bar> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
proof -
  have "\<bar>a + b - (c + d)\<bar> = \<bar>(a - c) + (b - d)\<bar>"
    by (simp add: algebra_simps)
  also have "\<dots> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
    by (rule abs_triangle_ineq)
  finally show ?thesis .
qed

lemma abs_add_abs [simp]: "\<bar>\<bar>a\<bar> + \<bar>b\<bar>\<bar> = \<bar>a\<bar> + \<bar>b\<bar>"
  (is "?L = ?R")
proof (rule order.antisym)
  show "?L \<ge> ?R" by (rule abs_ge_self)
  have "?L \<le> \<bar>\<bar>a\<bar>\<bar> + \<bar>\<bar>b\<bar>\<bar>" by (rule abs_triangle_ineq)
  also have "\<dots> = ?R" by simp
  finally show "?L \<le> ?R" .
qed

end

lemma dense_eq0_I:
  fixes x::"'a::{dense_linorder,ordered_ab_group_add_abs}"
  assumes "\<And>e. 0 < e \<Longrightarrow> \<bar>x\<bar> \<le> e"
  shows "x = 0"
proof (cases "\<bar>x\<bar> = 0")
  case False
  then have "\<bar>x\<bar> > 0"
    by simp
  then obtain z where "0 < z" "z < \<bar>x\<bar>"
    using dense by force
  then show ?thesis
    using assms by (simp flip: not_less)
qed auto

hide_fact (open) ab_diff_conv_add_uminus add_0 mult_1 ab_left_minus

lemmas add_0 = add_0_left (* FIXME duplicate *)
lemmas mult_1 = mult_1_left (* FIXME duplicate *)
lemmas ab_left_minus = left_minus (* FIXME duplicate *)
lemmas diff_diff_eq = diff_diff_add (* FIXME duplicate *)

subsection \<open>Canonically ordered monoids\<close>

text \<open>Canonically ordered monoids are never groups.\<close>

class canonically_ordered_monoid_add = comm_monoid_add + order +
  assumes le_iff_add: "a \<le> b \<longleftrightarrow> (\<exists>c. b = a + c)"
begin

lemma zero_le[simp]: "0 \<le> x"
  by (auto simp: le_iff_add)

lemma le_zero_eq[simp]: "n \<le> 0 \<longleftrightarrow> n = 0"
  by (auto intro: order.antisym)

lemma not_less_zero[simp]: "\<not> n < 0"
  by (auto simp: less_le)

lemma zero_less_iff_neq_zero: "0 < n \<longleftrightarrow> n \<noteq> 0"
  by (auto simp: less_le)

text \<open>This theorem is useful with \<open>blast\<close>\<close>
lemma gr_zeroI: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> 0 < n"
  by (rule zero_less_iff_neq_zero[THEN iffD2]) iprover

lemma not_gr_zero[simp]: "\<not> 0 < n \<longleftrightarrow> n = 0"
  by (simp add: zero_less_iff_neq_zero)

subclass ordered_comm_monoid_add
  proof qed (auto simp: le_iff_add add_ac)

lemma gr_implies_not_zero: "m < n \<Longrightarrow> n \<noteq> 0"
  by auto

lemma add_eq_0_iff_both_eq_0[simp]: "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (intro add_nonneg_eq_0_iff zero_le)

lemma zero_eq_add_iff_both_eq_0[simp]: "0 = x + y \<longleftrightarrow> x = 0 \<and> y = 0"
  using add_eq_0_iff_both_eq_0[of x y] unfolding eq_commute[of 0] .

lemma less_eqE:
  assumes \<open>a \<le> b\<close>
  obtains c where \<open>b = a + c\<close>
  using assms by (auto simp add: le_iff_add)

lemma lessE:
  assumes \<open>a < b\<close>
  obtains c where \<open>b = a + c\<close> and \<open>c \<noteq> 0\<close>
proof -
  from assms have \<open>a \<le> b\<close> \<open>a \<noteq> b\<close>
    by simp_all
  from \<open>a \<le> b\<close> obtain c where \<open>b = a + c\<close>
    by (rule less_eqE)
  moreover have \<open>c \<noteq> 0\<close> using \<open>a \<noteq> b\<close> \<open>b = a + c\<close>
    by auto
  ultimately show ?thesis
    by (rule that)
qed

lemmas zero_order = zero_le le_zero_eq not_less_zero zero_less_iff_neq_zero not_gr_zero
  \<comment> \<open>This should be attributed with \<open>[iff]\<close>, but then \<open>blast\<close> fails in \<open>Set\<close>.\<close>

end

class ordered_cancel_comm_monoid_diff =
  canonically_ordered_monoid_add + comm_monoid_diff + ordered_ab_semigroup_add_imp_le
begin

context
  fixes a b :: 'a
  assumes le: "a \<le> b"
begin

lemma add_diff_inverse: "a + (b - a) = b"
  using le by (auto simp add: le_iff_add)

lemma add_diff_assoc: "c + (b - a) = c + b - a"
  using le by (auto simp add: le_iff_add add.left_commute [of c])

lemma add_diff_assoc2: "b - a + c = b + c - a"
  using le by (auto simp add: le_iff_add add.assoc)

lemma diff_add_assoc: "c + b - a = c + (b - a)"
  using le by (simp add: add.commute add_diff_assoc)

lemma diff_add_assoc2: "b + c - a = b - a + c"
  using le by (simp add: add.commute add_diff_assoc)

lemma diff_diff_right: "c - (b - a) = c + a - b"
  by (simp add: add_diff_inverse add_diff_cancel_left [of a c "b - a", symmetric] add.commute)

lemma diff_add: "b - a + a = b"
  by (simp add: add.commute add_diff_inverse)

lemma le_add_diff: "c \<le> b + c - a"
  by (auto simp add: add.commute diff_add_assoc2 le_iff_add)

lemma le_imp_diff_is_add: "a \<le> b \<Longrightarrow> b - a = c \<longleftrightarrow> b = c + a"
  by (auto simp add: add.commute add_diff_inverse)

lemma le_diff_conv2: "c \<le> b - a \<longleftrightarrow> c + a \<le> b"
  (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  then have "c + a \<le> b - a + a"
    by (rule add_right_mono)
  then show ?Q
    by (simp add: add_diff_inverse add.commute)
next
  assume ?Q
  then have "a + c \<le> a + (b - a)"
    by (simp add: add_diff_inverse add.commute)
  then show ?P by simp
qed

end

end

subsection \<open>Tools setup\<close>

lemma add_mono_thms_linordered_semiring:
  fixes i j k :: "'a::ordered_ab_semigroup_add"
  shows "i \<le> j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
    and "i = j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
    and "i \<le> j \<and> k = l \<Longrightarrow> i + k \<le> j + l"
    and "i = j \<and> k = l \<Longrightarrow> i + k = j + l"
  by (rule add_mono, clarify+)+

lemma add_mono_thms_linordered_field:
  fixes i j k :: "'a::ordered_cancel_ab_semigroup_add"
  shows "i < j \<and> k = l \<Longrightarrow> i + k < j + l"
    and "i = j \<and> k < l \<Longrightarrow> i + k < j + l"
    and "i < j \<and> k \<le> l \<Longrightarrow> i + k < j + l"
    and "i \<le> j \<and> k < l \<Longrightarrow> i + k < j + l"
    and "i < j \<and> k < l \<Longrightarrow> i + k < j + l"
  by (auto intro: add_strict_right_mono add_strict_left_mono
      add_less_le_mono add_le_less_mono add_strict_mono)

code_identifier
  code_module Groups \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


section \<open>Fixpoints and Complete Lattices\<close>

(*
    Author: Viorel Preoteasa
*)

theory Complete_Lattice_Prop
imports WellFoundedTransitive
begin

text\<open>
This theory introduces some results about fixpoints of functions on
complete lattices. The main result is that a monotonic function
mapping momotonic functions to monotonic functions has the least
fixpoint monotonic.
\<close>

context complete_lattice begin

lemma inf_Inf: assumes nonempty: "A \<noteq> {}"
  shows "inf x (Inf A) = Inf ((inf x) ` A)"
  using assms by (auto simp add: INF_inf_const1 nonempty)

end

(*
Monotonic applications which map monotonic to monotonic have monotonic fixpoints
*)

definition
  "mono_mono F = (mono F \<and> (\<forall> f . mono f \<longrightarrow> mono (F f)))"

theorem lfp_mono [simp]:
  "mono_mono F \<Longrightarrow> mono (lfp F)"
  apply (simp add: mono_mono_def)
  apply (rule_tac f="F" and P = "mono" in lfp_ordinal_induct)
  apply (simp_all add: mono_def)
  apply (intro allI impI SUP_least)
  apply (rule_tac y = "f y" in order_trans)
  apply (auto intro: SUP_upper)
  done

lemma gfp_ordinal_induct:
  fixes f :: "'a::complete_lattice => 'a"
  assumes mono: "mono f"
  and P_f: "!!S. P S ==> P (f S)"
  and P_Union: "!!M. \<forall>S\<in>M. P S ==> P (Inf M)"
  shows "P (gfp f)"
proof -
  let ?M = "{S. gfp f \<le> S \<and> P S}"
  have "P (Inf ?M)" using P_Union by simp
  also have "Inf ?M = gfp f"
  proof (rule antisym)
    show "gfp f \<le> Inf ?M" by (blast intro: Inf_greatest)
    hence "f (gfp f) \<le> f (Inf ?M)" by (rule mono [THEN monoD])
    hence "gfp f \<le> f (Inf ?M)" using mono [THEN gfp_unfold] by simp
    hence "f (Inf ?M) \<in> ?M" using P_f P_Union by simp
    hence "Inf ?M \<le> f (Inf ?M)" by (rule Inf_lower)
    thus "Inf ?M \<le> gfp f" by (rule gfp_upperbound)
  qed
  finally show ?thesis .
qed
theorem gfp_mono [simp]:
  "mono_mono F \<Longrightarrow> mono (gfp F)"
  apply (simp add: mono_mono_def)
  apply (rule_tac f="F" and P = "mono" in gfp_ordinal_induct)
  apply (simp_all, safe)
  apply (simp_all add: mono_def)
  apply (intro allI impI INF_greatest)
  apply (rule_tac y = "f x" in order_trans)
  apply (auto intro: INF_lower)
  done

context complete_lattice begin

definition
  "Sup_less x (w::'b::well_founded) = Sup {y ::'a . \<exists> v < w . y = x v}"

lemma Sup_less_upper:
  "v < w \<Longrightarrow> P v \<le> Sup_less P w"
  by (simp add: Sup_less_def, rule Sup_upper, blast)

lemma Sup_less_least:
  "(!! v . v < w \<Longrightarrow> P v \<le> Q) \<Longrightarrow> Sup_less P w \<le> Q"
  by (simp add: Sup_less_def, rule Sup_least, blast)

end

lemma Sup_less_fun_eq:
  "((Sup_less P w) i) = (Sup_less (\<lambda> v . P v i)) w"
  apply (simp add: Sup_less_def fun_eq_iff)
  apply (rule arg_cong [of _ _ Sup])
  apply auto
  done

theorem fp_wf_induction:
  "f x  = x \<Longrightarrow> mono f \<Longrightarrow> (\<forall> w . (y w) \<le> f (Sup_less y w)) \<Longrightarrow> Sup (range y) \<le> x"
  apply (rule Sup_least)
  apply (simp add: image_def, safe, simp)
  apply (rule less_induct1, simp_all)
  apply (rule_tac y = "f (Sup_less y xa)" in order_trans, simp)
  apply (drule_tac x = "Sup_less y xa" and y = "x" in monoD)
  by (simp add: Sup_less_least, auto)

end


theory Jordan
  imports Walkup
begin

theorem even_genus: "hypermap H \<Longrightarrow> even (genus H)"
proof (induct "card (darts H)" arbitrary: H)
  case 0
  then interpret H: hypermap H by simp
  have "darts H = {}"
    by (metis 0 card_eq_0_iff hypermap_def)
  then have "verts (glink H) = {}"
    by (simp add: cedge_def cface_def cnode_def glink_def)
  then have "pre_digraph.sccs (glink H) = {}"
    apply auto
    by (metis \<open>verts (with_proj (glink H)) = {}\<close> pre_digraph.in_sccsE
      pre_digraph.induced_subgraph_altdef strongly_connected_def subgraph_imp_subverts subset_empty)
  then have "euler_lhs H = 0"
    by (simp add: "0.hyps" euler_lhs_def)
  also have "euler_rhs H = 0"
    unfolding euler_rhs_def
    by (metis H.perm_edge H.perm_face H.perm_node \<open>darts H = {}\<close> add_eq_0_iff_both_eq_0
        perm_on.count_cycles_on_empty perm_on.intro)
  ultimately have "genus H = 0"
    unfolding genus_def by presburger
  then show ?case by auto
next
  case (Suc x)
  then obtain d where "d \<in> darts H"
    by fastforce
  then interpret H': walkup H d
    by (simp add: Suc.prems walkup.intro walkup_axioms.intro)
  have "even (genus (walkupE H d))"
    by (metis H'.H'_def H'.card_darts_walkup H'.hypermap_walkupE Suc.hyps diff_Suc_1)
  then show "even (genus H)"
    by (simp add: H'.H'_def H'.even_genus_walkupE)
qed

(********************* Excerpt from jordan.v **********************************)
(*  For the induction we consider the following cases for the reduction       *)
(*  1) a dart not in p, with an E-transform                                   *)
(*  2) x with an E-transform if x is followed by an N-link (i.e., x = node y) *)
(*  3) y = face x with an F-transform, if y is followed by an N-link.         *)
(*  4) y with an E-transform, if y != t (by 3), z = face y)                   *)
(*  5) y with an N-transform, if y != node x                                  *)
(*  6) z with an E-transform, if z is followed by an F-link in p              *)
(*  7) z with an F-transform, otherwise (z is followed by an N-link in p)     *)
(******************************************************************************)

theorem planar_Jordan: "\<lbrakk>hypermap H; planar H\<rbrakk> \<Longrightarrow> hypermap.jordan H"
proof (induct "card (darts H)" arbitrary: H)
  case 0
  then have "verts (clink H) = {}"
    by (metis card_0_eq hypermap.finite_darts hypermap.verts_clink)
  then have "\<And>p. set p \<subseteq> verts (clink H) \<Longrightarrow> p = []"
    by force
  then show ?case
    by (metis "0.prems"(1) hypermap.jordan_def hypermap.moebius_path.elims(2) vpathE vwalk_def)
next
  case (Suc n)
  then interpret H: hypermap H by simp
  have IHe: "z \<in> darts H \<Longrightarrow> hypermap.jordan (walkupE H z)" for z
    by (metis H.finite_darts H.hypermap_axioms Suc.hyps Suc.prems(2) card_Diff_singleton
        diff_Suc_1 pre_hypermap.select_convs(1) walkup.H'_def hypermap.hypermap_walkupE walkup.intro
        walkup.planar_walkupE walkupE_def walkup_axioms.intro)
  have IHn: "z \<in> darts H \<Longrightarrow> hypermap.jordan (walkupN H z)" for z
    by (metis H.finite_darts H.hypermap_axioms H.hypermap_permN Suc.hyps Suc.prems(2)
        card_Diff_singleton diff_Suc_1 hypermap.hypermap_permF walkup.darts_walkupN walkupN_def
        hypermap.hypermap_walkupE walkup.intro walkup.planar_walkupN walkup_axioms.intro)
  have IHf: "z \<in> darts H \<Longrightarrow> hypermap.jordan (walkupF H z)" for z
    by (metis H.finite_darts H.hypermap_axioms H.hypermap_permF Suc.hyps Suc.prems(2)
        card_Diff_singleton diff_Suc_1 hypermap.hypermap_permN walkup.darts_walkupF walkupF_def
        hypermap.hypermap_walkupE walkup.intro walkup.planar_walkupF walkup_axioms.intro)

  have liftE: "\<lbrakk>z \<notin> set p; vpath p (clink H)\<rbrakk> \<Longrightarrow> vpath p (clink (walkupE H z))" for p z
    unfolding vpath_def
  proof (auto; rule vwalkI; rule)
    define H' where "H' = walkupE H z"
    assume *: "z \<notin> set p" "vwalk p (clink H)" "distinct p"
    { fix x assume "x \<in> set p"
      then have "x \<noteq> z"
        using *(1) by blast
      also have "x \<in> darts H"
        using "*"(2) H.verts_clink \<open>x \<in> set p\<close> by blast
      ultimately show "x \<in> verts (clink H')"
        by (metis Diff_iff H'_def H.hypermap_walkupE distinct.simps(2) distinct_singleton
            empty_set hypermap.verts_clink insert_iff pre_hypermap.select_convs(1) walkupE_def)
    }
    {
      fix x assume **: "x \<in> set (vwalk_arcs p)"
      then obtain u v where "(u,v) = x"
        by (metis surj_pair)
      then have "face H u = v \<or> node H v = u"
        by (metis "*"(2) H.arc_clink H.verts_clink \<open>x \<in> set (vwalk_arcs p)\<close>
            in_set_vwalk_arcsE subsetD vwalkE)
      also have "u \<noteq> z \<and> v \<noteq> z"
        by (metis *(1) \<open>(u, v) = x\<close> \<open>x \<in> set (vwalk_arcs p)\<close> in_set_vwalk_arcsE)
      ultimately have "face H' u = v \<or> node H' v = u"
        by (metis H'_def pre_hypermap.select_convs(3) pre_hypermap.select_convs(4)
            skip_perm_invariant walkupE_def)
      then show "x \<in> arcs_ends (clink H')"
        by (metis ** H'_def H.hypermap_walkupE \<open>(u, v) = x\<close> hypermap.verts_clink in_set_vwalk_arcsE
            \<open>\<And>x. x \<in> set p \<Longrightarrow> x \<in> verts (with_proj (clink H'))\<close> hypermap.arc_clink)
    }
    show "p = [] \<Longrightarrow> False"
      using "*"(2) by blast
  qed

  have liftN: "\<lbrakk>z \<notin> set (x#p); face H z \<notin> set p; vpath (x#p) (clink H)\<rbrakk>
                \<Longrightarrow> vpath (x#p) (clink (walkupN H z))" for p x z
  unfolding vpath_def
  proof (simp; rule vwalkI; rule; auto)
    assume *: "face H z \<notin> set p" "z \<noteq> x" "z \<notin> set p" "vwalk (x # p) (clink H)" "x \<notin> set p" "distinct p"
    define H' where "H' \<equiv> walkupN H z"
    have "x \<in> darts H"
      by (metis *(4) H.verts_clink list.set_intros(1) vwalk_verts_in_verts)
    then have "x \<in> darts H'"
      by (metis (no_types, lifting) *(2) Diff_iff H'_def H.darts_permN distinct.simps(2)
          distinct_singleton empty_set insert_iff permF_def pre_hypermap.ext_inject
          pre_hypermap.surjective walkupE_def walkupN_def)
    then show "x \<in> pverts (clink H')"
      by (metis H'_def H.hypermap_permN hypermap.hypermap_permF hypermap.hypermap_walkupE
          hypermap.verts_clink walkupN_def with_proj_simps(1))
    { fix v assume "v \<in> set p"
      then have "v \<noteq> z"
        using *(3) by fast
      also have "v \<in> darts H"
        using *(4) H.verts_clink \<open>v \<in> set p\<close> by fastforce
      ultimately have "v \<in> darts H'"
        by (simp add: H'_def H.darts_permN permF_def walkupE_def walkupN_def)
      then show "v \<in> pverts (clink H')"
        by (simp add: clink_def cnode_def pair_union_def reverse_def)
    }
    fix u v assume "(u, v) \<in> set (vwalk_arcs (x # p))"
    then have "u\<rightarrow>\<^bsub>clink H\<^esub>v"
      using *(4) by blast
    then consider (face) "face H u = v" | (node) "node H v = u"
      by (metis Gr_eq H.clinkP cface_def cnode_def)
    then have "face H' u = v \<or> node H' v = u"
    proof cases
      case face
      then have "face H' u = v"
        by (metis "*"(2) "*"(3) H'_def \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close> in_set_vwalk_arcsE
            permF_def permN_def pre_hypermap.select_convs(3) pre_hypermap.select_convs(4) set_ConsD
            skip_perm_invariant walkupE_def walkupN_def)
      then show ?thesis by simp
    next
      case node
      then have "v \<noteq> face H z \<and> node H v \<noteq> z"
        by (smt (verit, ccfv_threshold) *(1-3) \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close>
            in_set_vwalk_arcsE list.distinct(1) list.inject list.set_cases list.set_sel(1)
            prod.sel(2) vwalk_arcs.simps(2) vwalk_arcs_Cons)
      then have "node H' v = u"
        by (smt (z3) "*"(2) "*"(3) H'_def H.hypermap_permN \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close>
            hypermap.skip_edge_Perm in_set_vwalk_arcsE node permF_def permN_def
            pre_hypermap.select_convs(2) pre_hypermap.select_convs(3) set_ConsD skip_edge_def
            walkupE_def walkupN_def)
      then show ?thesis by simp
    qed
    then show "(u,v) \<in> parcs (clink H')"
      by (metis H'_def H.hypermap_permN \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close>
          \<open>\<And>v. v \<in> set p \<Longrightarrow> v \<in> pverts (clink H')\<close> \<open>x \<in> darts H'\<close> hypermap.hypermap_permF
          hypermap.hypermap_walkupE hypermap.parcs_clink hypermap.verts_clink in_set_vwalk_arcsE
          set_ConsD walkupN_def with_proj_simps(1))
  qed

 have liftF: "\<lbrakk>z \<notin> set (x#p); face H (edge H z) \<notin> set p; vpath (x#p) (clink H)\<rbrakk>
                \<Longrightarrow> vpath (x#p) (clink (walkupF H z))" for p x z
   unfolding vpath_def
 proof (simp; rule vwalkI; rule; auto)
   assume *: "face H (edge H z) \<notin> set p" "z \<noteq> x" "z \<notin> set p" "vwalk (x # p) (clink H)"
             "x \<notin> set p" "distinct p"
    define H' where "H' \<equiv> walkupF H z"
    have "x \<in> darts H"
      by (metis *(4) H.verts_clink list.set_intros(1) vwalk_verts_in_verts)
    then have "x \<in> darts H'"
      by (metis (no_types, lifting) *(2) Diff_iff H'_def H.darts_permF distinct.simps(2)
          distinct_singleton empty_set insert_iff permN_def pre_hypermap.ext_inject
          pre_hypermap.surjective walkupE_def walkupF_def)
    then show "x \<in> pverts (clink H')"
      by (simp add: clink_def cnode_def pair_union_def reverse_def)
    { fix v assume "v \<in> set p"
      then have "v \<noteq> z"
        using *(3) by fast
      also have "v \<in> darts H"
        using *(4) H.verts_clink \<open>v \<in> set p\<close> by fastforce
      ultimately have "v \<in> darts H'"
        by (simp add: H'_def H.darts_permF permN_def walkupE_def walkupF_def)
      then show "v \<in> pverts (clink H')"
        by (simp add: clink_def cnode_def pair_union_def reverse_def)
    }
    fix u v assume "(u, v) \<in> set (vwalk_arcs (x # p))"
    then have "u\<rightarrow>\<^bsub>clink H\<^esub>v"
      using *(4) by blast
    then consider (face) "face H u = v" | (node) "node H v = u"
      by (metis Gr_eq H.clinkP cface_def cnode_def)
    then have "face H' u = v \<or> node H' v = u"
    proof cases
      case face
      then have "u \<noteq> edge H z \<and> face H u \<noteq> z"
        by (smt (verit, ccfv_threshold) *(1-3) \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close>
            in_set_vwalk_arcsE list.distinct(1) list.inject list.set_cases list.set_sel(1)
            prod.sel(2) vwalk_arcs.simps(2) vwalk_arcs_Cons)
      then have "face H' u = v"
        by (metis (no_types, lifting) "*"(2,3) H'_def H.hypermap_axioms H.hypermap_permF
            \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close> face hypermap.edgeK hypermap.hypermap_walkupE
            in_set_vwalk_arcsE permF_def permN_def pre_hypermap.select_convs(3,4) set_ConsD
            skip_perm_invariant walkupE_def walkupF_def)
      then show ?thesis by simp
    next
      case node
      then have "node H' v = u"
        by (metis "*"(2,3) H'_def \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close> in_set_vwalk_arcsE permF_def
            permN_def pre_hypermap.select_convs(3,4) set_ConsD skip_perm_invariant
            walkupE_def walkupF_def)
      then show ?thesis by simp
    qed
    then show "(u,v) \<in> parcs (clink H')"
      by (metis H'_def H.hypermap_permF \<open>(u, v) \<in> set (vwalk_arcs (x # p))\<close>
          \<open>\<And>v. v \<in> set p \<Longrightarrow> v \<in> pverts (clink H')\<close> \<open>x \<in> pverts (clink H')\<close> hypermap.hypermap_permN
          hypermap.hypermap_walkupE hypermap.parcs_clink hypermap.verts_clink in_set_vwalk_arcsE
          set_ConsD walkupF_def with_proj_simps(1))
  qed

  {
    assume "\<not> H.jordan"
    then obtain x q where xq_def: "H.moebius_path (x#q)"
      using H.jordan_def H.moebius_path.elims(2) by blast
    define p where "p \<equiv> x#q"
    then have vpath_p: "vpath p (clink H)"
      using H.moebius_path.elims(2) xq_def by blast
    have dart_x: "x \<in> darts H"
      by (metis H.verts_clink list.set_intros(1) vpathE p_def vpath_p vwalk_verts_in_verts)
    obtain t where t_def: "(node H t) = last q"
      using H.nodeK by blast
    have dart_t: "t \<in> darts H"
      by (metis H.moebius_path.simps(2) H.perm_node H.verts_clink Permutations.permutes_not_in
          last_ConsR last_in_set p_def subsetD t_def vpathE vpath_p vwalkE xq_def)
    have "appears_before q t (node H x)"
      by (smt (verit, ccfv_threshold) H.faceK H.moebius_path.elims(2) list.inject p_def t_def xq_def)
    (* Case 1: WalkupE on a dart outside the path *)
    have "set p = darts H"
    proof (rule ccontr)
      assume "set p \<noteq> darts H"
      then obtain u where u_def: "u \<notin> set (x#q) \<and> u \<in> darts H"
        by (metis H.finite_darts H.verts_clink List.finite_set card_mono card_seteq
            subsetI vpathE vpath_p vwalk_def p_def)
      interpret H': walkup H u
        by (simp add: H.hypermap_axioms u_def walkup_axioms.intro walkup_def)
      define H' where "H' \<equiv> walkupE H u"
      then have "vpath (x#q) (clink H')"
        using \<open>u \<notin> set (x # q) \<and> u \<in> darts H\<close> liftE vpath_p xq_def p_def by blast
      also have "appears_before q (face H' (edge H' (last q))) (node H' x)"
        by (smt (z3) H'.H'_def H'.walkup_edge H'.walkup_face H'.walkup_node H'_def H.faceK
            H.moebius_path.simps(2) H.skip_edge_Perm skip_edge_noteq_z xq_def
            \<open>appears_before q t ((node H) \<langle>$\<rangle> x)\<close> appears_before_in apply_skip_perm last_in_set
            list.set_intros p_def skip_edge_def skip_fz skip_perm_invariant t_def u_def)
      ultimately have "hypermap.moebius_path H' (x#q)"
        using H'_def H.hypermap_walkupE H.moebius_path.simps(2)
          hypermap.moebius_path.elims(3) p_def xq_def by blast
      then show False
        using H'.z_dart H'_def H.hypermap_walkupE IHe hypermap.jordan_def by blast
    qed
    obtain y z q' where "q = y#z#q'"
      by (metis H.moebius_path.cases H.moebius_path.elims(2) \<open>appears_before q t ((node H) \<langle>$\<rangle> x)\<close>
          appears_before_in apply_inj_eq_iff distinct_length_2_or_more empty_iff empty_set
          last.simps set_ConsD t_def vpathE xq_def)
    have dart_y: "y \<in> darts H" and dart_z: "z \<in> darts H"
      using \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> p_def by auto
    have vpath_q': "q' \<noteq> [] \<Longrightarrow> vpath q' (clink H)"
      by (metis distinct.simps(2) list.simps(3) vpathE vpathI vpath_p p_def vwalk_consE \<open>q = y#z#q'\<close>)
    have "y \<noteq> x"
      by (metis \<open>q = y # z# q'\<close> distinct_length_2_or_more vpathE vpath_p p_def)
    have "t \<noteq> x"
      by (metis \<open>appears_before q t ((node H) \<langle>$\<rangle> x)\<close> appears_before_in(1) distinct.simps(2)
          p_def vpathE vpath_p)
    have "node H t \<noteq> x"
      by (metis \<open>q = y#z#q'\<close> distinct.simps(2) last_in_set list.distinct(1) p_def t_def vpathE vpath_p)
    have "node H t \<noteq> y"
      by (metis \<open>q = y # z # q'\<close> distinct.simps(2) last_ConsR last_in_set
          list.simps(3) t_def vpathE vpath_p p_def)

    (* Case 2: node H y = x with WalkupE *)
    have "face H x = y"
    proof (rule ccontr)
      assume "face H x \<noteq> y"
      then have "node H y = x"
        by (metis H.arc_clink H.wf_clink \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> p_def
            list.set_intros(1) vpathE vpath_p wf_digraph.vwalk_Cons_Cons wf_digraph_wp_iff)
      interpret H': walkup H x
        by (metis H.hypermap_axioms \<open>set p = darts H\<close> p_def list.set_intros(1)
            walkup.intro walkup_axioms.intro)
      define H' where " H' \<equiv> walkupE H x"
      have "vpath q (clink H')"
        by (metis H'_def \<open>q = y # z # q'\<close> distinct.simps(2) liftE list.distinct(1) p_def
            vpathE vpathI vpath_p vwalk_consE)
      also have "appears_before (z#q') (face H' (edge H' (last (z#q')))) (node H' y)"
        by (metis H'.H'_def H.hypermap_walkupE H'.walkup_node H'_def \<open>node H t \<noteq> x\<close> \<open>node H y = x\<close>
            \<open>appears_before q t (node H x)\<close> \<open>q = y # z # q'\<close> \<open>t \<noteq> x\<close> appears_before_cons
            apply_inj_eq_iff apply_skip_perm hypermap.nodeK last_ConsR list.simps(3) skip_def t_def)
      then have "hypermap.moebius_path H' q"
        by (metis H.hypermap_walkupE H'_def \<open>q = y # z # q'\<close> calculation
            hypermap.moebius_path.simps(3))
      then show False
        using H'.H'_def H.hypermap_walkupE H'.z_dart H'_def IHe hypermap.jordan_def by auto
    qed

    have ptnx: "if y = t then node H x \<in> set q else appears_before (z # q') t (node H x)"
      by (metis \<open>appears_before q t ((node H) \<langle>$\<rangle> x)\<close> \<open>q = y # z # q'\<close> appears_before_cons)

    (* Case 3 - y with walkupF if z = node y *)
    text_raw \<open>\DefineSnippet{jordan_3}{\<close>
    have "face H y = z"
    proof (rule ccontr)
      assume "face H y \<noteq> z"
      then have "node H z = y"
        by (metis H.arc_clink H.perm_face H.wf_clink \<open>face H x = y\<close> \<open>q = y # z # q'\<close> \<open>y \<noteq> x\<close> p_def
          apply_inj_eq_iff permutes_def vpathE vpath_p wf_digraph.vwalk_Cons_Cons wf_digraph_wp_iff)
      interpret H': walkup H y
        by (metis H.hypermap_axioms \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> list.set_intros p_def
            walkup.intro walkup_axioms_def)
      define H' where "H' \<equiv> walkupF H y"
      have vpath_H'_q': "vpath (z#q') (clink H')"
        by (metis H'_def H.faceK \<open>node H z = y\<close> \<open>q = y # z # q'\<close> distinct.simps(2) liftF
            list.simps(3) vpathE vpathI vpath_p vwalk_consE p_def)
      also have "face H' x = z"
        by (metis (no_types, lifting) H'.walkup_axioms H'_def H.faceK \<open>face H x = y\<close>
            \<open>node H z = y\<close> \<open>q = y # z # q'\<close> apply_inj_eq_iff distinct_length_2_or_more
            skip_face_def vpathE vpath_p walkup.face_walkupF p_def)
      then have "x\<rightarrow>\<^bsub>clink H'\<^esub>z"
        by (metis Gr_eq H'.darts_walkupF H'.z_dart H'_def \<open>set p = darts H\<close> \<open>y \<noteq> x\<close> p_def
            arc_in_union cface_def clink_def insert_Diff insert_iff list.set_intros(1))
      ultimately have vpath_p': "vpath (x#z#q') (clink H')"
        by (metis H'_def H.hypermap_permF \<open>q = y # z # q'\<close> distinct_length_2_or_more
            fin_digraph.axioms(1) hypermap.finite_clink hypermap.hypermap_permN
            hypermap.hypermap_walkupE list.sel(1) p_def vpathE vpathI vpath_p walkupF_def
            wf_digraph.vwalk_wf_digraph_consI)
      then have H'_t: "face H' (edge H' (last (z#q'))) = (if t=y then z else t)"
        by (smt (z3) H'.edge_walkupF H'.walkup_axioms H'_def H.faceK \<open>(node H) \<langle>$\<rangle> t \<noteq> y\<close>
            \<open>node H z = y\<close> \<open>q = y # z # q'\<close> apply_inj_eq_iff apply_skip_perm last_ConsR
            list.simps(3) skip_def skip_face_def t_def walkup.face_walkupF)
      then have moebius_q': "appears_before (z#q') (if t=y then z else t) (node H' x)"
        by (smt (z3) H'.node_walkupF H'_def H.faceK \<open>(node H) \<langle>$\<rangle> z = y\<close> \<open>q = y # z # q'\<close>
            appears_before_cons apply_skip_perm distinct.simps(2) distinct_length_2_or_more
            ptnx skip_def vpathE vpath_p p_def)
      then have "hypermap.moebius_path H' (x#z#q')"
        by (smt (z3) H'_def H.darts_permF H.hypermap_permF vpath_p' H'_t dart_y
            hypermap.hypermap_permN hypermap.moebius_path.simps(3) walkup.H'_def
            hypermap.hypermap_walkupE walkup.intro walkupF_def walkup_axioms.intro)
      then have "\<not> hypermap.jordan H'"
          by (metis H'_def H.hypermap_permF hypermap.hypermap_permN hypermap.hypermap_walkupE
              hypermap.jordan_def walkupF_def)
      then show False
        by (simp add: H'_def IHf dart_y)
    qed
    text_raw \<open>}%EndSnippet\<close>

    (* Case 4: y with walkupE if y \<noteq> t *)
    have "t = y"
    proof (rule ccontr)
      assume "t \<noteq> y"
      interpret H': walkup H y
        by (metis H.hypermap_axioms \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> list.set_intros p_def
            walkup.intro walkup_axioms_def)
      define H' where "H' \<equiv> walkupE H y"
      then have "vpath (z#q') (clink H')"
        by (metis \<open>q = y # z # q'\<close> distinct.simps(2) liftE list.simps(3) p_def
            vpathE vpathI vpath_p vwalk_consE)
      also have "face H' x = z"
        by (metis H'.H'_def H'.walkup_face H'_def \<open>face H x = y\<close> \<open>face H y = z\<close> apply_skip_perm skip_fz)
      ultimately have vpath_H': "vpath (x#z#q') (clink H')"
        by (metis H'_def H.hypermap_walkupE \<open>q = y # z # q'\<close> dart_x dart_y distinct_length_2_or_more
            hypermap.arc_clink hypermap.wf_clink insert_Diff insert_iff pre_hypermap.select_convs(1)
            vpath_def vpath_p walkupE_def wf_digraph.vwalk_Cons_Cons wf_digraph_wp_iff p_def)
      moreover have "appears_before (z#q') t (node H' x)"
        by (metis H'.H'_def H'.walkup_node H'_def \<open>q = y # z # q'\<close> \<open>t \<noteq> y\<close> appears_before_in(2)
          distinct.simps(2) distinct_length_2_or_more p_def ptnx skip_perm_invariant vpathE vpath_p)
      ultimately have "hypermap.moebius_path H' (x#z#q')"
        by (smt (z3) H'.H'_def H'.walkup_node H'_def H.faceK H.hypermap_axioms \<open>(node H) \<langle>$\<rangle> t \<noteq> y\<close>
            \<open>q = y # z # q'\<close> \<open>t \<noteq> y\<close> apply_skip_perm hypermap.hypermap_walkupE
            hypermap.moebius_path.simps(3) hypermap.nodeK last_ConsR list.simps(3) skip_def t_def)
      then show False
        using H'_def H.hypermap_walkupE IHe dart_y hypermap.jordan_def by blast
    qed

    (* Case 5: y with walkupN if y \<noteq> node x *)
    have "node H x = y"
    proof (rule ccontr)
      assume "node H x \<noteq> y"
      interpret H': walkup H y
        by (metis H.hypermap_axioms \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> list.set_intros p_def
            walkup.intro walkup_axioms_def)
      define H' where "H' \<equiv> walkupN H y"
      then have "vpath (z#q') (clink H')"
        by (metis \<open>(face H) \<langle>$\<rangle> y = z\<close> \<open>q = y # z # q'\<close> distinct.simps(2) liftN list.simps(3)
            vpathE vpathI vpath_p vwalk_consE p_def)
      also have "x\<rightarrow>\<^bsub>clink H'\<^esub>z"
        by (metis Gr_eq H'.darts_walkupN H'_def \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(face H) \<langle>$\<rangle> y = z\<close> \<open>y \<noteq> x\<close>
            apply_skip_perm arc_in_union cface_def clink_def dart_x dart_y insert_Diff insert_iff
            permF_def permN_def pre_hypermap.select_convs(3) pre_hypermap.select_convs(4) skip_fz
            walkupE_def walkupN_def)
      ultimately have vpath_H': "vpath (x#z#q') (clink H')"
        by (metis H'_def H.hypermap_permN \<open>q = y # z # q'\<close> distinct_length_2_or_more p_def
            hypermap.hypermap_permF hypermap.hypermap_walkupE hypermap.wf_clink list.sel(1)
            vpath_def vpath_p vwalk_consI walkupN_def wf_digraph.adj_in_verts(1) wf_digraph_wp_iff)
      have "face H' (edge H' (last (z#q'))) = z"
        by (metis H'.edge_walkupN H'.face_walkupN H'_def H.edgeK \<open>face H x = y\<close>
            \<open>face H y = z\<close> \<open>node H t \<noteq> y\<close> \<open>q = y # z # q'\<close> \<open>t = y\<close> \<open>y \<noteq> x\<close> apply_skip_perm
            last_ConsR list.simps(3) skip_def t_def)
      then have "appears_before (z#q') (face H' (edge H' (last (z#q')))) (node H' x)"
        by (metis (no_types, lifting) H'.walkup_axioms H'_def \<open>(face H) \<langle>$\<rangle> y = z\<close>
            \<open>(node H) \<langle>$\<rangle> x \<noteq> y\<close> \<open>q = y # z # q'\<close> \<open>t = y\<close> \<open>y \<noteq> x\<close> appears_before_cons
         distinct_length_2_or_more ptnx set_ConsD skip_node_def vpathE vpath_H' walkup.node_walkupN)
      then have "hypermap.moebius_path H' (x#z#q')"
        by (metis H'_def H.hypermap_permN hypermap.hypermap_permF hypermap.hypermap_walkupE
            hypermap.moebius_path.simps(3) vpath_H' walkupN_def)
      then show False
        by (metis H'_def H.hypermap_permN IHn dart_y hypermap.hypermap_permF
            hypermap.hypermap_walkupE hypermap.jordan_def walkupN_def)
    qed

    (* Base case: when there are less than 4 darts we can directly prove a contradiction *)
    have "length p \<ge> 4"
    proof (rule ccontr)
      have "length p \<ge> 2"
        by (metis H.moebius_path_length add_2_eq_Suc le_add1 less_le_trans not_less
            numeral_3_eq_3 p_def xq_def)
      moreover have "length p = 3 \<Longrightarrow> False"
      proof -
        assume "length p = 3"
        then have "q' = []"
          by (simp add: \<open>q = y # z # q'\<close> p_def)
        then have "p = [x,y,z]"
          by (simp add: \<open>q = y # z # q'\<close> p_def)
        then have "darts H = {x,y,z}"
          using \<open>set p = darts H\<close> by force
        then have "face H z = x"
          by (smt (verit) H.perm_face \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(face H) \<langle>$\<rangle> y = z\<close> \<open>(node H) \<langle>$\<rangle> t \<noteq> x\<close>
     \<open>q = y # z # q'\<close> \<open>q' = []\<close> empty_iff insert_iff last.simps list.distinct(1) permutes_def t_def)
        have "node H y = z"
          using \<open>q = y # z # q'\<close> \<open>q' = []\<close> \<open>t = y\<close> t_def by auto
        then have "node H z = x"
          by (smt (z3) H.edgeK H.perm_edge Permutations.permutes_not_in \<open>(face H) \<langle>$\<rangle> y = z\<close>
              \<open>(node H) \<langle>$\<rangle> t \<noteq> x\<close> \<open>(node H) \<langle>$\<rangle> t \<noteq> y\<close> \<open>(node H) \<langle>$\<rangle> x = y\<close> \<open>q = y # z # q'\<close>
              \<open>q' = []\<close> \<open>set p = darts H\<close> \<open>t = y\<close> apply_inj_eq_iff distinct.simps(2)
              distinct_singleton insert_iff list.simps(15) p_def)
        then have "edge H x = y \<and> edge H y = z \<and> edge H z = x"
          by (metis H.edgeK \<open>face H x = y\<close> \<open>face H y = z\<close> \<open>face H z = x\<close>
                            \<open>node H x = y\<close> \<open>node H y = z\<close>)
        {
          fix u assume "u \<in> darts H"
          then have  "u = x \<or> u = y \<or> u = z"
            using \<open>darts H = {x,y,z}\<close> by blast
          then have "u\<rightarrow>\<^sup>*\<^bsub>cedge H\<^esub>v \<and> u\<rightarrow>\<^sup>*\<^bsub>cnode H\<^esub>v \<and> u\<rightarrow>\<^sup>*\<^bsub>cface H\<^esub>v" if "v \<in> darts H" for v
            by (smt (z3) Gr_eq Gr_verts H.arc_clink H.cedge_connect_sym H.cface_connect_sym
              H.clinkP H.cnode_connect_sym H.wf_cedge H.wf_cface H.wf_cnode
              \<open>(edge H) \<langle>$\<rangle> x = y \<and> (edge H) \<langle>$\<rangle> y = z \<and> (edge H) \<langle>$\<rangle> z = x\<close> \<open>(face H) \<langle>$\<rangle> x = y\<close>
              \<open>(face H) \<langle>$\<rangle> y = z\<close> \<open>(face H) \<langle>$\<rangle> z = x\<close> \<open>(node H) \<langle>$\<rangle> x = y\<close> \<open>(node H) \<langle>$\<rangle> y = z\<close>
              \<open>(node H) \<langle>$\<rangle> z = x\<close> \<open>p = [x, y, z]\<close> \<open>set p = darts H\<close> cedge_def cface_def cnode_def
              empty_iff empty_set set_ConsD that wf_digraph.reach_sym_arc wf_digraph.reachable_adjI
              wf_digraph.reachable_refl wf_digraph_wp_iff)
        } note reach_enf = this
        then have strongly_connected_enf: "strongly_connected (cedge H)"
                  "strongly_connected (cnode H)"
                  "strongly_connected (cface H)"
          by (metis Gr_verts cedge_def cnode_def cface_def reach_enf
              dart_y equals0D strongly_connectedI)+
        then have "card (pre_digraph.sccs (cedge H)) = 1"
                  "card (pre_digraph.sccs (cnode H)) = 1"
                  "card (pre_digraph.sccs (cface H)) = 1"
          using H.wf_cedge H.wf_cnode H.wf_cface wf_digraph.card_sccs_connected wf_digraph_wp_iff
          by blast+
        then have "euler_rhs H = 3"
          unfolding euler_rhs_def
          by (simp add: perm_on.count_cycles_card_sccs H.finite_darts H.perm_edge H.perm_face
              H.perm_node cedge_def cface_def cnode_def perm_on.intro)

        have "card (darts H) = 3"
          by (metis \<open>length p = 3\<close> \<open>set p = darts H\<close> distinct_card vpathE vpath_p)
        also have "strongly_connected (glink H)"
        proof
          show "verts (glink H) \<noteq> {}"
            by (metis H.hypermap_axioms H.verts_clink H.wf_clink dart_x empty_iff
             hypermap.clink_glink reachable_in_vertsE wf_digraph.reachable_refl wf_digraph_wp_iff)
          fix u v assume "u \<in> verts (glink H)" "v \<in> verts (glink H)"
          then show "u \<rightarrow>\<^sup>*\<^bsub>with_proj (glink H)\<^esub> v"
            by (metis H.arc_clink H.clink_connect_sym H.clink_glink H.verts_clink H.wf_clink
                H.wf_glink \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(face H) \<langle>$\<rangle> y = z\<close> \<open>(node H) \<langle>$\<rangle> z = x\<close>
                \<open>q = y # z # q'\<close> \<open>q' = []\<close> \<open>set p = darts H\<close> empty_iff empty_set p_def
                reachable_in_vertsE set_ConsD wf_digraph.reach_sym_arc wf_digraph.reachable_adjI
                wf_digraph.reachable_refl wf_digraph_wp_iff)
        qed
        then have "card (pre_digraph.sccs (glink H)) = 1"
          using H.wf_glink wf_digraph.card_sccs_connected wf_digraph_wp_iff by blast
        then have "euler_lhs H = 5"
          unfolding euler_lhs_def using \<open>card (darts H) = 3\<close> by simp
        then have "genus H = 1"
          using \<open>euler_rhs H = 3\<close> by (simp add: genus_def)
        then show False
          by (metis H.finite_darts One_nat_def Suc.prems(2) calculation card_0_eq dart_t
              empty_iff numeral_3_eq_3 planar_def)
      qed
      ultimately show "\<not> 4 \<le> length p \<Longrightarrow> False"
        by (metis H.moebius_path_length Suc_leI le_neq_implies_less numeral_eq_Suc p_def
            pred_numeral_simps(2) semiring_norm(26,27) xq_def)
    qed

    then obtain w q'' where "w # q'' = q'"
      by (metis One_nat_def Suc_le_length_iff Suc_le_mono \<open>q = y # z # q'\<close> add.commute list.size(4)
          numeral_3_eq_3 numeral_eq_Suc p_def plus_1_eq_Suc pred_numeral_simps(2) semiring_norm(26,27))
    then have xyzw: "p = x#y#z#w#q''"
      by (simp add: \<open>q = y # z # q'\<close> p_def)

    (* Case 6: z with walkupE if z is followed by an f-link *)
    have "node H w = z"
    proof (rule ccontr)
      assume "node H w \<noteq> z"
      then have "face H z = w"
        by (metis H.arc_clink \<open>q = y # z # q'\<close> \<open>w # q'' = q'\<close> dart_z list.sel(1)
            list.simps(3) p_def vpathE vpath_p vwalk_consE)
      interpret H': walkup H z
        by (metis H.hypermap_axioms \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> list.set_intros p_def
            walkup.intro walkup_axioms_def)
      define H' where "H' \<equiv> walkupE H z"
      have "vpath q' (clink H')"
        unfolding H'_def apply (rule liftE)
        using \<open>q = y # z # q'\<close> p_def vpath_p apply auto
        using \<open>w # q'' = q'\<close> vpath_q' by blast
      moreover have "x\<rightarrow>\<^bsub>clink H'\<^esub>y"
        by (metis H'.H'_def H'.walkup_face H'_def H.hypermap_walkupE \<open>(face H) \<langle>$\<rangle> x = y\<close>
            \<open>q = y # z # q'\<close> apply_skip_perm dart_x dart_z distinct.simps(2) hypermap.arc_clink
            insert_Diff insert_iff list.simps(15) p_def pre_hypermap.select_convs(1) skip_invariant
            vpathE vpath_p walkupE_def)
      moreover have "y\<rightarrow>\<^bsub>clink H'\<^esub>w"
        by (metis H'.H'_def H'.walkup_face H'_def H.hypermap_walkupE \<open>(face H) \<langle>$\<rangle> y = z\<close>
            \<open>(face H) \<langle>$\<rangle> z = w\<close> apply_skip_perm calculation(2) hypermap.arc_clink
            hypermap.verts_clink hypermap.wf_clink skip_fz wf_digraph.adj_in_verts(2)
            wf_digraph_wp_iff)
      ultimately have "vpath (x#y#q') (clink H')"
        by (metis H'_def H.hypermap_walkupE \<open>q = y # z # q'\<close> \<open>w # q'' = q'\<close>
            distinct_length_2_or_more hypermap.wf_clink list.sel(1) p_def vpathE vpathI vpath_p
            wf_digraph.vwalk_wf_digraph_consI wf_digraph_wp_iff)
      also have "appears_before (y#q') t (node H' x)"
        by (metis H'.H'_def H'.walkup_node H'_def \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(face H) \<langle>$\<rangle> y = z\<close>
            \<open>(face H) \<langle>$\<rangle> z = w\<close> \<open>(node H) \<langle>$\<rangle> x = y\<close> \<open>t = y\<close> \<open>w # q'' = q'\<close> appears_before_id
            calculation distinct_length_2_or_more list.set_intros(1) skip_perm_invariant vpathE)
      ultimately have "hypermap.moebius_path H' (x#y#q')"
        by (smt (z3) H'.H'_def H'.walkup_axioms H'.walkup_face H'_def H.edgeK H.hypermap_walkupE
          H.skip_edge_Perm \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(face H) \<langle>$\<rangle> y = z\<close> \<open>q = y # z # q'\<close> \<open>t = y\<close>
          \<open>w # q'' = q'\<close> distinct.simps(2) distinct_length_2_or_more hypermap.moebius_path.simps(3)
          last_ConsR last_in_set list.distinct(1) p_def skip_edge_def skip_perm_invariant t_def
          vpathE vpath_p walkup.walkup_edge)
      then show False
        using H'_def H.hypermap_walkupE IHe dart_z hypermap.jordan_def by blast
    qed

    (* Case 7: otherwise z with F-transform *)
    then have False
    proof -
       interpret H': walkup H z
        by (metis H.hypermap_axioms \<open>q = y # z # q'\<close> \<open>set p = darts H\<close> list.set_intros p_def
            walkup.intro walkup_axioms_def)
      define H' where "H' \<equiv> walkupF H z"
      have "vpath (w#q'') (clink H')"
        unfolding H'_def apply (rule liftF)
          apply (metis distinct.simps(2) vpathE vpath_p xyzw)
         apply (metis H.faceK \<open>(node H) \<langle>$\<rangle> w = z\<close> \<open>w # q'' = q'\<close>
            distinct.simps(2) list.distinct(1) vpathE vpath_q')
        using \<open>w # q'' = q'\<close> vpath_q' by fastforce
      moreover have "face H' x = y"
        by (metis H'.walkup_axioms H'_def H.faceK \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(node H) \<langle>$\<rangle> w = z\<close>
            \<open>q = y # z # q'\<close> \<open>w # q'' = q'\<close> distinct_length_2_or_more p_def skip_face_def vpathE
            vpath_p walkup.face_walkupF)
      moreover have "face H' y = w"
        by (metis H'.walkup_axioms H'_def H.faceK \<open>face H y = z\<close> \<open>node H w = z\<close> \<open>q = y # z # q'\<close>
            \<open>w # q'' = q'\<close> apply_perm_neq_idI apply_set_perm distinct_length_2_or_more in_set_permI
            p_def skip_face_def vpathE vpath_p walkup.face_walkupF)
      ultimately have "vpath (x#y#q') (clink H')"
        by (metis H'.darts_walkupF H'_def H.hypermap_permF \<open>q = y # z # q'\<close> \<open>w # q'' = q'\<close> dart_x
            dart_y dart_z distinct_length_2_or_more hypermap.clinkF hypermap.hypermap_permN
            hypermap.hypermap_walkupE hypermap.verts_clink insert_Diff insert_iff list.sel(1) p_def
            vpath_def vpath_p vwalk_consI walkupF_def)
      also have "appears_before (y#q') t (node H' x)"
        by (metis H'.node_walkupF H'.walkup_axioms H'_def \<open>(face H') \<langle>$\<rangle> x = y\<close> \<open>(node H) \<langle>$\<rangle> x = y\<close>
            \<open>t = y\<close> \<open>y \<noteq> x\<close> appears_before_cons apply_inj_eq_iff insert_iff list.simps(15)
            skip_face_def skip_perm_invariant walkup.face_walkupF)
      ultimately have "hypermap.moebius_path H' (x#y#q')"
        by (smt (z3) H'.edge_walkupF H'_def H.edgeK H.hypermap_permF \<open>(face H') \<langle>$\<rangle> x = y\<close>
            \<open>(face H) \<langle>$\<rangle> x = y\<close> \<open>(node H) \<langle>$\<rangle> w = z\<close> \<open>q = y # z # q'\<close> \<open>t = y\<close> \<open>w # q'' = q'\<close>
            apply_inj_eq_iff distinct_length_2_or_more hypermap.hypermap_permN
            hypermap.hypermap_walkupE hypermap.moebius_path.simps(3) last_ConsR list.distinct(1)
            p_def skip_perm_invariant t_def vpathE vpath_p walkupF_def)
      then show False
        by (metis H'_def H.hypermap_permF IHf dart_z hypermap.hypermap_permN
            hypermap.hypermap_walkupE hypermap.jordan_def walkupF_def)
    qed
  }
  then show ?case
    by auto
qed

theorem Jordan_planar: "\<lbrakk>hypermap H; hypermap.jordan H\<rbrakk> \<Longrightarrow> planar H"
proof (induction "card (darts H)" arbitrary: H)
  case 0
  then have "darts H = {}"
    by (metis card_0_eq hypermap.finite_darts)
  then have "verts (glink H) = {}"
    by (simp add: cedge_def cface_def cnode_def glink_def)
  then have "pre_digraph.sccs (glink H) = {}"
    by (simp add: "0.prems"(1) hypermap.wf_glink wf_digraph.sccs_empty wf_digraph_wp_iff)
  then have "euler_lhs H = 0"
    by (simp add: "0.hyps" euler_lhs_def)
  also have "euler_rhs H = 0"
    by (metis "0.prems"(1) \<open>darts H = {}\<close> add_eq_0_iff_both_eq_0 euler_rhs_def hypermap.perm_edge
        hypermap.perm_face hypermap.perm_node perm_on.count_cycles_on_empty perm_on.intro)
  ultimately show ?case
    unfolding planar_def genus_def by presburger
next
  case (Suc x)
  then show ?case sorry
qed

end


(*  Title:      HOL/ex/Abstract_NAT.thy
    Author:     Makarius
*)

section \<open>Abstract Natural Numbers primitive recursion\<close>

theory Abstract_NAT
imports Main
begin

text \<open>Axiomatic Natural Numbers (Peano) -- a monomorphic theory.\<close>

locale NAT =
  fixes zero :: 'n
    and succ :: "'n \<Rightarrow> 'n"
  assumes succ_inject [simp]: "succ m = succ n \<longleftrightarrow> m = n"
    and succ_neq_zero [simp]: "succ m \<noteq> zero"
    and induct [case_names zero succ, induct type: 'n]:
      "P zero \<Longrightarrow> (\<And>n. P n \<Longrightarrow> P (succ n)) \<Longrightarrow> P n"
begin

lemma zero_neq_succ [simp]: "zero \<noteq> succ m"
  by (rule succ_neq_zero [symmetric])

text \<open>\<^medskip> Primitive recursion as a (functional) relation -- polymorphic!\<close>

inductive Rec :: "'a \<Rightarrow> ('n \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> 'a \<Rightarrow> bool"
  for e :: 'a and r :: "'n \<Rightarrow> 'a \<Rightarrow> 'a"
where
  Rec_zero: "Rec e r zero e"
| Rec_succ: "Rec e r m n \<Longrightarrow> Rec e r (succ m) (r m n)"

lemma Rec_functional:
  fixes x :: 'n
  shows "\<exists>!y::'a. Rec e r x y"
proof -
  let ?R = "Rec e r"
  show ?thesis
  proof (induct x)
    case zero
    show "\<exists>!y. ?R zero y"
    proof
      show "?R zero e" ..
      show "y = e" if "?R zero y" for y
        using that by cases simp_all
    qed
  next
    case (succ m)
    from \<open>\<exists>!y. ?R m y\<close>
    obtain y where y: "?R m y" and yy': "\<And>y'. ?R m y' \<Longrightarrow> y = y'"
      by blast
    show "\<exists>!z. ?R (succ m) z"
    proof
      from y show "?R (succ m) (r m y)" ..
    next
      fix z
      assume "?R (succ m) z"
      then obtain u where "z = r m u" and "?R m u"
        by cases simp_all
      with yy' show "z = r m y"
        by (simp only:)
    qed
  qed
qed

text \<open>\<^medskip> The recursion operator -- polymorphic!\<close>

definition rec :: "'a \<Rightarrow> ('n \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> 'a"
  where "rec e r x = (THE y. Rec e r x y)"

lemma rec_eval:
  assumes Rec: "Rec e r x y"
  shows "rec e r x = y"
  unfolding rec_def
  using Rec_functional and Rec by (rule the1_equality)

lemma rec_zero [simp]: "rec e r zero = e"
proof (rule rec_eval)
  show "Rec e r zero e" ..
qed

lemma rec_succ [simp]: "rec e r (succ m) = r m (rec e r m)"
proof (rule rec_eval)
  let ?R = "Rec e r"
  have "?R m (rec e r m)"
    unfolding rec_def using Rec_functional by (rule theI')
  then show "?R (succ m) (r m (rec e r m))" ..
qed

text \<open>\<^medskip> Example: addition (monomorphic)\<close>

definition add :: "'n \<Rightarrow> 'n \<Rightarrow> 'n"
  where "add m n = rec n (\<lambda>_ k. succ k) m"

lemma add_zero [simp]: "add zero n = n"
  and add_succ [simp]: "add (succ m) n = succ (add m n)"
  unfolding add_def by simp_all

lemma add_zero_right: "add m zero = m"
  by (induct m) simp_all

lemma add_succ_right: "add m (succ n) = succ (add m n)"
  by (induct m) simp_all

lemma "add (succ (succ (succ zero))) (succ (succ zero)) =
    succ (succ (succ (succ (succ zero))))"
  by simp

text \<open>\<^medskip> Example: replication (polymorphic)\<close>

definition repl :: "'n \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "repl n x = rec [] (\<lambda>_ xs. x # xs) n"

lemma repl_zero [simp]: "repl zero x = []"
  and repl_succ [simp]: "repl (succ n) x = x # repl n x"
  unfolding repl_def by simp_all

lemma "repl (succ (succ (succ zero))) True = [True, True, True]"
  by simp

end

text \<open>\<^medskip> Just see that our abstract specification makes sense \dots\<close>

interpretation NAT 0 Suc
proof (rule NAT.intro)
  fix m n
  show "Suc m = Suc n \<longleftrightarrow> m = n" by simp
  show "Suc m \<noteq> 0" by simp
  show "P n"
    if zero: "P 0"
    and succ: "\<And>n. P n \<Longrightarrow> P (Suc n)"
    for P
  proof (induct n)
    case 0
    show ?case by (rule zero)
  next
    case Suc
    then show ?case by (rule succ)
  qed
qed

end


theory Chapter5Guisen
imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_0: "iter r 0 x x" |
iter_Suc: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

text\<open>
\section*{Chapter 5}

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
(* your definition/proof here *)

text\<open>
Each step should use at most one of the assumptions @{text T}, @{text A}
or @{text TA}.
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
(* your definition/proof here *)

text\<open>
Hint: There are predefined functions @{const take} and {const drop} of type
@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\exercise
Give a structured proof by rule inversion:
\<close>
inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"
lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
(* your definition/proof here *)

text\<open>
\exercise
Give a structured proof by rule inversions:
\<close>

lemma "\<not> ev(Suc(Suc(Suc 0)))"
(* your definition/proof here *)

text\<open>
If there are no cases to be proved you can close
a proof immediateley with \isacom{qed}.
\endexercise

\exercise
Recall predicate @{const star} from Section 4.5 and @{const iter}
from Exercise~\ref{exe:iter}.
\<close>

lemma "iter r n x y \<Longrightarrow> star r x y"
(* your definition/proof here *)

text\<open>
Prove this lemma in a structured style, do not just sledgehammer each case of the
required induction.
\endexercise

\exercise
Define a recursive function
\<close>

fun elems :: "'a list \<Rightarrow> 'a set" where
(* your definition/proof here *)

text\<open> that collects all elements of a list into a set. Prove \<close>

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a recursive function \<close>
(* your definition/proof here *)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open> such that @{term"balanced n w"}
is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove \<close>

corollary "balanced n w \<longleftrightarrow> S (replicate n a @ w)"

text\<open> where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
\<close>

end