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

section {* Groups, also combined with orderings *}

theory Groups
imports Orderings
begin

subsection {* Dynamic facts *}

named_theorems ac_simps "associativity and commutativity simplification rules"

text{* The rewrites accumulated in @{text algebra_simps} 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 @{text field_simps}. *}

named_theorems algebra_simps "algebra simplification rules"

text{* Lemmas @{text field_simps} multiply with denominators in (in)equations
if they can be proved to be non-zero (for equations) or positive/negative
(for inequations). Can be too aggressive and is therefore separate from the
more benign @{text algebra_simps}. *}

named_theorems field_simps "algebra simplification rules for fields"

subsection {* Abstract structures *}

text {*
  These locales provide basic structures for interpretation into
  bigger structures;  extensions require careful thinking, otherwise
  undesired effects may occur due to interpretation.
*}

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

locale abel_semigroup = semigroup +
  assumes commute [ac_simps]: "a * b = b * a"
begin

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

end

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

locale comm_monoid = abel_semigroup +
  fixes z :: 'a ("1")
  assumes comm_neutral: "a * 1 = a"
begin

sublocale monoid
  by default (simp_all add: commute comm_neutral)

end

subsection {* Generic operations *}

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 {*
  Reorient_Proc.add
    (fn Const(@{const_name Groups.zero}, _) => true
      | Const(@{const_name Groups.one}, _) => true
      | _ => false)
*}

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

typed_print_translation {*
  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 "_constrain"} $ Syntax.const c $
          Syntax_Phases.term_of_typ ctxt T
      else raise Match);
  in map tr' [@{const_syntax Groups.one}, @{const_syntax Groups.zero}] end;
*} -- {* show types that are presumably too general *}

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 {* Semigroups and Monoids *}

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

sublocale add!: semigroup plus
  by default (fact add_assoc)

end

hide_fact add_assoc

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

sublocale add!: abel_semigroup plus
  by default (fact add_commute)

declare add.left_commute [algebra_simps, field_simps]

theorems add_ac = add.assoc add.commute add.left_commute

end

hide_fact add_commute

theorems add_ac = add.assoc add.commute add.left_commute

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

sublocale mult!: semigroup times
  by default (fact mult_assoc)

end

hide_fact mult_assoc

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

sublocale mult!: abel_semigroup times
  by default (fact mult_commute)

declare mult.left_commute [algebra_simps, field_simps]

theorems mult_ac = mult.assoc mult.commute mult.left_commute

end

hide_fact mult_commute

theorems 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 default (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

sublocale add!: comm_monoid plus 0
  by default (insert add_0, simp add: ac_simps)

subclass monoid_add
  by default (fact add.left_neutral add.right_neutral)+

end

class comm_monoid_diff = comm_monoid_add + minus +
  assumes diff_zero [simp]: "a - 0 = a"
    and zero_diff [simp]: "0 - a = 0"
    and add_diff_cancel_left [simp]: "(c + a) - (c + b) = a - b"
    and diff_diff_add: "a - b - c = a - (b + c)"
begin

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

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

lemma add_diff_cancel_right' [simp]:
  "(a + b) - b = a"
  using add_diff_cancel_left' [symmetric] by (simp add: add.commute)

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

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 diff_right_commute:
  "a - c - b = a - b - c"
  by (simp add: diff_diff_add add.commute)

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

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 default (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

sublocale mult!: comm_monoid times 1
  by default (insert mult_1, simp add: ac_simps)

subclass monoid_mult
  by default (fact mult.left_neutral mult.right_neutral)+

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 +
  assumes add_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
begin

subclass cancel_semigroup_add
proof
  fix a b c :: 'a
  assume "a + b = a + c"
  then show "b = c" by (rule add_imp_eq)
next
  fix a b c :: 'a
  assume "b + a = c + a"
  then have "a + b = a + c" by (simp only: add.commute)
  then show "b = c" by (rule add_imp_eq)
qed

end

class cancel_comm_monoid_add = cancel_ab_semigroup_add + comm_monoid_add

subsection {* Groups *}

class group_add = minus + uminus + monoid_add +
  assumes left_minus [simp]: "- 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

lemma minus_unique:
  assumes "a + b = 0" shows "- a = b"
proof -
  have "- a = - a + (a + b)" using assms by simp
  also have "\<dots> = b" by (simp add: add.assoc [symmetric])
  finally show ?thesis .
qed

lemma minus_zero [simp]: "- 0 = 0"
proof -
  have "0 + 0 = 0" by (rule add_0_right)
  thus "- 0 = 0" by (rule minus_unique)
qed

lemma minus_minus [simp]: "- (- a) = a"
proof -
  have "- a + a = 0" by (rule left_minus)
  thus "- (- a) = a" by (rule minus_unique)
qed

lemma right_minus: "a + - a = 0"
proof -
  have "a + - a = - (- a) + - a" by simp
  also have "\<dots> = 0" by (rule left_minus)
  finally show ?thesis .
qed

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

subclass cancel_semigroup_add
proof
  fix a b c :: 'a
  assume "a + b = a + c"
  then have "- a + a + b = - a + a + c"
    unfolding add.assoc 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" unfolding add.assoc by simp
qed

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"
proof -
  have "(a + b) + (- b + - a) = 0"
    by (simp only: add.assoc add_minus_cancel) simp
  then show "- (a + b) = - b + - a"
    by (rule minus_unique)
qed

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 `a - b = 0` by simp
  finally show "a = b" .
next
  assume "a = b" thus "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"
  hence "- (- a) = - (- b)" by simp
  thus "a = b" by simp
next
  assume "a = b"
  thus "- 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{*The next two equations can make the simplifier loop!*}

lemma equation_minus_iff:
  "a = - b \<longleftrightarrow> b = - a"
proof -
  have "- (- a) = - b \<longleftrightarrow> - a = b" by (rule neg_equal_iff_equal)
  thus ?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)
  thus ?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, field_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, field_simps]:
  "a - b = c \<longleftrightarrow> a = c + b"
  by auto

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

lemma diff_diff_eq2 [algebra_simps, field_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_add_uminus_conv_diff: "a - b = a + (- b)"
begin

subclass group_add
  proof qed (simp_all add: ab_left_minus ab_add_uminus_conv_diff)

subclass cancel_comm_monoid_add
proof
  fix a b c :: 'a
  assume "a + b = a + c"
  then have "- a + a + b = - a + a + c"
    by (simp only: add.assoc)
  then show "b = c" by simp
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, field_simps]:
  "(a - b) + c = (a + c) - b"
  by (simp add: algebra_simps)

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

lemma diff_add_eq_diff_diff:
  "a - (b + c) = a - b - c"
  using diff_add_eq_diff_diff_swap [of a c b] by (simp add: add.commute)

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

end

subsection {* (Partially) Ordered Groups *}

text {*
  The theory of partially ordered groups is taken from the books:
  \begin{itemize}
  \item \emph{Lattice Theory} by Garret Birkhoff, American Mathematical Society 1979
  \item \emph{Partially Ordered Algebraic Systems}, Pergamon Press 1963
  \end{itemize}
  Most of the used notions can also be looked up in
  \begin{itemize}
  \item @{url "http://www.mathworld.com"} by Eric Weisstein et. al.
  \item \emph{Algebra I} by van der Waerden, Springer.
  \end{itemize}
*}

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 {* non-strict, in both arguments *}
lemma add_mono:
  "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
  apply (erule add_right_mono [THEN order_trans])
  apply (simp add: add.commute add_left_mono)
  done

end

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)

text{*Strict monotonicity in both arguments*}
lemma add_strict_mono:
  "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
apply (erule add_strict_right_mono [THEN less_trans])
apply (erule add_strict_left_mono)
done

lemma add_less_le_mono:
  "a < b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c < b + d"
apply (erule add_strict_right_mono [THEN less_le_trans])
apply (erule add_left_mono)
done

lemma add_le_less_mono:
  "a \<le> b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
apply (erule add_right_mono [THEN le_less_trans])
apply (erule add_strict_left_mono)
done

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 <= c + b" by (simp add: order_le_less)
  have "a <= b"
    apply (insert le)
    apply (drule add_le_imp_le_left)
    by (insert le, drule add_le_imp_le_left, assumption)
  moreover have "a \<noteq> b"
  proof (rule ccontr)
    assume "~(a \<noteq> b)"
    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"
apply (rule add_less_imp_less_left [of c])
apply (simp add: add.commute)
done

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, drule add_le_imp_le_left, simp_all add: 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

class ordered_cancel_comm_monoid_diff = comm_monoid_diff + ordered_ab_semigroup_add_imp_le +
  assumes le_iff_add: "a \<le> b \<longleftrightarrow> (\<exists>c. b = a + c)"
begin

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

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

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

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

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

lemma diff_add_assoc2:
  "b + c - a = b - a + c"
  using `a \<le> b`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 {* Support for reasoning about signs *}

class ordered_comm_monoid_add =
  ordered_cancel_ab_semigroup_add + comm_monoid_add
begin

lemma add_pos_nonneg:
  assumes "0 < a" and "0 \<le> b" shows "0 < a + b"
proof -
  have "0 + 0 < a + b"
    using assms by (rule add_less_le_mono)
  then show ?thesis by simp
qed

lemma add_pos_pos:
  assumes "0 < a" and "0 < b" shows "0 < a + b"
by (rule add_pos_nonneg) (insert assms, auto)

lemma add_nonneg_pos:
  assumes "0 \<le> a" and "0 < b" shows "0 < a + b"
proof -
  have "0 + 0 < a + b"
    using assms by (rule add_le_less_mono)
  then show ?thesis by simp
qed

lemma add_nonneg_nonneg [simp]:
  assumes "0 \<le> a" and "0 \<le> b" shows "0 \<le> a + b"
proof -
  have "0 + 0 \<le> a + b"
    using assms by (rule add_mono)
  then show ?thesis by simp
qed

lemma add_neg_nonpos:
  assumes "a < 0" and "b \<le> 0" shows "a + b < 0"
proof -
  have "a + b < 0 + 0"
    using assms by (rule add_less_le_mono)
  then show ?thesis by simp
qed

lemma add_neg_neg:
  assumes "a < 0" and "b < 0" shows "a + b < 0"
by (rule add_neg_nonpos) (insert assms, auto)

lemma add_nonpos_neg:
  assumes "a \<le> 0" and "b < 0" shows "a + b < 0"
proof -
  have "a + b < 0 + 0"
    using assms by (rule add_le_less_mono)
  then show ?thesis by simp
qed

lemma add_nonpos_nonpos:
  assumes "a \<le> 0" and "b \<le> 0" shows "a + b \<le> 0"
proof -
  have "a + b \<le> 0 + 0"
    using assms by (rule add_mono)
  then show ?thesis by simp
qed

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

lemma add_nonneg_eq_0_iff:
  assumes x: "0 \<le> x" and y: "0 \<le> y"
  shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
proof (intro iffI conjI)
  have "x = x + 0" by simp
  also have "x + 0 \<le> x + y" using y by (rule add_left_mono)
  also assume "x + y = 0"
  also have "0 \<le> x" using x .
  finally show "x = 0" .
next
  have "y = 0 + y" by simp
  also have "0 + y \<le> x + y" using x by (rule add_right_mono)
  also assume "x + y = 0"
  also have "0 \<le> y" using y .
  finally show "y = 0" .
next
  assume "x = 0 \<and> y = 0"
  then show "x + y = 0" by simp
qed

lemma add_increasing:
  "0 \<le> a \<Longrightarrow> b \<le> c \<Longrightarrow> b \<le> a + c"
  by (insert add_mono [of 0 a b c], 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_strict_increasing:
  "0 < a \<Longrightarrow> b \<le> c \<Longrightarrow> b < a + c"
  by (insert add_less_le_mono [of 0 a b c], simp)

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

end

class ordered_ab_group_add =
  ab_group_add + ordered_ab_semigroup_add
begin

subclass ordered_cancel_ab_semigroup_add ..

subclass ordered_ab_semigroup_add_imp_le
proof
  fix a b c :: 'a
  assume "c + a \<le> c + b"
  hence "(-c) + (c + a) \<le> (-c) + (c + b)" by (rule add_left_mono)
  hence "((-c) + c) + a \<le> ((-c) + c) + b" by (simp only: add.assoc)
  thus "a \<le> b" by simp
qed

subclass ordered_comm_monoid_add ..

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

lemma max_diff_distrib_left:
  shows "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:
  shows "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 -
  have "-a+a \<le> -a+b" using `a \<le> 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"
  hence "- (- a) \<le> - (- b)" by (rule le_imp_neg_le)
  thus "a\<le>b" by simp
next
  assume "a\<le>b"
  thus "-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 (force 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{*The next several equations can make the simplifier loop!*}

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

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

lemma le_minus_iff: "a \<le> - b \<longleftrightarrow> b \<le> - a"
proof -
  have mm: "!! a (b::'a). (-(-a)) < -b \<Longrightarrow> -(-b) < -a" by (simp only: minus_less_iff)
  have "(- (- a) <= -b) = (b <= - a)"
    apply (auto simp only: le_less)
    apply (drule mm)
    apply (simp_all)
    apply (drule mm[simplified], assumption)
    done
  then show ?thesis by simp
qed

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 "... \<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, field_simps]:
  "a - b < c \<longleftrightarrow> a < c + b"
apply (subst less_iff_diff_less_0 [of a])
apply (rule less_iff_diff_less_0 [of _ c, THEN ssubst])
apply (simp add: algebra_simps)
done

lemma less_diff_eq[algebra_simps, field_simps]:
  "a < c - b \<longleftrightarrow> a + b < c"
apply (subst less_iff_diff_less_0 [of "a + b"])
apply (subst less_iff_diff_less_0 [of a])
apply (simp add: algebra_simps)
done

lemma diff_le_eq[algebra_simps, field_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, field_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_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

ML_file "Tools/group_cancel.ML"

simproc_setup group_cancel_add ("a + b::'a::ab_group_add") =
  {* fn phi => fn ss => try Group_Cancel.cancel_add_conv *}

simproc_setup group_cancel_diff ("a - b::'a::ab_group_add") =
  {* fn phi => fn ss => try Group_Cancel.cancel_diff_conv *}

simproc_setup group_cancel_eq ("a = (b::'a::ab_group_add)") =
  {* fn phi => fn ss => try Group_Cancel.cancel_eq_conv *}

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

simproc_setup group_cancel_less ("a < (b::'a::ordered_ab_group_add)") =
  {* fn phi => fn ss => try Group_Cancel.cancel_less_conv *}

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 le: "c + a <= c + b"
  show "a <= b"
  proof (rule ccontr)
    assume w: "~ a \<le> b"
    hence "b <= a" by (simp add: linorder_not_le)
    hence le2: "c + b <= c + a" by (rule add_left_mono)
    have "a = b"
      apply (insert le)
      apply (insert le2)
      apply (drule antisym, simp_all)
      done
    with w 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: "- a \<le> a" show "0 \<le> a"
  proof (rule classical)
    assume "\<not> 0 \<le> a"
    then have "a < 0" by auto
    with A have "- a < 0" by (rule le_less_trans)
    then show ?thesis by auto
  qed
next
  assume A: "0 \<le> a" show "- a \<le> a"
  proof (rule order_trans)
    show "- a \<le> 0" using A by (simp add: minus_le_iff)
  next
    show "0 \<le> a" using A .
  qed
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 assm: "a + a = 0"
  then have a: "- a = a" by (rule minus_unique)
  then show "a = 0" by (simp only: neg_equal_zero)
qed simp

lemma double_zero_sym [simp]:
  "0 = a + a \<longleftrightarrow> a = 0"
  by (rule, drule sym) simp_all

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"
begin

notation (xsymbols)
  abs  ("\<bar>_\<bar>")

notation (HTML output)
  abs  ("\<bar>_\<bar>")

end

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

class abs_if = minus + uminus + ord + zero + abs +
  assumes abs_if: "\<bar>a\<bar> = (if a < 0 then - a else a)"

class sgn_if = minus + uminus + zero + one + ord + sgn +
  assumes sgn_if: "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
begin

lemma sgn0 [simp]: "sgn 0 = 0"
  by (simp add:sgn_if)

end

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 antisym)
  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 (rule abs_ge_self)

lemma abs_idempotent [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
by (rule 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 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)
  thus ?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 antisym) simp
  thus "a = 0" by simp
next
  assume "a = 0"
  thus "\<bar>a\<bar> \<le> 0" by simp
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 a: "\<And>x y. x \<le> y \<Longrightarrow> \<not> y < x" by auto
  show ?thesis by (simp add: a)
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 "... = \<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"
by (insert abs_ge_self, blast intro: order_trans)

lemma abs_le_D2: "\<bar>a\<bar> \<le> b \<Longrightarrow> - a \<le> b"
by (insert abs_le_D1 [of "- a"], 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 "... \<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 "... \<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 antisym)
  show "?L \<ge> ?R" by(rule abs_ge_self)
next
  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

subsection {* Tools setup *}

lemma add_mono_thms_linordered_semiring:
  fixes i j k :: "'a\<Colon>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\<Colon>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


theory HSV_tasks_2020 imports Complex_Main begin

section \<open>Task 1: proving that "3 / sqrt 2" is irrational.\<close>

(* In case it is helpful, the following theorem is copied from Chapter 3 of the worksheet. *)
theorem sqrt2_irrational: "sqrt 2 \<notin> \<rat>"
proof auto
  assume "sqrt 2 \<in> \<rat>"
  then obtain m n where
    "n \<noteq> 0" and "\<bar>sqrt 2\<bar> = real m / real n" and "coprime m n"
    by (rule Rats_abs_nat_div_natE)
  hence "\<bar>sqrt 2\<bar>^2 = (real m / real n)^2" by auto
  hence "2 = (real m / real n)^2" by simp
  hence "2 = (real m)^2 / (real n)^2" unfolding power_divide by auto
  hence "2 * (real n)^2 = (real m)^2"
    by (simp add: nonzero_eq_divide_eq `n \<noteq> 0`)
  hence "real (2 * n^2) = (real m)^2" by auto
  hence *: "2 * n^2 = m^2"
    using of_nat_power_eq_of_nat_cancel_iff by blast
  hence "even (m^2)" by presburger
  hence "even m" by simp
  then obtain m' where "m = 2 * m'" by auto
  with * have "2 * n^2 = (2 * m')^2" by auto
  hence "2 * n^2 = 4 * m'^2" by simp
  hence "n^2 = 2 * m'^2" by simp
  hence "even (n^2)" by presburger
  hence "even n" by simp
  with `even m` and `coprime m n` show False by auto
qed

theorem "3 / sqrt 2 \<notin> \<rat>"
  sorry (* TODO: Complete this proof. *)

section \<open>Task 2: Centred pentagonal numbers.\<close>

fun pent :: "nat \<Rightarrow> nat" where
  "pent n = (if n = 0 then 1 else 5 * n + pent (n - 1))"

value "pent 0" (* should be 1 *)
value "pent 1" (* should be 6 *)
value "pent 2" (* should be 16 *)
value "pent 3" (* should be 31 *)

theorem "pent n = (5 * n^2 + 5 * n + 2) div 2"
  sorry (* TODO: Complete this proof. *)

section \<open>Task 3: Lucas numbers.\<close>

fun fib :: "nat \<Rightarrow> nat" where
  "fib n = (if n = 0 then 0 else if n = 1 then 1 else fib (n - 1) + fib (n - 2))"

value "fib 0" (* should be 0 *)
value "fib 1" (* should be 1 *)
value "fib 2" (* should be 1 *)
value "fib 3" (* should be 2 *)

thm fib.induct (* rule induction theorem for fib *)

(* TODO: Complete this task. *)

section \<open>Task 4: Balancing circuits.\<close>

(* Here is a datatype for representing circuits, copied from the worksheet *)

datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

text \<open>Delay (assuming all gates have a delay of 1)\<close>

(* The following "delay" function also appeared in the 2019 coursework exercises. *)

fun delay :: "circuit \<Rightarrow> nat" where
  "delay (NOT c) = 1 + delay c"
| "delay (AND c1 c2) = 1 + max (delay c1) (delay c2)"
| "delay (OR c1 c2) = 1 + max (delay c1) (delay c2)"
| "delay _ = 0"

(* TODO: Complete this task. *)

section \<open>Task 5: Extending with NAND gates.\<close>

(* TODO: Complete this task. *)

end


(*<*)
theory Typed_Arithmetic_Expressions
imports Main
  Untyped_Arithmetic_Expressions
begin
(*>*)

section {* Typed Arithmetic Expressions *}
text {* \label{sec:typed-arith-expr} *}

text {* In this section, we revisit the previously formalized arithmetic expression language
(Section~\ref{sec:untyped-arith-expr}) and augment it with static types. Since types are a
characterization external to the definition of terms, we import the theory to reuse its definitions
and theorems. We complete the definitions with the typing relation and prove type safety through the
progress and preservation theorems.
*}

subsection {* Definitions *}

text {*
The language of arithmetic expressions contains two types for Booleans and natural numbers, which we
model using a datatype:
*}

datatype nbtype = Bool | Nat

(* Definition 8.2.1 *)

text {*
The typing relation serves to assign a type to an expression. It is characterized by the following
inference rules:
\setcounter{equation}{0}
\begin{gather}
  \inferrule {}{\text{true} : \text{Bool}} \\[0.8em]
  \inferrule {}{\text{false} : \text{Bool}} \\[0.8em]
  \inferrule {t_1 : \text{Bool} \\ t_2 : \text{T} \\ t_3 : \text{T}}
    {\text{if } t_1 \text{ then } t_2 \text{ else } t_3 : \text{T}} \\[0.8em]
    \inferrule {}{0 : \text{Nat}} \displaybreak\\[0.8em]
  \inferrule {t_1 : \text{Nat}}{\text{succ } t_1 : \text{Nat}} \\[0.8em]
  \inferrule {t_1 : \text{Nat}}{\text{pred } t_1 : \text{Nat}} \\[0.8em]
  \inferrule {t_1 : \text{Nat}}{\text{iszero } t_1 : \text{Bool}}
\end{gather}

The first, second and fourth rules give the type of constants. The third rule requires that both
branches of a conditional have the same type and that the condition is a Boolean. The fifth and
sixth rules state that the successor and predecessor of natural numbers are natural numbers
themselves. Finally, the seventh rule state that the test of equality with zero requires a natural
number and leads a Boolean. We translate these rules in an inductive definition, for which we also
provide the @{text "|:|"} operator as a more conventional notation:
*}

inductive has_type :: "nbterm \<Rightarrow> nbtype \<Rightarrow> bool" (infix "|:|" 150) where
  \<comment> \<open>Rules relating to the type of Booleans\<close>
  has_type_NBTrue:
    "NBTrue |:| Bool" |
  has_type_NBFalse:
    "NBFalse |:| Bool" |
  has_type_NBIf:
    "t1 |:| Bool \<Longrightarrow> t2 |:| T \<Longrightarrow> t3 |:| T \<Longrightarrow> NBIf t1 t2 t3 |:| T" |

  \<comment> \<open>Rules relating to the type of natural numbers\<close>
  has_type_NBZero:
    "NBZero |:| Nat" |
  has_type_NBSucc:
    "t |:| Nat \<Longrightarrow> NBSucc t |:| Nat" |
  has_type_NBPred:
    "t |:| Nat \<Longrightarrow> NBPred t |:| Nat" |
  has_type_NBIs_zero:
    "t |:| Nat \<Longrightarrow> NBIs_zero t |:| Bool"

(* Lemma 8.2.2 *)

text {*
The inversion of the typing relation gives us information on types for specific terms:
*}

lemma inversion_of_typing_relation:
  "NBTrue |:| R \<Longrightarrow> R = Bool"
  "NBFalse |:| R \<Longrightarrow> R = Bool"
  "NBIf t1 t2 t3 |:| R \<Longrightarrow> t1 |:| Bool \<and> t2 |:| R \<and> t3 |:| R"
  "NBZero |:| R \<Longrightarrow> R = Nat"
  "NBSucc t |:| R \<Longrightarrow> R = Nat \<and> t |:| Nat"
  "NBPred t |:| R \<Longrightarrow> R = Nat \<and> t |:| Nat"
  "NBIs_zero t |:| R \<Longrightarrow> R = Bool \<and> t |:| Nat"
by (auto elim: has_type.cases)

(* Theorem 8.2.4 *)

text {*
In the typed arithmetic language, every term @{term t} has at most one type. That is, if @{term t}
is typable, then its type is unique:
*}

theorem uniqueness_of_types:
  "t |:| T \<Longrightarrow> t |:| T' \<Longrightarrow> T = T'"
by (induction t T rule: has_type.induct) (auto dest: inversion_of_typing_relation)

subsection {* Safety = Progress + Preservation *}

text {*
The most basic property a type system must provide is \emph{safety}, also called \emph{soundness}:
the evaluation of a well-typed term will not reach a state whose semantics is undefined. Since our
\emph{operational semantics} is based the of the evaluation relation and the value predicate, every
term that does not fit in one or the other has no defined semantics.

An example of an undefined state is @{term "NBSucc NBTrue"}: there is no further evaluation
step possible but it is not a value neither. In our current language, there is nothing we can do
with this term.
*}

(* Lemma 8.3.1 *)

text {*
Another usefull lemma is the canonical form of values which, for well typed terms, give us
information on the nature of the terms:
*}

lemma canonical_form:
  "is_value_NB v \<Longrightarrow> v |:| Bool \<Longrightarrow> v = NBTrue \<or> v = NBFalse"
  "is_value_NB v \<Longrightarrow> v |:| Nat \<Longrightarrow> is_numeric_value_NB v"
by (auto elim: has_type.cases is_value_NB.cases is_numeric_value_NB.cases)

(* Theorem 8.3.2 *)

text {*
The safety of a type system can be shown in two step: progress and preservation. Progress means that
a well-typed term is not stuck, i.e. either it is a value or it can take a step according to the
evaluation rules.
*}

theorem progress:
  "t |:| T \<Longrightarrow> is_value_NB t \<or> (\<exists>t'. eval1_NB t t')"
proof (induction t T rule: has_type.induct)
  case (has_type_NBPred t)
  thus ?case
    by (auto intro: eval1_NB.intros is_numeric_value_NB.cases dest: canonical_form)
next
  case (has_type_NBIs_zero t)
  thus ?case
    by (auto intro: eval1_NB.intros is_numeric_value_NB.cases dest: canonical_form)
qed (auto
  intro: eval1_NB.intros is_value_NB.intros is_numeric_value_NB.intros
  dest: canonical_form)

(* Theorem 8.3.3 *)

text {*
Preservation means that if a well-typed term takes a step of evaluation, then the resulting term is
also well-typed.
*}

theorem preservation: "t |:| T \<Longrightarrow> eval1_NB t t' \<Longrightarrow> t' |:| T"
proof (induction t T arbitrary: t' rule: has_type.induct)
  case (has_type_NBIf t1 t2 T t3)
  from has_type_NBIf.prems has_type_NBIf.IH has_type_NBIf.hyps show ?case
    by (auto intro: has_type.intros elim: eval1_NB.cases)
qed (auto
  intro: has_type.intros
  dest: inversion_of_typing_relation
  elim: eval1_NB.cases)

(*<*)
end
(*>*)


theory nanocop_propositional imports Main
begin

(*--List Set Operations----*)
primrec member (infix\<open>|\<in>|\<close> 200) where
  \<open>(_ |\<in>| []) = False\<close> |
  \<open>(x |\<in>| (x' # xs)) = ((x = x') \<or> (x |\<in>| xs))\<close>

lemma member_simp[simp]: \<open>x |\<in>| xs \<longleftrightarrow> x \<in> (set xs)\<close>
  by (induct xs) simp_all

abbreviation notmember (infix \<open>|\<notin>|\<close> 200) where \<open>x |\<notin>| xs \<equiv> \<not> x |\<in>| xs\<close>

definition \<open>linsert x xs \<equiv> (if (x |\<in>| xs) then xs else x # xs)\<close>

lemma linsert_is_insert: \<open>set (linsert x xs) = insert x (set xs)\<close>
  by (induct xs) (simp_all add: linsert_def insert_absorb)

primrec subseteq (infix \<open>|\<subseteq>|\<close> 120) where
  \<open>([] |\<subseteq>| _) = True\<close> |
  \<open>((x # xs) |\<subseteq>| ys) = ((x |\<in>| ys) \<and> (xs |\<subseteq>| ys))\<close>

lemma subseteq_simp[simp]: \<open>xs |\<subseteq>| ys \<longleftrightarrow> (set xs) \<subseteq> (set ys)\<close>
  by (induct xs) simp_all

primrec lremove where
  \<open>lremove _ [] = []\<close> |
  \<open>lremove x (y # ys) = (if y = x then lremove x ys else y # (lremove x ys))\<close>

lemma lremove_simp[simp]: \<open>set (lremove x xs) = (set xs) - {x}\<close>
  by (induct xs) (simp_all add: insert_Diff_if)

primrec lminus (infix \<open>|-|\<close> 210) where
  \<open>xs |-| [] = xs\<close> |
  \<open>xs |-| (y # ys) = (lremove y xs) |-| ys\<close>

lemma hoist_lremove:\<open>set ((lremove x xs) |-| ys) = set (lremove x (xs |-| ys))\<close>
  apply (induct ys arbitrary: x xs)
   apply simp
  by (metis Diff_insert Diff_insert2 lminus.simps(2) lremove_simp)

lemma lminus_simp[simp]: \<open>set (xs |-| ys) = (set xs) - (set ys)\<close>
proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  have \<open>set (xs |-| (y # ys)) = set (xs |-| ys) - {y}\<close>
    by (simp add: hoist_lremove)
  then show ?case
    using Cons.hyps by force
qed

definition lequal (infix \<open>|=|\<close> 120) where \<open>xs |=| ys \<equiv> xs |\<subseteq>| ys \<and> ys |\<subseteq>| xs\<close>

lemma lequal_simp[simp]: \<open>xs |=| ys \<longleftrightarrow> (set xs) = (set ys)\<close>
  by (simp add: lequal_def set_eq_subset)

primrec lunion (infix \<open>|\<union>|\<close> 110) where
  \<open>lunion xs [] = xs\<close> |
  \<open>lunion xs (y # ys) = (if y |\<in>| xs then lunion xs ys else y # (lunion xs ys))\<close>

lemma lunion_simp[simp]: \<open>set (xs |\<union>| ys) = set xs \<union> set ys\<close>
  by (induct ys) auto

primrec isset where
  \<open>isset [] = True\<close> |
  \<open>isset (x # xs) = (x |\<notin>| xs \<and> isset xs)\<close>

lemma isset_length: \<open>isset xs \<Longrightarrow> size xs = size (sorted_list_of_set (set xs))\<close>
  by (induct xs) simp_all

primrec union_many where
  \<open>union_many [] = {}\<close> |
  \<open>union_many (xs # ys) = xs \<union> (union_many ys)\<close>

fun count where
  \<open>count x [] = 0\<close> |
  \<open>count x (y # ys) = (if x = y then Suc (count x ys) else count x ys)\<close>

lemma count_0: \<open>count x xs = 0 \<longleftrightarrow> x \<notin> set xs\<close>
  by (induct xs) auto

lemma count_1: \<open>count x ys \<ge> 1 \<longleftrightarrow> x \<in> set ys\<close>
  by (induct ys) (simp_all | force)

fun remove where
  \<open>remove x [] = []\<close> |
  \<open>remove x (y # ys) = (
    if x = y
    then ys
    else y # remove x ys)\<close>

lemma remove_length: \<open>member x ys \<Longrightarrow> length ys = length (remove x ys) + 1\<close>
  by (induct ys) auto

lemma remove_set: \<open>member x ys \<Longrightarrow> set ([x] |\<union>| (remove x ys)) = set ys\<close>
  by (induct ys) (auto|force)

lemma remove_count: \<open>member x ys \<Longrightarrow> count x ys = count x (remove x ys) + 1\<close>
  by (induct ys) auto

lemma remove_count2: \<open>x \<noteq> y \<Longrightarrow> count x ys = count x (remove y ys)\<close>
proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons z ys)
  consider (1)\<open>z = y\<close> | (2)\<open>z \<noteq> y\<close> by fast
  then show ?case
  proof cases
    case 1
    then have \<open>count x (remove y (z # ys)) = count x ys\<close>
      by simp
    moreover have \<open>x \<noteq> z \<Longrightarrow> count x ys = count x (z # ys)\<close>
      by simp
    ultimately show ?thesis
      by (metis "1" Cons.prems)
  next
    case 2
    show ?thesis
        using Cons.hyps Cons.prems by auto
  qed
qed

fun permutation where
  \<open>permutation [] [] = True\<close> |
  \<open>permutation _ [] = False\<close> |
  \<open>permutation [] _ = False\<close> |
  \<open>permutation (x # xs) ys = (
    member x ys \<and>
    permutation xs (remove x ys))\<close>

lemma permutation_count: \<open>permutation xs ys \<longleftrightarrow> (\<forall> x. count x xs = count x ys)\<close>
proof (induct xs arbitrary: ys)
  case Nil
  then show ?case by
      (metis count.simps(1) count_0 list.set_intros(1) neq_Nil_conv permutation.simps(1)
        permutation.simps(3))
next
  case (Cons x xs)
  have rimp: \<open>permutation (x # xs) ys \<Longrightarrow> (\<forall> y. count y (x # xs) = count y ys)\<close>
  proof
    fix y
    assume asm:\<open>permutation (x # xs) ys\<close>
    consider (1) \<open>x = y\<close> | (2) \<open>x \<noteq> y\<close> by fast
    then show \<open>count y (x # xs) = count y ys\<close>
    proof cases
      case 1
      have \<open>member x ys\<close>
        using asm permutation.elims(2) by blast
      then have \<open>count x ys = count x (remove x ys) + 1\<close>
        by (simp add: remove_count)
      then show ?thesis
        using 1 asm local.Cons permutation.elims(2) permutation.simps(4) remove.simps(2)
        by fastforce
    next
      case 2
      then have \<open>count y ys = count y (remove x ys)\<close> sorry
      moreover have \<open>count y xs = count y (x # xs)\<close> using 2 by auto
      ultimately show ?thesis using asm
        by (smt (verit, ccfv_threshold) list.inject local.Cons permutation.elims(2))
    qed
  qed
  have limp: \<open>(\<forall> y. count y (x # xs) = count y ys) \<Longrightarrow> permutation (x # xs) ys\<close>
  proof-
    assume \<open>(\<forall> y. count y (x # xs) = count y ys)\<close>
    show \<open>permutation (x # xs) ys\<close> sorry
  qed
  then show ?case using limp rimp by fast
qed

lemma permutation_alt: \<open>permutation xs ys \<Longrightarrow> length xs = length ys \<and> set xs = set ys\<close>
proof (induct xs arbitrary: ys)
  case Nil
  then show ?case using permutation.elims(2) by auto
next
  case (Cons x xs)
  have \<open>member x ys\<close>
    using Cons.prems permutation.elims(2) by blast
  then have \<open>length (x # xs) = length ys\<close>
    using remove_length
    by (smt (verit, ccfv_threshold) Cons.hyps Cons.prems list.inject
        member.simps(2) permutation.elims(2) remove.simps(2))
  moreover have \<open>member x xs \<Longrightarrow> set (x # xs) = set ys\<close>
    by (smt (verit) Cons.hyps Cons.prems insert_absorb list.inject list.simps(15) lunion_simp
        member_simp permutation.elims(2) remove_set sup.left_idem)
  ultimately show ?case sorry
qed

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

(*--------NaNoCop----------*)
datatype mat
  = Lit bool nat
  | Mat \<open>(nat \<times> (nat \<times> mat) list) list\<close>

fun exi_clause where
  \<open>exi_clause P (_,Lit _ _) = False\<close> |
  \<open>exi_clause P (_,Mat []) = False\<close> |
  \<open>exi_clause P (mid,Mat ((cid,ms) # cs)) =
  (P (cid,ms) \<or> (\<exists> m \<in> set ms. exi_clause P m) \<or> exi_clause P (mid,Mat cs))\<close>

definition \<open>exi_mat P m \<equiv> P m \<or> exi_clause (\<lambda> (_,ms). \<exists> m' \<in> set ms. P m') m\<close>

fun all_clause where
  \<open>all_clause P (_,Lit _ _) = True\<close> |
  \<open>all_clause P (_,Mat []) = True\<close> |
  \<open>all_clause P (mid,Mat ((cid,ms) # cs)) =
  (P (cid,ms) \<and> (\<forall> m \<in> set ms. all_clause P m) \<and> all_clause P (mid,Mat cs))\<close>

definition \<open>all_mat P m \<equiv> P m \<and> all_clause (\<lambda> (_,ms). \<forall> m' \<in> set ms. P m') m\<close>

definition \<open>contains_cls c m \<equiv> exi_clause (\<lambda> c'. c = c') m\<close>

definition \<open>contains_mat m1 m2 \<equiv> exi_mat (\<lambda> m'. m' = m1) m2\<close>

definition \<open>id_exists idty m \<equiv> exi_clause (\<lambda> (n,_). n = idty) m \<or> exi_mat (\<lambda> (n,_). n = idty) m\<close>

fun siblings where
  \<open>siblings c1 c2 (_,Lit _ _) = False\<close> |
  \<open>siblings c1 c2 (_,Mat cs) = (member c1 cs \<and> member c2 cs)\<close>

abbreviation \<open>
  alpha_top_level c l m \<equiv> (\<exists> cid' c'.
    c \<noteq> (cid',c') \<and>
    siblings c (cid',c') m \<and>
    (\<exists> m' \<in> set c'. contains_mat l m'))\<close>

definition \<open>extension_clause M P C \<equiv> True\<close>

(*fun beta_clause where
  \<open>beta_clause l [] = []\<close> |
  \<open>beta_clause l ((Lit pol prop) # ms) = (
    if l = (pol,prop)
    then ms
    else (Lit pol prop) # (beta_clause l ms))\<close> |
  \<open>beta_clause l ((Mat []) # ms) = \<close>*)

inductive CC (\<open>\<turnstile> _ _ _\<close> 0) where
Axiom: \<open>\<turnstile> [] _ _\<close> |
Reduction: \<open>
  (\<turnstile> C M ((lid,pol,prp) # P)) \<Longrightarrow>
  pol \<longleftrightarrow> \<not>pol' \<Longrightarrow>
  (\<turnstile> ((_,Lit pol' prp) # C) M ((lid,pol,prp) # P))\<close> |
Permutation: \<open>
  (\<turnstile> C M P) \<Longrightarrow>
  permutation C C' \<Longrightarrow> permutation P P' \<Longrightarrow>
  (\<turnstile> C' M P')\<close> |
Extention: \<open>
  (\<turnstile> C' M ((lid,pol,prp) # P)) \<Longrightarrow>
  contains_cls (cid,C') (0,Mat M) \<Longrightarrow>
  extension_clause M P (cid,C')  \<Longrightarrow>
  (\<turnstile> C M P) \<Longrightarrow>
  (\<turnstile> ((lid,Lit pol prp) # C) M P)\<close> |
Decomposition: \<open>
  (\<turnstile> (C' @ C) M P) \<Longrightarrow>
  member (_,C') cs \<Longrightarrow>
  (\<turnstile> ((mid,Mat cs) # C) M P)\<close>

fun CC_mat where
  \<open>CC_mat (Lit _ _) = False\<close> |
  \<open>CC_mat (Mat []) = False\<close> |
  \<open>CC_mat (Mat ((cid,c) # m)) = (\<turnstile> c ((cid,c) # m) [])\<close>
(*-------------------------*)

(*---Generic Prop Forms----*)
datatype 'a gen_forms
  = Atm 'a
  | Neg \<open>'a gen_forms\<close>
  | Con \<open>'a gen_forms\<close> \<open>'a gen_forms\<close>
  | Dis \<open>'a gen_forms\<close> \<open>'a gen_forms\<close>
  | Imp \<open>'a gen_forms\<close> \<open>'a gen_forms\<close>

fun form_to_clauses where
  \<open>form_to_clauses mx pol (Atm n) = (mx + 1,(mx,Lit pol n))\<close> |
  \<open>form_to_clauses mx pol (Neg p) = form_to_clauses mx (\<not>pol) p\<close> |
  \<open>form_to_clauses mx True (Con p1 p2) = (
    let (nmx,mat1) = form_to_clauses (mx + 3) True p1 in
    let (nnmx,mat2) = form_to_clauses nmx True p2 in
    (nnmx,(mx,Mat [(mx + 1,[mat1]),(mx + 2,[mat2])])))\<close> |
  \<open>form_to_clauses mx False (Dis p1 p2) = (
    let (nmx,mat1) = form_to_clauses (mx + 3) False p1 in
    let (nnmx,mat2) = form_to_clauses nmx False p2 in
    (nnmx,(mx,Mat [(mx + 1,[mat1]),(mx + 2,[mat2])])))\<close> |
  \<open>form_to_clauses mx False (Imp p1 p2) = (
    let (nmx,mat1) = form_to_clauses (mx + 3) True p1 in
    let (nnmx,mat2) = form_to_clauses nmx False p2 in
    (nnmx,(mx,Mat [(mx + 1,[mat1]),(mx + 2,[mat2])])))\<close> |
  \<open>form_to_clauses mx False (Con p1 p2) = (
    let (nmx,mat1) = form_to_clauses (mx + 2) False p1 in
    let (nnmx,mat2) = form_to_clauses nmx False p2 in
    (nnmx,(mx,Mat [(mx + 1,[mat1, mat2])])))\<close> |
  \<open>form_to_clauses mx True (Dis p1 p2) = (
    let (nmx,mat1) = form_to_clauses (mx + 2) True p1 in
    let (nnmx,mat2) = form_to_clauses nmx True p2 in
    (nnmx,(mx,Mat [(mx + 1,[mat1, mat2])])))\<close> |
  \<open>form_to_clauses mx True (Imp p1 p2) = (
    let (nmx,mat1) = form_to_clauses (mx + 2) False p1 in
    let (nnmx,mat2) = form_to_clauses nmx True p2 in
    (nnmx,(mx,Mat [(mx + 1,[mat1, mat2])])))\<close>

fun collaps_mat and collaps_clause where
  \<open>collaps_mat (mid,Lit pol prp) = (mid,Lit pol prp)\<close> |
  \<open>collaps_mat (mid,Mat [(_,[(mid2,Mat cs)])]) = collaps_mat (mid,Mat cs)\<close> |
  \<open>collaps_mat (mid,Mat cs) = (mid,Mat (map collaps_clause cs))\<close> |
  \<open>collaps_clause (cid,[(mid,Mat [c])]) = collaps_clause c\<close> |
  \<open>collaps_clause (cid,ms) = (cid, (map collaps_mat ms))\<close>

(*prove idunique here*)

value \<open>form_to_clauses 0 False (Imp (Con (Imp (Atm 0) (Atm 1)) (Atm 0)) (Atm 1))\<close>
value \<open>collaps_mat
(0,
  Mat [(1, [(3, Mat [(4, [(6, Mat [(7, [(8, Lit False 0), (9, Lit True 1)])])]),
                     (5, [(10, Lit True 0)])])]),
       (2, [(11, Lit False 1)])])\<close>

lemma \<open>CC_mat (
  Mat [
    (0, [(5,Mat [
      (1, [(6,Mat [(2, [(7,Lit False 0), (8,Lit True 1)])])]),
      (3, [(9,Lit True 0)])])]),
    (4, [(10,Lit False 1)])])\<close> (is \<open>CC_mat (Mat ?M)\<close>)
proof -
  have ?thesis if \<open>(\<turnstile>
    [(5,Mat [
      (1, [(6,Mat [(2, [(7,Lit False 0), (8,Lit True 1)])])]),
      (3, [(9,Lit True 0)])])] ?M [])\<close>
    using that by simp
  then have ?thesis if \<open>(\<turnstile>
    [(9,Lit True 0)] ?M [])\<close>
    using that Decomposition by simp
  moreover have \<open>alpha_related ?M (4,[(10,Lit False 1)]) (9,Lit True 0)\<close>sorry
  ultimately have ?thesis if \<open>(\<turnstile>
    [(10,Lit False 1)] ?M [(9,True, 0)])\<close>
    using that Extention Axiom sorry
  then have ?thesis if \<open>(\<turnstile>
    [Lit False 0, Lit True 1] ?M [(False,1),(True, 0)])\<close>
    using that Extention Axiom by simp
  then have ?thesis if \<open>(\<turnstile>
    [Lit False 0, Lit True 1] ?M [(True, 0),(False,1)])\<close>
    using that Permutation by simp
  then have ?thesis if \<open>(\<turnstile>
    [Lit True 1] ?M [(True, 0),(False,1)])\<close>
    using that Reduction by fast
  then have ?thesis if \<open>(\<turnstile>
    [Lit True 1] ?M [(False,1),(True, 0)])\<close>
    using that Permutation by simp
  then show ?thesis using Reduction Axiom by simp
qed
(*-------------------------*)

(*---Paths-----------------*)
fun is_path where
  \<open>is_path p (Lit pol prop) = member (pol, prop) p\<close> |
  \<open>is_path p (Mat cs) = (\<forall> (_,ms) \<in> set cs. \<exists> m \<in> set ms. is_path p m)\<close>

definition \<open>
  cc_valid c m p \<equiv>
    \<forall> p'. is_path p' m \<longrightarrow> (\<exists> m' \<in> set c. is_path p m') \<longrightarrow> set p \<subseteq> set p' \<longrightarrow>
      (\<exists> prop. member (True,prop) p \<and> member (False,prop) p)\<close>

theorem cc_soundness: \<open>(\<turnstile> c m p) \<Longrightarrow> cc_valid c m p\<close>
proof (induct rule: CC.induct)
  case (Axiom uu uv)
  then show ?case
    using cc_valid_def by simp
next
  case (Reduction C M pol prp P pol')
  then show ?case sorry
next
  case (Permutation C M P C' P')
  then show ?case sorry
next
  case (Extention C' M pol prp P C)
  then show ?case sorry
next
  case (Decomposition C' C M P uw cs)
  then show ?case sorry
qed

definition \<open>
  mat_valid m \<equiv> \<forall> p. is_path p m \<longrightarrow> (\<exists> prop. member (True,prop) p \<and> member (False,prop) p)\<close>

theorem mat_soundness: \<open>cc_valid c (Mat ((cid,c) # m)) [] \<Longrightarrow> mat_valid (Mat ((cid,c) # m))\<close> sorry
(*-------------------------*)

(*---Semantics-------------*)
primrec form_semantics where
  \<open>form_semantics i (Atm a) = i a\<close> |
  \<open>form_semantics i (Neg p) = (\<not>form_semantics i p)\<close> |
  \<open>form_semantics i (Con p1 p2) = (form_semantics i p1 \<and> form_semantics i p2)\<close> |
  \<open>form_semantics i (Dis p1 p2) = (form_semantics i p1 \<or> form_semantics i p2)\<close> |
  \<open>form_semantics i (Imp p1 p2) = (form_semantics i p1 \<longrightarrow> form_semantics i p2)\<close>

fun mat_semantics where
  \<open>mat_semantics i (Lit pol prp) = (i prp \<longleftrightarrow> \<not>pol)\<close> |
  \<open>mat_semantics i (Mat cs) = (\<exists> (c,ms) \<in> set cs. \<forall> m \<in> set ms. mat_semantics i m)\<close>

lemma path_to_semantics_soundness: \<open>
  mat_valid m \<Longrightarrow> \<forall> i. mat_semantics i m\<close> sorry

lemma mat_to_form: \<open>
  form_to_clauses mx pol p = (n,m) \<Longrightarrow>
  mat_semantics i m \<Longrightarrow>
  (\<not>pol \<longleftrightarrow> form_semantics i p)\<close>
proof (induct p arbitrary: mx pol n m)
  case (Atm a)
  then show ?case by auto
next
  case (Neg p)
  then show ?case
    by auto
next
  case (Con p1 p2)
  then show ?case sorry
next
  case (Dis p1 p2)
  then show ?case sorry
next
  case (Imp p1 p2)
  then show ?case sorry
qed

theorem form_soundness: \<open>
  form_to_clauses 0 False p = (n,Mat ((cid,c) # cs)) \<Longrightarrow>
  (\<turnstile> c (Mat ((cid,c) # cs)) []) \<Longrightarrow>
  \<forall> i. form_semantics i p\<close> (is \<open>?translation \<Longrightarrow> ?proof \<Longrightarrow> ?valid\<close>)
proof-
  let ?m = \<open>Mat ((cid,c) # cs)\<close>
  assume t:?translation
  assume ?proof
  then have \<open>mat_valid ?m\<close>
    by (simp add: cc_soundness mat_soundness)
  then have \<open>\<forall> i. mat_semantics i ?m\<close>
    using path_to_semantics_soundness by blast
  then show ?valid
    using mat_to_form t by blast
qed

end


(*  Title:      HOL/Library/Infinite_Set.thy
    Author:     Stephan Merz
*)

section \<open>Infinite Sets and Related Concepts\<close>

theory Infinite_Set
  imports "MainRLT"
begin

subsection \<open>The set of natural numbers is infinite\<close>

lemma infinite_nat_iff_unbounded_le: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n\<ge>m. n \<in> S)"
  for S :: "nat set"
  using frequently_cofinite[of "\<lambda>x. x \<in> S"]
  by (simp add: cofinite_eq_sequentially frequently_def eventually_sequentially)

lemma infinite_nat_iff_unbounded: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n>m. n \<in> S)"
  for S :: "nat set"
  using frequently_cofinite[of "\<lambda>x. x \<in> S"]
  by (simp add: cofinite_eq_sequentially frequently_def eventually_at_top_dense)

lemma finite_nat_iff_bounded: "finite S \<longleftrightarrow> (\<exists>k. S \<subseteq> {..<k})"
  for S :: "nat set"
  using infinite_nat_iff_unbounded_le[of S] by (simp add: subset_eq) (metis not_le)

lemma finite_nat_iff_bounded_le: "finite S \<longleftrightarrow> (\<exists>k. S \<subseteq> {.. k})"
  for S :: "nat set"
  using infinite_nat_iff_unbounded[of S] by (simp add: subset_eq) (metis not_le)

lemma finite_nat_bounded: "finite S \<Longrightarrow> \<exists>k. S \<subseteq> {..<k}"
  for S :: "nat set"
  by (simp add: finite_nat_iff_bounded)

text \<open>
  For a set of natural numbers to be infinite, it is enough to know
  that for any number larger than some \<open>k\<close>, there is some larger
  number that is an element of the set.
\<close>

lemma unbounded_k_infinite: "\<forall>m>k. \<exists>n>m. n \<in> S \<Longrightarrow> infinite (S::nat set)"
  apply (clarsimp simp add: finite_nat_set_iff_bounded)
  apply (drule_tac x="Suc (max m k)" in spec)
  using less_Suc_eq apply fastforce
  done

lemma nat_not_finite: "finite (UNIV::nat set) \<Longrightarrow> R"
  by simp

lemma range_inj_infinite:
  fixes f :: "nat \<Rightarrow> 'a"
  assumes "inj f"
  shows "infinite (range f)"
proof
  assume "finite (range f)"
  from this assms have "finite (UNIV::nat set)"
    by (rule finite_imageD)
  then show False by simp
qed

subsection \<open>The set of integers is also infinite\<close>

lemma infinite_int_iff_infinite_nat_abs: "infinite S \<longleftrightarrow> infinite ((nat \<circ> abs) ` S)"
  for S :: "int set"
proof (unfold Not_eq_iff, rule iffI)
  assume "finite ((nat \<circ> abs) ` S)"
  then have "finite (nat ` (abs ` S))"
    by (simp add: image_image cong: image_cong)
  moreover have "inj_on nat (abs ` S)"
    by (rule inj_onI) auto
  ultimately have "finite (abs ` S)"
    by (rule finite_imageD)
  then show "finite S"
    by (rule finite_image_absD)
qed simp

proposition infinite_int_iff_unbounded_le: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n. \<bar>n\<bar> \<ge> m \<and> n \<in> S)"
  for S :: "int set"
  by (simp add: infinite_int_iff_infinite_nat_abs infinite_nat_iff_unbounded_le o_def image_def)
    (metis abs_ge_zero nat_le_eq_zle le_nat_iff)

proposition infinite_int_iff_unbounded: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n. \<bar>n\<bar> > m \<and> n \<in> S)"
  for S :: "int set"
  by (simp add: infinite_int_iff_infinite_nat_abs infinite_nat_iff_unbounded o_def image_def)
    (metis (full_types) nat_le_iff nat_mono not_le)

proposition finite_int_iff_bounded: "finite S \<longleftrightarrow> (\<exists>k. abs ` S \<subseteq> {..<k})"
  for S :: "int set"
  using infinite_int_iff_unbounded_le[of S] by (simp add: subset_eq) (metis not_le)

proposition finite_int_iff_bounded_le: "finite S \<longleftrightarrow> (\<exists>k. abs ` S \<subseteq> {.. k})"
  for S :: "int set"
  using infinite_int_iff_unbounded[of S] by (simp add: subset_eq) (metis not_le)

subsection \<open>Infinitely Many and Almost All\<close>

text \<open>
  We often need to reason about the existence of infinitely many
  (resp., all but finitely many) objects satisfying some predicate, so
  we introduce corresponding binders and their proof rules.
\<close>

lemma not_INFM [simp]: "\<not> (INFM x. P x) \<longleftrightarrow> (MOST x. \<not> P x)"
  by (rule not_frequently)

lemma not_MOST [simp]: "\<not> (MOST x. P x) \<longleftrightarrow> (INFM x. \<not> P x)"
  by (rule not_eventually)

lemma INFM_const [simp]: "(INFM x::'a. P) \<longleftrightarrow> P \<and> infinite (UNIV::'a set)"
  by (simp add: frequently_const_iff)

lemma MOST_const [simp]: "(MOST x::'a. P) \<longleftrightarrow> P \<or> finite (UNIV::'a set)"
  by (simp add: eventually_const_iff)

lemma INFM_imp_distrib: "(INFM x. P x \<longrightarrow> Q x) \<longleftrightarrow> ((MOST x. P x) \<longrightarrow> (INFM x. Q x))"
  by (rule frequently_imp_iff)

lemma MOST_imp_iff: "MOST x. P x \<Longrightarrow> (MOST x. P x \<longrightarrow> Q x) \<longleftrightarrow> (MOST x. Q x)"
  by (auto intro: eventually_rev_mp eventually_mono)

lemma INFM_conjI: "INFM x. P x \<Longrightarrow> MOST x. Q x \<Longrightarrow> INFM x. P x \<and> Q x"
  by (rule frequently_rev_mp[of P]) (auto elim: eventually_mono)

text \<open>Properties of quantifiers with injective functions.\<close>

lemma INFM_inj: "INFM x. P (f x) \<Longrightarrow> inj f \<Longrightarrow> INFM x. P x"
  using finite_vimageI[of "{x. P x}" f] by (auto simp: frequently_cofinite)

lemma MOST_inj: "MOST x. P x \<Longrightarrow> inj f \<Longrightarrow> MOST x. P (f x)"
  using finite_vimageI[of "{x. \<not> P x}" f] by (auto simp: eventually_cofinite)

text \<open>Properties of quantifiers with singletons.\<close>

lemma not_INFM_eq [simp]:
  "\<not> (INFM x. x = a)"
  "\<not> (INFM x. a = x)"
  unfolding frequently_cofinite by simp_all

lemma MOST_neq [simp]:
  "MOST x. x \<noteq> a"
  "MOST x. a \<noteq> x"
  unfolding eventually_cofinite by simp_all

lemma INFM_neq [simp]:
  "(INFM x::'a. x \<noteq> a) \<longleftrightarrow> infinite (UNIV::'a set)"
  "(INFM x::'a. a \<noteq> x) \<longleftrightarrow> infinite (UNIV::'a set)"
  unfolding frequently_cofinite by simp_all

lemma MOST_eq [simp]:
  "(MOST x::'a. x = a) \<longleftrightarrow> finite (UNIV::'a set)"
  "(MOST x::'a. a = x) \<longleftrightarrow> finite (UNIV::'a set)"
  unfolding eventually_cofinite by simp_all

lemma MOST_eq_imp:
  "MOST x. x = a \<longrightarrow> P x"
  "MOST x. a = x \<longrightarrow> P x"
  unfolding eventually_cofinite by simp_all

text \<open>Properties of quantifiers over the naturals.\<close>

lemma MOST_nat: "(\<forall>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<exists>m. \<forall>n>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (auto simp add: eventually_cofinite finite_nat_iff_bounded_le subset_eq simp flip: not_le)

lemma MOST_nat_le: "(\<forall>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<exists>m. \<forall>n\<ge>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (auto simp add: eventually_cofinite finite_nat_iff_bounded subset_eq simp flip: not_le)

lemma INFM_nat: "(\<exists>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<forall>m. \<exists>n>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (simp add: frequently_cofinite infinite_nat_iff_unbounded)

lemma INFM_nat_le: "(\<exists>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<forall>m. \<exists>n\<ge>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (simp add: frequently_cofinite infinite_nat_iff_unbounded_le)

lemma MOST_INFM: "infinite (UNIV::'a set) \<Longrightarrow> MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
  by (simp add: eventually_frequently)

lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
  by (simp add: cofinite_eq_sequentially)

lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
  and MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
  by (simp_all add: MOST_Suc_iff)

lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
  by (simp add: cofinite_eq_sequentially)

\<comment> \<open>legacy names\<close>
lemma Inf_many_def: "Inf_many P \<longleftrightarrow> infinite {x. P x}" by (fact frequently_cofinite)
lemma Alm_all_def: "Alm_all P \<longleftrightarrow> \<not> (INFM x. \<not> P x)" by simp
lemma INFM_iff_infinite: "(INFM x. P x) \<longleftrightarrow> infinite {x. P x}" by (fact frequently_cofinite)
lemma MOST_iff_cofinite: "(MOST x. P x) \<longleftrightarrow> finite {x. \<not> P x}" by (fact eventually_cofinite)
lemma INFM_EX: "(\<exists>\<^sub>\<infinity>x. P x) \<Longrightarrow> (\<exists>x. P x)" by (fact frequently_ex)
lemma ALL_MOST: "\<forall>x. P x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. P x" by (fact always_eventually)
lemma INFM_mono: "\<exists>\<^sub>\<infinity>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> \<exists>\<^sub>\<infinity>x. Q x" by (fact frequently_elim1)
lemma MOST_mono: "\<forall>\<^sub>\<infinity>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> \<forall>\<^sub>\<infinity>x. Q x" by (fact eventually_mono)
lemma INFM_disj_distrib: "(\<exists>\<^sub>\<infinity>x. P x \<or> Q x) \<longleftrightarrow> (\<exists>\<^sub>\<infinity>x. P x) \<or> (\<exists>\<^sub>\<infinity>x. Q x)" by (fact frequently_disj_iff)
lemma MOST_rev_mp: "\<forall>\<^sub>\<infinity>x. P x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. P x \<longrightarrow> Q x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. Q x" by (fact eventually_rev_mp)
lemma MOST_conj_distrib: "(\<forall>\<^sub>\<infinity>x. P x \<and> Q x) \<longleftrightarrow> (\<forall>\<^sub>\<infinity>x. P x) \<and> (\<forall>\<^sub>\<infinity>x. Q x)" by (fact eventually_conj_iff)
lemma MOST_conjI: "MOST x. P x \<Longrightarrow> MOST x. Q x \<Longrightarrow> MOST x. P x \<and> Q x" by (fact eventually_conj)
lemma INFM_finite_Bex_distrib: "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)" by (fact frequently_bex_finite_distrib)
lemma MOST_finite_Ball_distrib: "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)" by (fact eventually_ball_finite_distrib)
lemma INFM_E: "INFM x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> thesis) \<Longrightarrow> thesis" by (fact frequentlyE)
lemma MOST_I: "(\<And>x. P x) \<Longrightarrow> MOST x. P x" by (rule eventuallyI)
lemmas MOST_iff_finiteNeg = MOST_iff_cofinite

subsection \<open>Enumeration of an Infinite Set\<close>

text \<open>The set's element type must be wellordered (e.g. the natural numbers).\<close>

text \<open>
  Could be generalized to
    \<^prop>\<open>enumerate' S n = (SOME t. t \<in> s \<and> finite {s\<in>S. s < t} \<and> card {s\<in>S. s < t} = n)\<close>.
\<close>

primrec (in wellorder) enumerate :: "'a set \<Rightarrow> nat \<Rightarrow> 'a"
  where
    enumerate_0: "enumerate S 0 = (LEAST n. n \<in> S)"
  | enumerate_Suc: "enumerate S (Suc n) = enumerate (S - {LEAST n. n \<in> S}) n"

lemma enumerate_Suc': "enumerate S (Suc n) = enumerate (S - {enumerate S 0}) n"
  by simp

lemma enumerate_in_set: "infinite S \<Longrightarrow> enumerate S n \<in> S"
proof (induct n arbitrary: S)
  case 0
  then show ?case
    by (fastforce intro: LeastI dest!: infinite_imp_nonempty)
next
  case (Suc n)
  then show ?case
    by simp (metis DiffE infinite_remove)
qed

declare enumerate_0 [simp del] enumerate_Suc [simp del]

lemma enumerate_step: "infinite S \<Longrightarrow> enumerate S n < enumerate S (Suc n)"
proof (induction n arbitrary: S)
  case 0
  then have "enumerate S 0 \<le> enumerate S (Suc 0)"
    by (simp add: enumerate_0 Least_le enumerate_in_set)
  moreover have "enumerate (S - {enumerate S 0}) 0 \<in> S - {enumerate S 0}"
    by (meson "0.prems" enumerate_in_set infinite_remove)
  then have "enumerate S 0 \<noteq> enumerate (S - {enumerate S 0}) 0"
    by auto
  ultimately show ?case
    by (simp add: enumerate_Suc')
next
  case (Suc n)
  then show ?case
    by (simp add: enumerate_Suc')
qed

lemma enumerate_mono: "m < n \<Longrightarrow> infinite S \<Longrightarrow> enumerate S m < enumerate S n"
  by (induct m n rule: less_Suc_induct) (auto intro: enumerate_step)

lemma enumerate_mono_iff [simp]:
  "infinite S \<Longrightarrow> enumerate S m < enumerate S n \<longleftrightarrow> m < n"
  by (metis enumerate_mono less_asym less_linear)

lemma le_enumerate:
  assumes S: "infinite S"
  shows "n \<le> enumerate S n"
  using S
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "n \<le> enumerate S n" by simp
  also note enumerate_mono[of n "Suc n", OF _ \<open>infinite S\<close>]
  finally show ?case by simp
qed

lemma infinite_enumerate:
  assumes fS: "infinite S"
  shows "\<exists>r::nat\<Rightarrow>nat. strict_mono r \<and> (\<forall>n. r n \<in> S)"
  unfolding strict_mono_def
  using enumerate_in_set[OF fS] enumerate_mono[of _ _ S] fS by blast

lemma enumerate_Suc'':
  fixes S :: "'a::wellorder set"
  assumes "infinite S"
  shows "enumerate S (Suc n) = (LEAST s. s \<in> S \<and> enumerate S n < s)"
  using assms
proof (induct n arbitrary: S)
  case 0
  then have "\<forall>s \<in> S. enumerate S 0 \<le> s"
    by (auto simp: enumerate.simps intro: Least_le)
  then show ?case
    unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"]
    by (intro arg_cong[where f = Least] ext) auto
next
  case (Suc n S)
  show ?case
    using enumerate_mono[OF zero_less_Suc \<open>infinite S\<close>, of n] \<open>infinite S\<close>
    apply (subst (1 2) enumerate_Suc')
    apply (subst Suc)
     apply (use \<open>infinite S\<close> in simp)
    apply (intro arg_cong[where f = Least] ext)
    apply (auto simp flip: enumerate_Suc')
    done
qed

lemma enumerate_Ex:
  fixes S :: "nat set"
  assumes S: "infinite S"
    and s: "s \<in> S"
  shows "\<exists>n. enumerate S n = s"
  using s
proof (induct s rule: less_induct)
  case (less s)
  show ?case
  proof (cases "\<exists>y\<in>S. y < s")
    case True
    let ?y = "Max {s'\<in>S. s' < s}"
    from True have y: "\<And>x. ?y < x \<longleftrightarrow> (\<forall>s'\<in>S. s' < s \<longrightarrow> s' < x)"
      by (subst Max_less_iff) auto
    then have y_in: "?y \<in> {s'\<in>S. s' < s}"
      by (intro Max_in) auto
    with less.hyps[of ?y] obtain n where "enumerate S n = ?y"
      by auto
    with S have "enumerate S (Suc n) = s"
      by (auto simp: y less enumerate_Suc'' intro!: Least_equality)
    then show ?thesis by auto
  next
    case False
    then have "\<forall>t\<in>S. s \<le> t" by auto
    with \<open>s \<in> S\<close> show ?thesis
      by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0)
  qed
qed

lemma inj_enumerate:
  fixes S :: "'a::wellorder set"
  assumes S: "infinite S"
  shows "inj (enumerate S)"
  unfolding inj_on_def
proof clarsimp
  show "\<And>x y. enumerate S x = enumerate S y \<Longrightarrow> x = y"
    by (metis neq_iff enumerate_mono[OF _ \<open>infinite S\<close>])
qed

text \<open>To generalise this, we'd need a condition that all initial segments were finite\<close>
lemma bij_enumerate:
  fixes S :: "nat set"
  assumes S: "infinite S"
  shows "bij_betw (enumerate S) UNIV S"
proof -
  have "\<forall>s \<in> S. \<exists>i. enumerate S i = s"
    using enumerate_Ex[OF S] by auto
  moreover note \<open>infinite S\<close> inj_enumerate
  ultimately show ?thesis
    unfolding bij_betw_def by (auto intro: enumerate_in_set)
qed

lemma
  fixes S :: "nat set"
  assumes S: "infinite S"
  shows range_enumerate: "range (enumerate S) = S"
    and strict_mono_enumerate: "strict_mono (enumerate S)"
  by (auto simp add: bij_betw_imp_surj_on bij_enumerate assms strict_mono_def)

text \<open>A pair of weird and wonderful lemmas from HOL Light.\<close>
lemma finite_transitivity_chain:
  assumes "finite A"
    and R: "\<And>x. \<not> R x x" "\<And>x y z. \<lbrakk>R x y; R y z\<rbrakk> \<Longrightarrow> R x z"
    and A: "\<And>x. x \<in> A \<Longrightarrow> \<exists>y. y \<in> A \<and> R x y"
  shows "A = {}"
  using \<open>finite A\<close> A
proof (induct A)
  case empty
  then show ?case by simp
next
  case (insert a A)
  have False
    using R(1)[of a] R(2)[of _ a] insert(3,4) by blast
  thus ?case ..
qed

corollary Union_maximal_sets:
  assumes "finite \<F>"
  shows "\<Union>{T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} = \<Union>\<F>"
    (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs" by force
  show "?rhs \<subseteq> ?lhs"
  proof (rule Union_subsetI)
    fix S
    assume "S \<in> \<F>"
    have "{T \<in> \<F>. S \<subseteq> T} = {}"
      if "\<not> (\<exists>y. y \<in> {T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} \<and> S \<subseteq> y)"
    proof -
      have \<section>: "\<And>x. x \<in> \<F> \<and> S \<subseteq> x \<Longrightarrow> \<exists>y. y \<in> \<F> \<and> S \<subseteq> y \<and> x \<subset> y"
        using that by (blast intro: dual_order.trans psubset_imp_subset)
      show ?thesis
      proof (rule finite_transitivity_chain [of _ "\<lambda>T U. S \<subseteq> T \<and> T \<subset> U"])
      qed (use assms in \<open>auto intro: \<section>\<close>)
    qed
    with \<open>S \<in> \<F>\<close> show "\<exists>y. y \<in> {T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} \<and> S \<subseteq> y"
      by blast
  qed
qed

subsection \<open>Properties of @{term enumerate} on finite sets\<close>

lemma finite_enumerate_in_set: "\<lbrakk>finite S; n < card S\<rbrakk> \<Longrightarrow> enumerate S n \<in> S"
proof (induction n arbitrary: S)
  case 0
  then show ?case
    by (metis all_not_in_conv card.empty enumerate.simps(1) not_less0 wellorder_Least_lemma(1))
next
  case (Suc n)
  show ?case
    using Suc.prems Suc.IH [of "S - {LEAST n. n \<in> S}"]
    apply (simp add: enumerate.simps)
    by (metis Diff_empty Diff_insert0 Suc_lessD card.remove less_Suc_eq)
qed

lemma finite_enumerate_step: "\<lbrakk>finite S; Suc n < card S\<rbrakk> \<Longrightarrow> enumerate S n < enumerate S (Suc n)"
proof (induction n arbitrary: S)
  case 0
  then have "enumerate S 0 \<le> enumerate S (Suc 0)"
    by (simp add: Least_le enumerate.simps(1) finite_enumerate_in_set)
  moreover have "enumerate (S - {enumerate S 0}) 0 \<in> S - {enumerate S 0}"
    by (metis 0 Suc_lessD Suc_less_eq card_Suc_Diff1 enumerate_in_set finite_enumerate_in_set)
  then have "enumerate S 0 \<noteq> enumerate (S - {enumerate S 0}) 0"
    by auto
  ultimately show ?case
    by (simp add: enumerate_Suc')
next
  case (Suc n)
  then show ?case
    by (simp add: enumerate_Suc' finite_enumerate_in_set)
qed

lemma finite_enumerate_mono: "\<lbrakk>m < n; finite S; n < card S\<rbrakk> \<Longrightarrow> enumerate S m < enumerate S n"
  by (induct m n rule: less_Suc_induct) (auto intro: finite_enumerate_step)

lemma finite_enumerate_mono_iff [simp]:
  "\<lbrakk>finite S; m < card S; n < card S\<rbrakk> \<Longrightarrow> enumerate S m < enumerate S n \<longleftrightarrow> m < n"
  by (metis finite_enumerate_mono less_asym less_linear)

lemma finite_le_enumerate:
  assumes "finite S" "n < card S"
  shows "n \<le> enumerate S n"
  using assms
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "n \<le> enumerate S n" by simp
  also note finite_enumerate_mono[of n "Suc n", OF _ \<open>finite S\<close>]
  finally show ?case
    using Suc.prems(2) Suc_leI by blast
qed

lemma finite_enumerate:
  assumes fS: "finite S"
  shows "\<exists>r::nat\<Rightarrow>nat. strict_mono_on r {..<card S} \<and> (\<forall>n<card S. r n \<in> S)"
  unfolding strict_mono_def
  using finite_enumerate_in_set[OF fS] finite_enumerate_mono[of _ _ S] fS
  by (metis lessThan_iff strict_mono_on_def)

lemma finite_enumerate_Suc'':
  fixes S :: "'a::wellorder set"
  assumes "finite S" "Suc n < card S"
  shows "enumerate S (Suc n) = (LEAST s. s \<in> S \<and> enumerate S n < s)"
  using assms
proof (induction n arbitrary: S)
  case 0
  then have "\<forall>s \<in> S. enumerate S 0 \<le> s"
    by (auto simp: enumerate.simps intro: Least_le)
  then show ?case
    unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"]
    by (metis Diff_iff dual_order.strict_iff_order singletonD singletonI)
next
  case (Suc n S)
  then have "Suc n < card (S - {enumerate S 0})"
    using Suc.prems(2) finite_enumerate_in_set by force
  then show ?case
    apply (subst (1 2) enumerate_Suc')
    apply (simp add: Suc)
    apply (intro arg_cong[where f = Least] HOL.ext)
    using finite_enumerate_mono[OF zero_less_Suc \<open>finite S\<close>, of n] Suc.prems
    by (auto simp flip: enumerate_Suc')
qed

lemma finite_enumerate_initial_segment:
  fixes S :: "'a::wellorder set"
  assumes "finite S" and n: "n < card (S \<inter> {..<s})"
  shows "enumerate (S \<inter> {..<s}) n = enumerate S n"
  using n
proof (induction n)
  case 0
  have "(LEAST n. n \<in> S \<and> n < s) = (LEAST n. n \<in> S)"
  proof (rule Least_equality)
    have "\<exists>t. t \<in> S \<and> t < s"
      by (metis "0" card_gt_0_iff disjoint_iff_not_equal lessThan_iff)
    then show "(LEAST n. n \<in> S) \<in> S \<and> (LEAST n. n \<in> S) < s"
      by (meson LeastI Least_le le_less_trans)
  qed (simp add: Least_le)
  then show ?case
    by (auto simp: enumerate_0)
next
  case (Suc n)
  then have less_card: "Suc n < card S"
    by (meson assms(1) card_mono inf_sup_ord(1) leD le_less_linear order.trans)
  obtain T where T: "T \<in> {s \<in> S. enumerate S n < s}"
    by (metis Infinite_Set.enumerate_step enumerate_in_set finite_enumerate_in_set finite_enumerate_step less_card mem_Collect_eq)
  have "(LEAST x. x \<in> S \<and> x < s \<and> enumerate S n < x) = (LEAST x. x \<in> S \<and> enumerate S n < x)"
       (is "_ = ?r")
  proof (intro Least_equality conjI)
    show "?r \<in> S"
      by (metis (mono_tags, lifting) LeastI mem_Collect_eq T)
    have "\<not> s \<le> ?r"
      using not_less_Least [of _ "\<lambda>x. x \<in> S \<and> enumerate S n < x"] Suc assms
      by (metis (mono_tags, lifting) Int_Collect Suc_lessD finite_Int finite_enumerate_in_set finite_enumerate_step lessThan_def less_le_trans)
    then show "?r < s"
      by auto
    show "enumerate S n < ?r"
      by (metis (no_types, lifting) LeastI mem_Collect_eq T)
  qed (auto simp: Least_le)
  then show ?case
    using Suc assms by (simp add: finite_enumerate_Suc'' less_card)
qed

lemma finite_enumerate_Ex:
  fixes S :: "'a::wellorder set"
  assumes S: "finite S"
    and s: "s \<in> S"
  shows "\<exists>n<card S. enumerate S n = s"
  using s S
proof (induction s arbitrary: S rule: less_induct)
  case (less s)
  show ?case
  proof (cases "\<exists>y\<in>S. y < s")
    case True
    let ?T = "S \<inter> {..<s}"
    have "finite ?T"
      using less.prems(2) by blast
    have TS: "card ?T < card S"
      using less.prems by (blast intro: psubset_card_mono [OF \<open>finite S\<close>])
    from True have y: "\<And>x. Max ?T < x \<longleftrightarrow> (\<forall>s'\<in>S. s' < s \<longrightarrow> s' < x)"
      by (subst Max_less_iff) (auto simp: \<open>finite ?T\<close>)
    then have y_in: "Max ?T \<in> {s'\<in>S. s' < s}"
      using Max_in \<open>finite ?T\<close> by fastforce
    with less.IH[of "Max ?T" ?T] obtain n where n: "enumerate ?T n = Max ?T" "n < card ?T"
      using \<open>finite ?T\<close> by blast
    then have "Suc n < card S"
      using TS less_trans_Suc by blast
    with S n have "enumerate S (Suc n) = s"
      by (subst finite_enumerate_Suc'') (auto simp: y finite_enumerate_initial_segment less finite_enumerate_Suc'' intro!: Least_equality)
    then show ?thesis
      using \<open>Suc n < card S\<close> by blast
  next
    case False
    then have "\<forall>t\<in>S. s \<le> t" by auto
    moreover have "0 < card S"
      using card_0_eq less.prems by blast
    ultimately show ?thesis
      using \<open>s \<in> S\<close>
      by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0)
  qed
qed

lemma finite_enum_subset:
  assumes "\<And>i. i < card X \<Longrightarrow> enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X \<le> card Y"
  shows "X \<subseteq> Y"
  by (metis assms finite_enumerate_Ex finite_enumerate_in_set less_le_trans subsetI)

lemma finite_enum_ext:
  assumes "\<And>i. i < card X \<Longrightarrow> enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X = card Y"
  shows "X = Y"
  by (intro antisym finite_enum_subset) (auto simp: assms)

lemma finite_bij_enumerate:
  fixes S :: "'a::wellorder set"
  assumes S: "finite S"
  shows "bij_betw (enumerate S) {..<card S} S"
proof -
  have "\<And>n m. \<lbrakk>n \<noteq> m; n < card S; m < card S\<rbrakk> \<Longrightarrow> enumerate S n \<noteq> enumerate S m"
    using finite_enumerate_mono[OF _ \<open>finite S\<close>] by (auto simp: neq_iff)
  then have "inj_on (enumerate S) {..<card S}"
    by (auto simp: inj_on_def)
  moreover have "\<forall>s \<in> S. \<exists>i<card S. enumerate S i = s"
    using finite_enumerate_Ex[OF S] by auto
  moreover note \<open>finite S\<close>
  ultimately show ?thesis
    unfolding bij_betw_def by (auto intro: finite_enumerate_in_set)
qed

lemma ex_bij_betw_strict_mono_card:
  fixes M :: "'a::wellorder set"
  assumes "finite M"
  obtains h where "bij_betw h {..<card M} M" and "strict_mono_on h {..<card M}"
proof
  show "bij_betw (enumerate M) {..<card M} M"
    by (simp add: assms finite_bij_enumerate)
  show "strict_mono_on (enumerate M) {..<card M}"
    by (simp add: assms finite_enumerate_mono strict_mono_on_def)
qed

end


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

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = Z"
| "t2 (S z) (Z) = S z"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "((t2 (t22 k m) (t22 k n)) = (t2 m n))"
  find_proof DInd
  apply (induct arbitrary: n rule: TIP_prop_08.t22.induct)
   apply auto
  done

theorem property0' :
  "((t2 (t22 k m) (t22 k n)) = (t2 m n))"
  apply(induct k arbitrary:n m)(*equivalent to apply (induct arbitrary: n rule: TIP_prop_08.t22.induct)*)
   apply auto
  done

theorem property0'' :
  "((t2 (t22 k m) (t22 k n)) = (t2 m n))"
  (*applying induction on "k" is the natural choice:
    "t22" is the unique innermost recursive constant, which pattern-matches on the first parameter.
    Furthermore, the other recursive function, "t2" takes "t22" in its arguments, and
    the two "t22"s have different arguments ("m" and "n"). Therefore, without applying induction on
    "t22"'s argument we cannot finish this proof.*)
  apply(induct k)
   apply auto
  done

theorem property0''' :(*sub-optimal proof*)
  "((t2 (t22 k m) (t22 k n)) = (t2 m n))"
  apply(induct m)
   apply clarsimp
   apply(induct k)(*extra induction*)
    apply fastforce+
  apply(induct k)(*extra induction*)
   apply auto
  done

end


theory ListLexorder
imports Main
begin

section\<open>Detour: Lexicographic ordering for lists\<close>
text\<open>Simplicial complexes are defined as sets of sets.
To conveniently run computations on them, we convert those sets to lists via @{const sorted_list_of_set}.
This requires providing an arbitrary linear order for lists.
We pick a lexicographic order.\<close>

(* There's probably an easier way to get a sorted list of lists from a set of lists. Some lexicographic ordering does have to exist. No idea... *)

datatype 'a :: linorder linorder_list = LinorderList "'a list"

definition "linorder_list_unwrap L \<equiv> case L of LinorderList L \<Rightarrow> L" (* Meh, there is a way to get datatype to generate this. I forgot *)

fun less_eq_linorder_list_pre where
  "less_eq_linorder_list_pre (LinorderList []) (LinorderList []) = True" |
  "less_eq_linorder_list_pre (LinorderList []) _ = True" |
  "less_eq_linorder_list_pre _ (LinorderList []) = False" |
  "less_eq_linorder_list_pre (LinorderList (a # as)) (LinorderList (b # bs))
    = (if a = b then less_eq_linorder_list_pre (LinorderList as) (LinorderList bs) else a < b)"

instantiation linorder_list :: (linorder) linorder
begin
definition "less_linorder_list x y \<equiv>
              (less_eq_linorder_list_pre x y \<and> \<not> less_eq_linorder_list_pre y x)"
definition "less_eq_linorder_list x y \<equiv> less_eq_linorder_list_pre x y"
instance
proof (standard; unfold less_eq_linorder_list_def less_linorder_list_def)
  fix x y z
  show "less_eq_linorder_list_pre x x"
  proof(induction x)
    case (LinorderList xa)
    then show ?case by(induction xa; simp)
  qed
  show "less_eq_linorder_list_pre x y \<Longrightarrow> less_eq_linorder_list_pre y x \<Longrightarrow> x = y"
    by(induction x y rule: less_eq_linorder_list_pre.induct; simp split: if_splits)
  show "less_eq_linorder_list_pre x y \<or> less_eq_linorder_list_pre y x"
    by(induction x y rule: less_eq_linorder_list_pre.induct; auto)
  show "less_eq_linorder_list_pre x y \<Longrightarrow> less_eq_linorder_list_pre y z \<Longrightarrow> less_eq_linorder_list_pre x z"
  proof(induction x z arbitrary: y rule: less_eq_linorder_list_pre.induct)
    case (3 va vb)
    then show ?case
      using less_eq_linorder_list_pre.elims(2) by blast
  next
    case (4 a1 as b1 bs)
    obtain y1 ys where y: "y = LinorderList (y1 # ys)"
      using "4.prems"(1) less_eq_linorder_list_pre.elims(2) by blast
    then show ?case proof(cases "a1 = b1")
      case True
      have prems: "less_eq_linorder_list_pre (LinorderList as) (LinorderList ys)" "less_eq_linorder_list_pre (LinorderList ys) (LinorderList bs)"
        by (metis "4.prems" True y less_eq_linorder_list_pre.simps(4) not_less_iff_gr_or_eq)+
      note IH = "4.IH"[OF _ this]
      then show ?thesis
        using True by simp

    next
      case False
        then show ?thesis using "4.prems" less_trans y by (simp  split: if_splits)
      qed
  qed simp_all
qed simp

end

text\<open>The main product of this theory file:\<close>
definition "sorted_list_of_list_set L \<equiv>
  map linorder_list_unwrap (sorted_list_of_set (LinorderList ` L))"

lemma set_sorted_list_of_list_set[simp]:
  "finite L \<Longrightarrow> set (sorted_list_of_list_set L) = L"
  by(force simp add: sorted_list_of_list_set_def linorder_list_unwrap_def)

end