(*
  Copyright (c) 2014-2019 by Clemens Ballarin
  This file is licensed under the 3-clause BSD license.
*)

theory Set_Theory imports "HOL-Library.FuncSet" begin

hide_const map
hide_const partition

no_notation divide (infixl "'/" 70)
no_notation inverse_divide (infixl "'/" 70)

text \<open>
  Each statement in the formal text is annotated with the location of the originating statement
  in Jacobson's text @{cite Jacobson1985}.  Each fact that Jacobson states explicitly is marked
  as @{command theorem} unless it is translated to a @{command sublocale} declaration.
  Literal quotations from Jacobson's text are reproduced in double quotes.

  Auxiliary results needed for the formalisation that cannot be found in Jacobson's text are marked
  as @{command lemma} or are @{command interpretation}s.  Such results are annotated with the
  location of a related statement.  For example, the introduction rule of a constant is annotated
  with the location of the definition of the corresponding operation.
\<close>

section \<open>Concepts from Set Theory.  The Integers\<close>

subsection \<open>The Cartesian Product Set.  Maps\<close>

text \<open>Maps as extensional HOL functions\<close>
text \<open>p 5, ll 21--25\<close>
locale map =
  fixes \<alpha> and S and T
  assumes graph [intro, simp]: "\<alpha> \<in> S \<rightarrow>\<^sub>E T"
begin

text \<open>p 5, ll 21--25\<close>
lemma map_closed [intro, simp]:
  "a \<in> S \<Longrightarrow> \<alpha> a \<in> T"
using graph by fast

text \<open>p 5, ll 21--25\<close>
lemma map_undefined [intro]:
  "a \<notin> S \<Longrightarrow> \<alpha> a = undefined"
using graph by fast

end (* map *)

text \<open>p 7, ll 7--8\<close>
locale surjective_map = map + assumes surjective [intro]: "\<alpha> ` S = T"

text \<open>p 7, ll 8--9\<close>
locale injective_map = map + assumes injective [intro, simp]: "inj_on \<alpha> S"

text \<open>Enables locale reasoning about the inverse @{term "restrict (inv_into S \<alpha>) T"} of @{term \<alpha>}.\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective =
  fixes \<alpha> and S and T
  assumes bijective [intro, simp]: "bij_betw \<alpha> S T"

text \<open>
  Exploit existing knowledge about @{term bij_betw} rather than extending @{locale surjective_map}
  and @{locale injective_map}.
\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective_map = map + bijective begin

text \<open>p 7, ll 9--10\<close>
sublocale surjective_map by unfold_locales (simp add: bij_betw_imp_surj_on)

text \<open>p 7, ll 9--10\<close>
sublocale injective_map using bij_betw_def by unfold_locales fast

text \<open>p 9, ll 12--13\<close>
sublocale inverse: map "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: inv_into_into surjective)

text \<open>p 9, ll 12--13\<close>
sublocale inverse: bijective "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: bij_betw_inv_into surjective)

end (* bijective_map *)

text \<open>p 8, ll 14--15\<close>
abbreviation "identity S \<equiv> (\<lambda>x \<in> S. x)"

context map begin

text \<open>p 8, ll 18--20; p 9, ll 1--8\<close>
theorem bij_betw_iff_has_inverse:
  "bij_betw \<alpha> S T \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. compose S \<beta> \<alpha> = identity S \<and> compose T \<alpha> \<beta> = identity T)"
    (is "_ \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>)")
proof
  let ?inv = "restrict (inv_into S \<alpha>) T"
  assume "bij_betw \<alpha> S T"
  then have "?INV ?inv" and "?inv \<in> T \<rightarrow>\<^sub>E S"
    by (simp_all add: compose_inv_into_id bij_betw_imp_surj_on compose_id_inv_into bij_betw_imp_funcset bij_betw_inv_into)
  then show "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>" ..
next
  assume "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>"
  then obtain \<beta> where "\<alpha> \<in> S \<rightarrow> T" "\<beta> \<in> T \<rightarrow> S" "\<And>x. x \<in> S \<Longrightarrow> \<beta> (\<alpha> x) = x" "\<And>y. y \<in> T \<Longrightarrow> \<alpha> (\<beta> y) = y"
    by (metis PiE_restrict compose_eq graph restrict_PiE restrict_apply)
  then show "bij_betw \<alpha> S T" by (rule bij_betwI)
qed

end (* map *)

subsection \<open>Equivalence Relations.  Factoring a Map Through an Equivalence Relation\<close>

text \<open>p 11, ll 6--11\<close>
locale equivalence =
  fixes S and E
  assumes closed [intro, simp]: "E \<subseteq> S \<times> S"
    and reflexive [intro, simp]: "a \<in> S \<Longrightarrow> (a, a) \<in> E"
    and symmetric [sym]: "(a, b) \<in> E \<Longrightarrow> (b, a) \<in> E"
    and transitive [trans]: "\<lbrakk> (a, b) \<in> E; (b, c) \<in> E \<rbrakk> \<Longrightarrow> (a, c) \<in> E"
begin

text \<open>p 11, ll 6--11\<close>
lemma left_closed [intro]: (* inefficient as a simp rule *)
  "(a, b) \<in> E \<Longrightarrow> a \<in> S"
  using closed by blast

text \<open>p 11, ll 6--11\<close>

end (* equivalence *)

text \<open>p 11, ll 16--20\<close>
locale partition =
  fixes S and P
  assumes subset: "P \<subseteq> Pow S"
    and non_vacuous: "{} \<notin> P"
    and complete: "\<Union>P = S"
    and disjoint: "\<lbrakk> A \<in> P; B \<in> P; A \<noteq> B \<rbrakk> \<Longrightarrow> A \<inter> B = {}"

context equivalence begin

text \<open>p 11, ll 24--26\<close>
definition "Class = (\<lambda>a \<in> S. {b \<in> S. (b, a) \<in> E})"

text \<open>p 11, ll 24--26\<close>
lemma Class_closed [dest]:
  "\<lbrakk> a \<in> Class b; b \<in> S \<rbrakk> \<Longrightarrow> a \<in> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_closed2 [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<subseteq> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Class a = undefined"
  unfolding Class_def by simp

text \<open>p 11, ll 24--26\<close>
lemma ClassI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> a \<in> Class b"
  unfolding Class_def by (simp add: left_closed right_closed)

text \<open>p 11, ll 24--26\<close>
lemma Class_revI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> b \<in> Class a"
  by (blast intro: symmetric)

text \<open>p 11, ll 24--26\<close>
lemma ClassD [dest]:
  "\<lbrakk> b \<in> Class a; a \<in> S \<rbrakk> \<Longrightarrow> (b, a) \<in> E"
  unfolding Class_def by simp

text \<open>p 11, ll 30--31\<close>
theorem Class_self [intro, simp]:
  "a \<in> S \<Longrightarrow> a \<in> Class a"
  unfolding Class_def by simp

text \<open>p 11, l 31; p 12, l 1\<close>
theorem Class_Union [simp]:
  "(\<Union>a\<in>S. Class a) = S"
  by blast

text \<open>p 11, ll 2--3\<close>
theorem Class_subset:
  "(a, b) \<in> E \<Longrightarrow> Class a \<subseteq> Class b"
proof
  fix a and b and c
  assume "(a, b) \<in> E" and "c \<in> Class a"
  then have "(c, a) \<in> E" by auto
  also note \<open>(a, b) \<in> E\<close>
  finally have "(c, b) \<in> E" by simp
  then show "c \<in> Class b" by auto
qed

text \<open>p 11, ll 3--4\<close>
theorem Class_eq:
  "(a, b) \<in> E \<Longrightarrow> Class a = Class b"
  by (auto intro!: Class_subset intro: symmetric)

text \<open>p 12, ll 1--5\<close>
theorem Class_equivalence:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> (a, b) \<in> E"
proof
  fix a and b
  assume "a \<in> S" "b \<in> S" "Class a = Class b"
  then have "a \<in> Class a" by auto
  also note \<open>Class a = Class b\<close>
  finally show "(a, b) \<in> E" by (fast intro: \<open>b \<in> S\<close>)
qed (rule Class_eq)

text \<open>p 12, ll 5--7\<close>
theorem not_disjoint_implies_equal:
  assumes not_disjoint: "Class a \<inter> Class b \<noteq> {}"
  assumes closed: "a \<in> S" "b \<in> S"
  shows "Class a = Class b"
proof -
  from not_disjoint and closed obtain c where witness: "c \<in> Class a \<inter> Class b" by fast
  with closed have "(a, c) \<in> E" by (blast intro: symmetric)
  also from witness and closed have "(c, b) \<in> E" by fast
  finally show ?thesis by (rule Class_eq)
qed

text \<open>p 12, ll 7--8\<close>
definition "Partition = Class ` S"

text \<open>p 12, ll 7--8\<close>
lemma Class_in_Partition [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<in> Partition"
  unfolding Partition_def by fast

text \<open>p 12, ll 7--8\<close>
theorem partition:
  "partition S Partition"
proof
  fix A and B
  assume closed: "A \<in> Partition" "B \<in> Partition"
  then obtain a and b where eq: "A = Class a" "B = Class b" and ab: "a \<in> S" "b \<in> S"
  unfolding Partition_def by auto
  assume distinct: "A \<noteq> B"
  then show "A \<inter> B = {}"
  proof (rule contrapos_np)
    assume not_disjoint: "A \<inter> B \<noteq> {}"
    then show "A = B" by (simp add: eq) (metis not_disjoint_implies_equal ab)
  qed
qed (auto simp: Partition_def)

end (* equivalence *)

context partition begin

text \<open>p 12, ll 9--10\<close>
theorem block_exists:
  "a \<in> S \<Longrightarrow> \<exists>A. a \<in> A \<and> A \<in> P"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
theorem block_unique:
  "\<lbrakk> a \<in> A; A \<in> P; a \<in> B; B \<in> P \<rbrakk> \<Longrightarrow> A = B"
  using disjoint by blast

text \<open>p 12, ll 9--10\<close>
lemma block_closed [intro]: (* inefficient as a simp rule *)
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> a \<in> S"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
lemma element_exists:
  "A \<in> P \<Longrightarrow> \<exists>a \<in> S. a \<in> A"
  by (metis non_vacuous block_closed all_not_in_conv)

text \<open>p 12, ll 9--10\<close>
definition "Block = (\<lambda>a \<in> S. THE A. a \<in> A \<and> A \<in> P)"

text \<open>p 12, ll 9--10\<close>
lemma Block_closed [intro, simp]:
  assumes [intro]: "a \<in> S" shows "Block a \<in> P"
proof -
  obtain A where "a \<in> A" "A \<in> P" using block_exists by blast
  then show ?thesis
    apply (auto simp: Block_def)
    apply (rule theI2)
      apply (auto dest: block_unique)
    done
qed

text \<open>p 12, ll 9--10\<close>
lemma Block_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Block a = undefined"
  unfolding Block_def by simp

text \<open>p 12, ll 9--10\<close>
lemma Block_self:
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> Block a = A"
  apply (simp add: Block_def block_closed)
  apply (rule the_equality)
   apply (auto dest: block_unique)
  done

text \<open>p 12, ll 10--11\<close>
definition "Equivalence = {(a, b) . \<exists>A \<in> P. a \<in> A \<and> b \<in> A}"

text \<open>p 12, ll 11--12\<close>
theorem equivalence: "equivalence S Equivalence"
proof
  show "Equivalence \<subseteq> S \<times> S" unfolding Equivalence_def using subset by auto
next
  fix a
  assume "a \<in> S"
  then show "(a, a) \<in> Equivalence" unfolding Equivalence_def using complete by auto
next
  fix a and b
  assume "(a, b) \<in> Equivalence"
  then show "(b, a) \<in> Equivalence" unfolding Equivalence_def by auto
next
  fix a and b and c
  assume "(a, b) \<in> Equivalence" "(b, c) \<in> Equivalence"
  then show "(a, c) \<in> Equivalence" unfolding Equivalence_def using disjoint by auto
qed

text \<open>Temporarily introduce equivalence associated to partition.\<close>
text \<open>p 12, ll 12--14\<close>
interpretation equivalence S Equivalence by (rule equivalence)

text \<open>p 12, ll 12--14\<close>
theorem Class_is_Block:
  assumes "a \<in> S" shows "Class a = Block a"
proof -
  from \<open>a \<in> S\<close> and block_exists obtain A where block: "a \<in> A \<and> A \<in> P" by blast
  show ?thesis
    apply (simp add: Block_def Class_def)
    apply (rule theI2)
      apply (rule block)
     apply (metis block block_unique)
    apply (auto dest: block_unique simp: Equivalence_def)
    done
qed

text \<open>p 12, l 14\<close>
lemma Class_equals_Block:
  "Class = Block"
proof
  fix x show "Class x = Block x"
  by (cases "x \<in> S") (auto simp: Class_is_Block)
qed

text \<open>p 12, l 14\<close>
theorem partition_of_equivalence:
  "Partition = P"
  by (auto simp add: Partition_def Class_equals_Block image_iff) (metis Block_self element_exists)

end (* partition *)

context equivalence begin

text \<open>p 12, ll 14--17\<close>
interpretation partition S Partition by (rule partition)

text \<open>p 12, ll 14--17\<close>
theorem equivalence_of_partition:
  "Equivalence = E"
  unfolding Equivalence_def unfolding Partition_def by auto (metis ClassD Class_closed Class_eq)

end (* equivalence *)

text \<open>p 12, l 14\<close>
sublocale partition \<subseteq> equivalence S Equivalence
  rewrites "equivalence.Partition S Equivalence = P" and "equivalence.Class S Equivalence = Block"
    apply (rule equivalence)
   apply (rule partition_of_equivalence)
  apply (rule Class_equals_Block)
  done

text \<open>p 12, ll 14--17\<close>
sublocale equivalence \<subseteq> partition S Partition
  rewrites "partition.Equivalence Partition = E" and "partition.Block S Partition = Class"
    apply (rule partition)
   apply (rule equivalence_of_partition)
  apply (metis equivalence_of_partition partition partition.Class_equals_Block)
  done

text \<open>Unfortunately only effective on input\<close>
text \<open>p 12, ll 18--20\<close>
notation equivalence.Partition (infixl "'/" 75)

context equivalence begin

text \<open>p 12, ll 18--20\<close>
lemma representant_exists [dest]: "A \<in> S / E \<Longrightarrow> \<exists>a\<in>S. a \<in> A \<and> A = Class a"
  by (metis Block_self element_exists)

text \<open>p 12, ll 18--20\<close>
lemma quotient_ClassE: "A \<in> S / E \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> P (Class a)) \<Longrightarrow> P A"
  using representant_exists by blast

end (* equivalence *)

text \<open>p 12, ll 21--23\<close>
sublocale equivalence \<subseteq> natural: surjective_map Class S "S / E"
  by unfold_locales force+

text \<open>Technical device to achieve Jacobson's syntax; context where @{text \<alpha>} is not a parameter.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation_notation = fixes S :: "'a set" begin

text \<open>p 12, ll 25--26\<close>
definition Fiber_Relation ("E'(_')") where "Fiber_Relation \<alpha> = {(x, y). x \<in> S \<and> y \<in> S \<and> \<alpha> x = \<alpha> y}"

end (* fiber_relation_notation *)

text \<open>
  Context where classes and the induced map are defined through the fiber relation.
  This will be the case for monoid homomorphisms but not group homomorphisms.
\<close>
text \<open>Avoids infinite interpretation chain.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation = map begin

text \<open>Install syntax\<close>
text \<open>p 12, ll 25--26\<close>
sublocale fiber_relation_notation .

text \<open>p 12, ll 26--27\<close>
sublocale equivalence where E = "E(\<alpha>)"
  unfolding Fiber_Relation_def by unfold_locales auto

text \<open>``define $\bar{\alpha}$ by $\bar{\alpha}(\bar{a}) = \alpha(a)$''\<close>
text \<open>p 13, ll 8--9\<close>
definition "induced = (\<lambda>A \<in> S / E(\<alpha>). THE b. \<exists>a \<in> A. b = \<alpha> a)"

text \<open>p 13, l 10\<close>
theorem Fiber_equality:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> \<alpha> a = \<alpha> b"
  unfolding Class_equivalence unfolding Fiber_Relation_def by simp

text \<open>p 13, ll 8--9\<close>
theorem induced_Fiber_simp [simp]:
  assumes [intro, simp]: "a \<in> S" shows "induced (Class a) = \<alpha> a"
proof -
  have "(THE b. \<exists>a\<in>Class a. b = \<alpha> a) = \<alpha> a"
    by (rule the_equality) (auto simp: Fiber_equality [symmetric] Block_self block_closed)
  then show ?thesis unfolding induced_def by simp
qed

text \<open>p 13, ll 10--11\<close>
interpretation induced: map induced "S / E(\<alpha>)" T
proof (unfold_locales, rule)
  fix A
  assume [intro, simp]: "A \<in> S / E(\<alpha>)"
  obtain a where a: "a \<in> S" "a \<in> A" using element_exists by auto
  have "(THE b. \<exists>a\<in>A. b = \<alpha> a) \<in> T"
    apply (rule theI2)
    using a apply (auto simp: Fiber_equality [symmetric] Block_self block_closed)
    done
  then show "induced A \<in> T" unfolding induced_def by simp
qed (simp add: induced_def)

text \<open>p 13, ll 12--13\<close>
sublocale induced: injective_map induced "S / E(\<alpha>)" T
proof
  show "inj_on induced Partition"
    unfolding inj_on_def
    by (metis Fiber_equality Block_self element_exists induced_Fiber_simp)
qed

text \<open>p 13, ll 16--19\<close>
theorem factorization_lemma:
  "a \<in> S \<Longrightarrow> compose S induced Class a = \<alpha> a"
  by (simp add: compose_eq)

text \<open>p 13, ll 16--19\<close>
theorem factorization [simp]: "compose S induced Class = \<alpha>"
  by (rule ext) (simp add: compose_def map_undefined)

text \<open>p 14, ll 2--4\<close>
theorem uniqueness:
  assumes map: "\<beta> \<in> S / E(\<alpha>) \<rightarrow>\<^sub>E T"
    and factorization: "compose S \<beta> Class = \<alpha>"
  shows "\<beta> = induced"
proof
  fix A
  show "\<beta> A = induced A"
  proof (cases "A \<in> S / E(\<alpha>)")
    case True
    then obtain a where [simp]: "A = Class a" "a \<in> S" by fast
    then have "\<beta> (Class a) = \<alpha> a" by (metis compose_eq factorization)
    also have "\<dots> = induced (Class a)" by simp
    finally show ?thesis by simp
  qed (simp add: induced_def PiE_arb [OF map])
qed

end (* fiber_relation *)

end


theory T129
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


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

Ramsey's Theorem (finite exponent 2 version)

Based upon the article
    D Basin and M Kaufmann,
    The Boyer-Moore Prover and Nuprl: An Experimental Comparison.
    In G Huet and G Plotkin, editors, Logical Frameworks.
    (CUP, 1991), pages 89-119

See also
    M Kaufmann,
    An example in NQTHM: Ramsey's Theorem
    Internal Note, Computational Logic, Inc., Austin, Texas 78703
    Available from the author: kaufmann@cli.com

This function compute Ramsey numbers according to the proof given below
(which, does not constrain the base case values at all.

fun ram 0 j = 1
  | ram i 0 = 1
  | ram i j = ram (i-1) j + ram i (j-1)
*)

theory Ramsey imports ZF begin

definition
  Symmetric :: "i\<Rightarrow>o" where
    "Symmetric(E) \<equiv> (\<forall>x y. \<langle>x,y\<rangle>:E \<longrightarrow> \<langle>y,x\<rangle>:E)"

definition
  Atleast :: "[i,i]\<Rightarrow>o" where \<comment> \<open>not really necessary: ZF defines cardinality\<close>
    "Atleast(n,S) \<equiv> (\<exists>f. f \<in> inj(n,S))"

definition
  Clique  :: "[i,i,i]\<Rightarrow>o" where
    "Clique(C,V,E) \<equiv> (C \<subseteq> V) \<and> (\<forall>x \<in> C. \<forall>y \<in> C. x\<noteq>y \<longrightarrow> \<langle>x,y\<rangle> \<in> E)"

definition
  Indept  :: "[i,i,i]\<Rightarrow>o" where
    "Indept(I,V,E) \<equiv> (I \<subseteq> V) \<and> (\<forall>x \<in> I. \<forall>y \<in> I. x\<noteq>y \<longrightarrow> \<langle>x,y\<rangle> \<notin> E)"

definition
  Ramsey  :: "[i,i,i]\<Rightarrow>o" where
    "Ramsey(n,i,j) \<equiv> \<forall>V E. Symmetric(E) \<and> Atleast(n,V) \<longrightarrow>
         (\<exists>C. Clique(C,V,E) \<and> Atleast(i,C)) |
         (\<exists>I. Indept(I,V,E) \<and> Atleast(j,I))"

(*** Cliques and Independent sets ***)

lemma Clique0 [intro]: "Clique(0,V,E)"
by (unfold Clique_def, blast)

lemma Clique_superset: "\<lbrakk>Clique(C,V',E);  V'<=V\<rbrakk> \<Longrightarrow> Clique(C,V,E)"
by (unfold Clique_def, blast)

lemma Indept0 [intro]: "Indept(0,V,E)"
by (unfold Indept_def, blast)

lemma Indept_superset: "\<lbrakk>Indept(I,V',E);  V'<=V\<rbrakk> \<Longrightarrow> Indept(I,V,E)"
by (unfold Indept_def, blast)

(*** Atleast ***)

lemma Atleast0 [intro]: "Atleast(0,A)"
by (unfold Atleast_def inj_def Pi_def function_def, blast)

lemma Atleast_succD:
    "Atleast(succ(m),A) \<Longrightarrow> \<exists>x \<in> A. Atleast(m, A-{x})"
  unfolding Atleast_def
apply (blast dest: inj_is_fun [THEN apply_type] inj_succ_restrict)
done

lemma Atleast_superset:
    "\<lbrakk>Atleast(n,A);  A \<subseteq> B\<rbrakk> \<Longrightarrow> Atleast(n,B)"
by (unfold Atleast_def, blast intro: inj_weaken_type)

lemma Atleast_succI:
    "\<lbrakk>Atleast(m,B);  b\<notin> B\<rbrakk> \<Longrightarrow> Atleast(succ(m), cons(b,B))"
  unfolding Atleast_def succ_def
apply (blast intro: inj_extend elim: mem_irrefl)
done

lemma Atleast_Diff_succI:
     "\<lbrakk>Atleast(m, B-{x});  x \<in> B\<rbrakk> \<Longrightarrow> Atleast(succ(m), B)"
by (blast intro: Atleast_succI [THEN Atleast_superset])

(*** Main Cardinality Lemma ***)

(*The #-succ(0) strengthens the original theorem statement, but precisely
  the same proof could be used\<And>*)
lemma pigeon2 [rule_format]:
     "m \<in> nat \<Longrightarrow>
          \<forall>n \<in> nat. \<forall>A B. Atleast((m#+n) #- succ(0), A \<union> B) \<longrightarrow>
                           Atleast(m,A) | Atleast(n,B)"
apply (induct_tac "m")
apply (blast intro!: Atleast0, simp)
apply (rule ballI)
apply (rename_tac m' n) (*simplifier does NOT preserve bound names!*)
apply (induct_tac "n", auto)
apply (erule Atleast_succD [THEN bexE])
apply (rename_tac n' A B z)
apply (erule UnE)
(**case z \<in> B.  Instantiate the '\<forall>A B' induction hypothesis. **)
apply (drule_tac [2] x1 = A and x = "B-{z}" in spec [THEN spec])
apply (erule_tac [2] mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [3] asm_rl notE Atleast_Diff_succI)+
(*proving the condition*)
prefer 2 apply (blast intro: Atleast_superset)
(**case z \<in> A.  Instantiate the '\<forall>n \<in> nat. \<forall>A B' induction hypothesis. **)
apply (drule_tac x2="succ(n')" and x1="A-{z}" and x=B
       in bspec [THEN spec, THEN spec])
apply (erule nat_succI)
apply (erule mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [2] asm_rl Atleast_Diff_succI notE)+
(*proving the condition*)
apply simp
apply (blast intro: Atleast_superset)
done

(**** Ramsey's Theorem ****)

(** Base cases of induction; they now admit ANY Ramsey number **)

lemma Ramsey0j: "Ramsey(n,0,j)"
by (unfold Ramsey_def, blast)

lemma Ramseyi0: "Ramsey(n,i,0)"
by (unfold Ramsey_def, blast)

(** Lemmas for induction step **)

(*The use of succ(m) here, rather than #-succ(0), simplifies the proof of
  Ramsey_step_lemma.*)
lemma Atleast_partition: "\<lbrakk>Atleast(m #+ n, A);  m \<in> nat;  n \<in> nat\<rbrakk>
      \<Longrightarrow> Atleast(succ(m), {x \<in> A. \<not>P(x)}) | Atleast(n, {x \<in> A. P(x)})"
apply (rule nat_succI [THEN pigeon2], assumption+)
apply (rule Atleast_superset, auto)
done

(*For the Atleast part, proves \<not>(a \<in> I) from the second premise!*)
lemma Indept_succ:
    "\<lbrakk>Indept(I, {z \<in> V-{a}. \<langle>a,z\<rangle> \<notin> E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,I)\<rbrakk> \<Longrightarrow>
     Indept(cons(a,I), V, E) \<and> Atleast(succ(j), cons(a,I))"
  unfolding Symmetric_def Indept_def
apply (blast intro!: Atleast_succI)
done

lemma Clique_succ:
    "\<lbrakk>Clique(C, {z \<in> V-{a}. \<langle>a,z\<rangle>:E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,C)\<rbrakk> \<Longrightarrow>
     Clique(cons(a,C), V, E) \<and> Atleast(succ(j), cons(a,C))"
  unfolding Symmetric_def Clique_def
apply (blast intro!: Atleast_succI)
done

(** Induction step **)

(*Published proofs gloss over the need for Ramsey numbers to be POSITIVE.*)
lemma Ramsey_step_lemma:
   "\<lbrakk>Ramsey(succ(m), succ(i), j);  Ramsey(n, i, succ(j));
       m \<in> nat;  n \<in> nat\<rbrakk> \<Longrightarrow> Ramsey(succ(m#+n), succ(i), succ(j))"
apply (unfold Ramsey_def, clarify)
apply (erule Atleast_succD [THEN bexE])
apply (erule_tac P1 = "\<lambda>z.\<langle>x,z\<rangle>:E" in Atleast_partition [THEN disjE],
       assumption+)
(*case m*)
apply (fast dest!: Indept_succ elim: Clique_superset)
(*case n*)
apply (fast dest!: Clique_succ elim: Indept_superset)
done

(** The actual proof **)

(*Again, the induction requires Ramsey numbers to be positive.*)
lemma ramsey_lemma: "i \<in> nat \<Longrightarrow> \<forall>j \<in> nat. \<exists>n \<in> nat. Ramsey(succ(n), i, j)"
apply (induct_tac "i")
apply (blast intro!: Ramsey0j)
apply (rule ballI)
apply (induct_tac "j")
apply (blast intro!: Ramseyi0)
apply (blast intro!: add_type Ramsey_step_lemma)
done

(*Final statement in a tidy form, without succ(...) *)

end


theory Derivations
imports CFG ListTools InductRules
begin

(* leftderives and leftderives1 *)
context CFG begin

lemma [simp]: "is_sentence []" by (auto simp add: is_sentence_def)

lemma [simp]: "is_word []" by (auto simp add: is_word_def)

lemma [simp]: "is_word u \<Longrightarrow> is_sentence u"
  by (induct u, auto simp add: is_word_def is_sentence_def)

definition leftderives1 :: "sentence \<Rightarrow> sentence \<Rightarrow> bool"
where
  "leftderives1 u v =
     (\<exists> x y N \<alpha>.
          u = x @ [N] @ y
        \<and> v = x @ \<alpha> @ y
        \<and> is_word x
        \<and> is_sentence y
        \<and> (N, \<alpha>) \<in> \<RR>)"

lemma leftderives1_implies_derives1[simp]: "leftderives1 u v \<Longrightarrow> derives1 u v"
  apply (auto simp add: leftderives1_def derives1_def)
  apply (rule_tac x="x" in exI)
  apply (rule_tac x="y" in exI)
  apply (rule_tac x="N" in exI)
  by auto

definition leftderivations1 :: "(sentence \<times> sentence) set"
where
  "leftderivations1 = { (u,v) | u v. leftderives1 u v }"

lemma [simp]: "leftderivations1 \<subseteq> derivations1"
  by (auto simp add: leftderivations1_def derivations1_def)

definition leftderivations :: "(sentence \<times> sentence) set"
where
  "leftderivations = leftderivations1^*"

lemma rtrancl_subset_implies: "a \<subseteq> b \<Longrightarrow> a \<subseteq> b^*" by blast

lemma leftderivations_subset_derivations[simp]: "leftderivations \<subseteq> derivations"
  apply (simp add: leftderivations_def derivations_def)
  apply (rule rtrancl_subset_rtrancl)
  apply (rule rtrancl_subset_implies)
  by simp

definition leftderives :: "sentence \<Rightarrow> sentence \<Rightarrow> bool"
where
  "leftderives u v = ((u, v) \<in> leftderivations)"

lemma leftderives_implies_derives[simp]: "leftderives u v \<Longrightarrow> derives u v"
  apply (auto simp add: leftderives_def derives_def)
  by (rule subsetD[OF leftderivations_subset_derivations])

definition is_leftderivation :: "sentence \<Rightarrow> bool"
where
  "is_leftderivation u = leftderives [\<SS>] u"

lemma leftderivation_implies_derivation[simp]:
  "is_leftderivation u \<Longrightarrow> is_derivation u"
  by (simp add: is_leftderivation_def is_derivation_def)

lemma leftderives_refl[simp]: "leftderives u u"
  by (auto simp add: leftderives_def leftderivations_def)

lemma leftderives1_implies_leftderives[simp]:"leftderives1 a b \<Longrightarrow> leftderives a b"
  by (auto simp add: leftderives_def leftderivations_def leftderivations1_def)

lemma leftderives_trans: "leftderives a b \<Longrightarrow> leftderives b c \<Longrightarrow> leftderives a c"
  by (auto simp add: leftderives_def leftderivations_def)

lemma leftderives1_eq_leftderivations1: "leftderives1 x y = ((x, y) \<in> leftderivations1)"
  by (simp add: leftderivations1_def)

lemma leftderives_induct[consumes 1, case_names Base Step]:
  assumes derives: "leftderives a b"
  assumes Pa: "P a"
  assumes induct: "\<And>y z. leftderives a y \<Longrightarrow> leftderives1 y z \<Longrightarrow> P y \<Longrightarrow> P z"
  shows "P b"
proof -
  note rtrancl_lemma = rtrancl_induct[where a = a and b = b and r = leftderivations1 and P=P]
  from derives Pa induct rtrancl_lemma show "P b"
    by (metis leftderives_def leftderivations_def leftderives1_eq_leftderivations1)
qed

end

(* Basic lemmas about derives1 and derives *)
context CFG begin

lemma derives1_implies_derives[simp]:"derives1 a b \<Longrightarrow> derives a b"
  by (auto simp add: derives_def derivations_def derivations1_def)

lemma derives_trans: "derives a b \<Longrightarrow> derives b c \<Longrightarrow> derives a c"
  by (auto simp add: derives_def derivations_def)

lemma derives1_eq_derivations1: "derives1 x y = ((x, y) \<in> derivations1)"
  by (simp add: derivations1_def)

lemma derives_induct[consumes 1, case_names Base Step]:
  assumes derives: "derives a b"
  assumes Pa: "P a"
  assumes induct: "\<And>y z. derives a y \<Longrightarrow> derives1 y z \<Longrightarrow> P y \<Longrightarrow> P z"
  shows "P b"
proof -
  note rtrancl_lemma = rtrancl_induct[where a = a and b = b and r = derivations1 and P=P]
  from derives Pa induct rtrancl_lemma show "P b"
    by (metis derives_def derivations_def derives1_eq_derivations1)
qed

end

(* Derives1 and Derivation, LDerives1 and LDerivation *)
context CFG begin

definition Derives1 :: "sentence \<Rightarrow> nat \<Rightarrow> rule \<Rightarrow> sentence \<Rightarrow> bool"
where
  "Derives1 u i r v =
     (\<exists> x y N \<alpha>.
          u = x @ [N] @ y
        \<and> v = x @ \<alpha> @ y
        \<and> is_sentence x
        \<and> is_sentence y
        \<and> (N, \<alpha>) \<in> \<RR>
        \<and> r = (N, \<alpha>) \<and> i = length x)"

lemma Derives1_split:
  "Derives1 u i r v \<Longrightarrow> \<exists> x y. u = x @ [fst r] @ y \<and> v = x @ (snd r) @ y \<and> length x = i"
by (metis Derives1_def fst_conv snd_conv)

lemma Derives1_implies_derives1: "Derives1 u i r v \<Longrightarrow> derives1 u v"
  by (auto simp add: Derives1_def derives1_def)

lemma derives1_implies_Derives1: "derives1 u v \<Longrightarrow> \<exists> i r. Derives1 u i r v"
  by (auto simp add: Derives1_def derives1_def)

lemma Derives1_unique_dest: "Derives1 u i r v \<Longrightarrow> Derives1 u i r w \<Longrightarrow> v = w"
  by (auto simp add: Derives1_def derives1_def)

lemma Derives1_unique_src: "Derives1 u i r w \<Longrightarrow> Derives1 v i r w \<Longrightarrow> u = v"
  by (auto simp add: Derives1_def derives1_def)

type_synonym derivation = "(nat \<times> rule) list"

fun Derivation :: "sentence \<Rightarrow> derivation \<Rightarrow> sentence \<Rightarrow> bool"
where
  "Derivation a [] b = (a = b)"
| "Derivation a (d#D) b = (\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b)"

lemma Derivation_implies_derives: "Derivation a D b \<Longrightarrow> derives a b"
proof (induct D arbitrary: a b)
  case Nil thus ?case
    by (simp add: derives_def derivations_def)
next
  case (Cons d D)
    note ihyps = this
    from ihyps have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b" by auto
    then obtain x where "Derives1 a (fst d) (snd d) x" and xb: "Derivation x D b" by blast
    with Derives1_implies_derives1 have d1: "derives a x" by auto
    from ihyps xb have d2:"derives x b" by simp
    show "derives a b" by (rule derives_trans[OF d1 d2])
qed

lemma Derivation_Derives1: "Derivation a S y \<Longrightarrow> Derives1 y i r z \<Longrightarrow> Derivation a (S@[(i,r)]) z"
proof (induct S arbitrary: a y z i r)
  case Nil thus ?case by simp
next
  case (Cons s S) thus ?case
    by (metis Derivation.simps(2) append_Cons)
qed

lemma derives_implies_Derivation: "derives a b \<Longrightarrow> \<exists> D. Derivation a D b"
proof (induct rule: derives_induct)
  case Base
  show ?case by (rule exI[where x="[]"], simp)
next
  case (Step y z)
  note ihyps = this
  from ihyps obtain D where ay: "Derivation a D y" by blast
  from ihyps derives1_implies_Derives1 obtain i r where yz: "Derives1 y i r z" by blast
  from Derivation_Derives1[OF ay yz] show ?case by auto
qed

lemma Derives1_take: "Derives1 a i r b \<Longrightarrow> take i a = take i b"
  by (auto simp add: Derives1_def)

lemma Derives1_drop: "Derives1 a i r b \<Longrightarrow> drop (Suc i) a = drop (i + length (snd r)) b"
  by (auto simp add: Derives1_def)

lemma Derives1_bound: "Derives1 a i r b \<Longrightarrow> i < length a"
  by (auto simp add: Derives1_def)

lemma Derives1_length: "Derives1 a i r b \<Longrightarrow> length b = length a + length (snd r) - 1"
  by (auto simp add: Derives1_def)

definition leftmost :: "nat \<Rightarrow> sentence \<Rightarrow> bool"
where
  "leftmost i s = (i < length s \<and> is_word (take i s) \<and> is_nonterminal (s ! i))"

lemma set_take: "set (take n s) = { s ! i | i. i < n \<and> i < length s}"
proof (cases "n \<le> length s")
  case True thus ?thesis
  by (subst List.nth_image[symmetric], auto)
next
  case False thus ?thesis
    apply (subst set_conv_nth)
    by (metis less_trans linear not_le take_all)
qed

lemma list_all_take: "list_all P (take n s) = (\<forall> i. i < n \<and> i < length s \<longrightarrow> P (s ! i))"
  by (auto simp add: set_take list_all_iff)

lemma is_sentence_concat: "is_sentence (x@y) = (is_sentence x \<and> is_sentence y)"
  by (auto simp add: is_sentence_def)

lemma is_sentence_cons: "is_sentence (x#xs) = (is_symbol x \<and> is_sentence xs)"
  by (auto simp add: is_sentence_def)

lemma rule_nonterminal_type[simp]: "(N, \<alpha>) \<in> \<RR> \<Longrightarrow> is_nonterminal N"
  apply (insert validRules)
  by (auto simp add: is_nonterminal_def)

lemma rule_\<alpha>_type[simp]: "(N, \<alpha>) \<in> \<RR> \<Longrightarrow> is_sentence \<alpha>"
  apply (insert validRules)
  by (auto simp add: is_sentence_def is_symbol_def list_all_iff is_terminal_def is_nonterminal_def)

lemma [simp]: "is_nonterminal N \<Longrightarrow> is_symbol N"
  by (simp add: is_symbol_def)

lemma Derives1_sentence1[elim]: "Derives1 a i r b \<Longrightarrow> is_sentence a"
  by (auto simp add: Derives1_def is_sentence_cons is_sentence_concat)

lemma Derives1_sentence2[elim]: "Derives1 a i r b \<Longrightarrow> is_sentence b"
  by (auto simp add: Derives1_def is_sentence_cons is_sentence_concat)

lemma [elim]: "Derives1 a i r b \<Longrightarrow> r \<in> \<RR>"
  using Derives1_def by auto

lemma is_sentence_symbol: "is_sentence a \<Longrightarrow> i < length a \<Longrightarrow> is_symbol (a ! i)"
  by (simp add: is_sentence_def list_all_iff)

lemma is_symbol_distinct: "is_symbol x \<Longrightarrow> is_terminal x \<noteq> is_nonterminal x"
  apply (insert disjunct_symbols)
  apply (auto simp add: is_symbol_def is_terminal_def is_nonterminal_def)
  done

lemma is_terminal_nonterminal: "is_terminal x \<Longrightarrow> is_nonterminal x \<Longrightarrow> False"
  by (metis is_symbol_def is_symbol_distinct)

lemma Derives1_leftmost:
  assumes "Derives1 a i r b"
  shows "\<exists> j. leftmost j a \<and> j \<le> i"
proof -
  let ?J = "{j . j < length a \<and> is_nonterminal (a ! j)}"
  let ?M = "Min ?J"
  from assms have J1:"i \<in> ?J"
    apply (auto simp add: Derives1_def is_nonterminal_def)
    by (metis (mono_tags, lifting) prod.simps(2) validRules)
  have J2:"finite ?J" by auto
  note J = J1 J2
  from J have M1: "?M \<in> ?J" by (rule_tac Min_in, auto)
  {
    fix j
    assume "j \<in> ?J"
    with J have "?M \<le> j" by auto
  }
  note M3 = this[OF J1]
  from assms have a_sentence: "is_sentence a" by (simp add: Derives1_sentence1)
  have is_word: "is_word (take ?M a)"
    apply (auto simp add: is_word_def list_all_take)
    proof -
      fix i
      assume i_less_M: "i < ?M"
      assume i_inbounds: "i < length a"
      show "is_terminal (a ! i)"
      proof(cases "is_terminal (a ! i)")
        case True thus ?thesis by auto
      next
        case False
        then have "is_nonterminal (a ! i)"
        using i_inbounds a_sentence is_sentence_symbol is_symbol_distinct by blast
        then have "i \<in> ?J" by (metis i_inbounds mem_Collect_eq)
        then have "?M < i" by (metis J2 Min_le i_less_M leD)
        then have "False" by (metis i_less_M less_asym')
        then show ?thesis by auto
      qed
    qed
  show ?thesis
    apply (rule_tac exI[where x="?M"])
    apply (simp add: leftmost_def)
    by (metis (mono_tags, lifting) M1 M3 is_word mem_Collect_eq)
qed

lemma Derivation_leftmost: "D \<noteq> [] \<Longrightarrow> Derivation a D b \<Longrightarrow> \<exists> i. leftmost i a"
  apply (case_tac "D")
  apply (auto)
  apply (metis Derives1_leftmost)
  done

lemma nonword_has_nonterminal:
  "is_sentence a \<Longrightarrow>  \<not> (is_word a) \<Longrightarrow> \<exists> k. k < length a \<and> is_nonterminal (a ! k)"
  apply (auto simp add: is_sentence_def list_all_iff is_word_def)
  by (metis in_set_conv_nth is_symbol_distinct)

lemma leftmost_cons_nonterminal:
  "is_nonterminal x \<Longrightarrow> leftmost 0 (x#xs)"
by (metis CFG.is_word_def CFG_axioms leftmost_def length_greater_0_conv list.distinct(1)
    list_all_simps(2) nth_Cons_0 take_Cons')

lemma leftmost_cons_terminal:
  "is_terminal x \<Longrightarrow> leftmost i (x#xs) = (i > 0 \<and> leftmost (i - 1) xs)"
by (metis Suc_diff_1 Suc_less_eq is_terminal_nonterminal is_word_def leftmost_def length_Cons
    list_all_simps(1) not_gr0 nth_Cons' take_Cons')

lemma is_nonterminal_cons_terminal:
  "is_terminal x \<Longrightarrow> k < length (x # a) \<Longrightarrow> is_nonterminal ((x # a) ! k) \<Longrightarrow>
   k > 0 \<and> k - 1 < length a \<and> is_nonterminal (a ! (k - 1))"
by (metis One_nat_def Suc_leI is_terminal_nonterminal less_diff_conv2
    list.size(4) nth_non_equal_first_eq)

lemma leftmost_exists:
  "is_sentence a \<Longrightarrow> k < length a \<Longrightarrow> is_nonterminal (a ! k) \<Longrightarrow>
   \<exists> i. leftmost i a \<and> i \<le> k"
proof (induct a arbitrary: k)
  case Nil thus ?case by auto
next
  case (Cons x a)
  show ?case
  proof(cases "is_nonterminal x")
    case True thus ?thesis
      apply(rule_tac exI[where x="0"])
      apply (simp add: leftmost_cons_nonterminal)
      done
  next
    case False
    then have x: "is_terminal x"
      by (metis Cons.prems(1) is_sentence_cons is_symbol_distinct)
    note k = is_nonterminal_cons_terminal[OF x Cons(3) Cons(4)]
    with Cons have "\<exists>i. leftmost i a \<and> i \<le> k - 1" by (metis is_sentence_cons)
    then show ?thesis
      apply (auto simp add: leftmost_cons_terminal[OF x])
      by (metis Nat.le_diff_conv2 Suc_leI add_Suc_right add_diff_cancel_right' k
          le_0_eq le_imp_less_Suc nat_le_linear)
  qed
qed

lemma nonword_leftmost_exists:
  "is_sentence a \<Longrightarrow> \<not> (is_word a) \<Longrightarrow> \<exists> i. leftmost i a"
  by (metis leftmost_exists nonword_has_nonterminal)

lemma leftmost_unaffected_Derives1: "leftmost j a \<Longrightarrow> j < i \<Longrightarrow> Derives1 a i r b \<Longrightarrow> leftmost j b"
apply (simp add: leftmost_def)
proof -
  assume a1: "j < length a \<and> is_word (take j a) \<and> is_nonterminal (a ! j)"
  assume a2: "j < i"
  assume "Derives1 a i r b"
  then have f3: "take i a = take i b"
    by (metis Derives1_take)
  have f4: "\<And>n ss ssa. take (length (take n (ss::symbol list))) (ssa::symbol list) = take (length ss) (take n ssa)"
    by (metis length_take take_take)
  have f5: "\<And>ss. take j (ss::symbol list) = take i (take j ss)"
    using a2 by (metis dual_order.strict_implies_order min.absorb2 take_take)
  have f6: "length (take j a) = j"
    using a1 by (metis dual_order.strict_implies_order length_take min.absorb2)
  then have f7: "\<And>n. min j n = length (take n (take j a))"
    by (metis length_take)
  have f8: "\<And>n ss. n = length (take n (ss::symbol list)) \<or> length ss < n"
    by (metis leI length_take min.absorb2)
  have f9: "\<And>ss. take j (ss::symbol list) = take j (take i ss)"
    using f7 f6 f5 by (metis take_take)
  have f10: "\<And>ss n. length (ss::symbol list) \<le> n \<or> length (take n ss) = n"
    using f8 by (metis dual_order.strict_implies_order)
  then have f11: "\<And>ss ssa. length (ss::symbol list) = length (take (length ss) (ssa::symbol list)) \<or> length (take (length ssa) ss) = length ssa"
    by (metis length_take min.absorb2)
  have f12: "\<And>ss ssa n. take (length (ss::symbol list)) (ssa::symbol list) = take n (take (length ss) ssa) \<or> length (take n ss) = n"
    using f10 by (metis min.absorb2 take_take)
  { assume "\<not> j < j"
    { assume "\<not> j < j \<and> i \<noteq> j"
      moreover
      { assume "length a \<noteq> j \<and> length (take i a) \<noteq> i"
        then have "\<exists>ss. length (take (length (take i (take (length a) (ss::symbol list)))) (take j ss)) \<noteq> length (take i (take (length a) ss))"
          using f12 f11 f6 f5 f4 by metis
        then have "\<exists>ss ssa. take (length (ss::symbol list)) (take j (ssa::symbol list)) \<noteq> take (length ss) (take i (take (length a) ssa))"
          using f11 by metis
        then have "length b \<noteq> j"
          using f9 f4 f3 by metis }
      ultimately have "length b \<noteq> j"
        using f7 f6 f5 f3 a1 by (metis length_take) }
    then have "length b = j \<longrightarrow> j < j"
      using a2 by metis }
  then have "j < length b"
    using f9 f8 f7 f6 f4 f3 by metis
  then show "j < length b \<and> is_word (take j b) \<and> is_nonterminal (b ! j)"
    using f9 f3 a2 a1 by (metis nth_take)
qed

definition derivation_ge :: "derivation \<Rightarrow> nat \<Rightarrow> bool"
where
  "derivation_ge D i = (\<forall> d \<in> set D. fst d \<ge> i)"

lemma derivation_ge_cons: "derivation_ge (d#D) i = (fst d \<ge> i \<and> derivation_ge D i)"
  by (auto simp add: derivation_ge_def)

lemma derivation_ge_append:
  "derivation_ge (D@E) i = (derivation_ge D i \<and> derivation_ge E i)"
  by (auto simp add: derivation_ge_def)

lemma leftmost_unaffected_Derivation:
  "derivation_ge D (Suc i) \<Longrightarrow> leftmost i a \<Longrightarrow> Derivation a D b \<Longrightarrow> leftmost i b"
proof (induct D arbitrary: a)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b" by simp
  then obtain x where x1: "Derives1 a (fst d) (snd d) x" and x2: "Derivation x D b" by blast
  with Cons have leftmost_x: "leftmost i x"
    apply (rule_tac leftmost_unaffected_Derives1[
           where a=a and j=i and b="x" and i="fst d" and r="snd d"])
    by (auto simp add: derivation_ge_def)
  with Cons x2 show ?case by (auto simp add: derivation_ge_def)
qed

lemma le_Derives1_take:
  assumes le: "i \<le> j"
  and D: "Derives1 a j r b"
  shows "take i a = take i b"
proof -
  note Derives1_take[where a=a and i=j and r=r and b=b]
  with le D show ?thesis by (rule_tac le_take_same[where i=i and j=j], auto)
qed

lemma Derivation_take: "derivation_ge D i \<Longrightarrow> Derivation a D b \<Longrightarrow> take i a = take i b"
proof(induct D arbitrary: a b)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b"
    by simp
  then obtain x where ax: "Derives1 a (fst d) (snd d) x" and xb: "Derivation x D b" by blast
  from derivation_ge_cons Cons(2) have d: "i \<le> fst d" and D: "derivation_ge D i" by auto
  note take_i_xb = Cons(1)[OF D xb]
  note take_i_ax = le_Derives1_take[OF d ax]
  from take_i_xb take_i_ax show ?case by auto
qed

lemma leftmost_cons_less: "i < length u \<Longrightarrow> leftmost i (u@v) = leftmost i u"
  by (auto simp add: leftmost_def nth_append)

lemma leftmost_is_nonterminal: "leftmost i u \<Longrightarrow> is_nonterminal (u ! i)"
  by (metis leftmost_def)

lemma is_word_is_terminal: "i < length u \<Longrightarrow> is_word u \<Longrightarrow> is_terminal (u ! i)"
  by (metis is_word_def list_all_length)

lemma leftmost_append:
  assumes leftmost: "leftmost i (u@v)"
  and is_word: "is_word u"
  shows "length u \<le> i"
proof (cases "i < length u")
  case False thus ?thesis by auto
next
  case True
  with leftmost have "leftmost i u" using leftmost_cons_less[OF True] by simp
  then have is_nonterminal: "is_nonterminal (u ! i)" by (rule leftmost_is_nonterminal)
  note is_terminal = is_word_is_terminal[OF True is_word]
  note is_terminal_nonterminal[OF is_terminal is_nonterminal]
  then show ?thesis by auto
qed

lemma derivation_ge_empty[simp]: "derivation_ge [] i"
by (simp add: derivation_ge_def)

lemma leftmost_notword: "leftmost i a \<Longrightarrow> j > i \<Longrightarrow> \<not> (is_word (take j a))"
by (metis is_terminal_nonterminal is_word_def leftmost_def list_all_take)

lemma leftmost_unique: "leftmost i a \<Longrightarrow> leftmost j a \<Longrightarrow> i = j"
by (metis leftmost_def leftmost_notword linorder_neqE_nat)

lemma leftmost_Derives1: "leftmost i a \<Longrightarrow> Derives1 a j r b \<Longrightarrow> i \<le> j"
by (metis Derives1_leftmost leftmost_unique)

lemma leftmost_Derives1_propagate:
  assumes leftmost: "leftmost i a"
      and Derives1: "Derives1 a j r b"
    shows "(is_word b \<and> i = j) \<or> (\<exists> k. leftmost k b \<and> i \<le> k)"
proof -
  from leftmost_Derives1[OF leftmost Derives1] have ij: "i \<le> j" by auto
  show ?thesis
  proof (cases "is_word b")
    case True show ?thesis
      by (metis Derives1 True ij le_neq_implies_less leftmost
          leftmost_unaffected_Derives1 order_refl)
  next
    case False show ?thesis
      by (metis (no_types, hide_lams) Derives1 Derives1_bound Derives1_sentence2
          Derives1_take append_take_drop_id ij le_neq_implies_less leftmost
          leftmost_append leftmost_cons_less leftmost_def length_take
          min.absorb2 nat_le_linear nonword_leftmost_exists not_le)
  qed
qed

lemma is_word_Derives1[elim]: "is_word a \<Longrightarrow> Derives1 a i r b \<Longrightarrow> False"
by (metis Derives1_leftmost is_terminal_nonterminal is_word_is_terminal leftmost_def)

lemma is_word_Derivation[elim]: "is_word a \<Longrightarrow> Derivation a D b \<Longrightarrow> D = []"
by (metis Derivation_leftmost is_terminal_nonterminal is_word_def
    leftmost_def list_all_length)

lemma leftmost_Derivation:
  "leftmost i a \<Longrightarrow> Derivation a D b \<Longrightarrow> j \<le> i \<Longrightarrow> derivation_ge D j"
proof (induct D arbitrary: a b i j)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b" by auto
  then obtain x where ax:"Derives1 a (fst d) (snd d) x" and xb:"Derivation x D b" by blast
  note ji = Cons(4)
  note i_fstd = leftmost_Derives1[OF Cons(2) ax]
  note disj = leftmost_Derives1_propagate[OF Cons(2) ax]
  thus ?case
  proof(induct rule: disjCases2)
    case 1
    with xb have "D = []" by auto
    with 1 ji show ?case by (simp add: derivation_ge_def)
  next
    case 2
    then obtain k where k: "leftmost k x" and ik: "i \<le> k" by blast
    note ge = Cons(1)[OF k xb, where j=j]
    from ji ik i_fstd ge show ?case
      by (simp add: derivation_ge_cons)
  qed
qed

lemma derivation_ge_list_all: "derivation_ge D i = list_all (\<lambda> d. fst d \<ge> i) D"
by (simp add: Ball_set derivation_ge_def)

lemma split_derivation_leftmost:
  assumes "derivation_ge D i"
  and "\<not> (derivation_ge D (Suc i))"
  shows "\<exists> E F r. D = E@[(i, r)]@F \<and> derivation_ge E (Suc i)"
proof -
  from assms have "\<exists> k. k < length D \<and> fst(D ! k) \<ge> i \<and> \<not>(fst(D ! k) \<ge> Suc i)"
    by (metis derivation_ge_def in_set_conv_nth)
  then have "\<exists> k. k < length D \<and> fst(D ! k) = i" by auto
  then show ?thesis
  proof(induct rule: ex_minimal_witness)
    case (Minimal k)
      then have k_len: "k < length D" and k_i: "fst (D ! k) = i" by auto
      let ?E = "take k D"
      let ?r = "snd (D ! k)"
      let ?F = "drop (Suc k) D"
      note split = split_list_at[OF k_len]
      from k_i have D_k: "D ! k = (i, ?r)" by auto
      show ?case
        apply (rule exI[where x="?E"])
        apply (rule exI[where x="?F"])
        apply (rule exI[where x="?r"])
        apply (subst D_k[symmetric])
        apply (rule conjI)
        apply (rule split)
        by (metis (mono_tags, lifting) Minimal.hyps(2) Suc_leI assms(1)
            derivation_ge_list_all le_neq_implies_less list_all_length list_all_take)
  qed
qed

lemma Derives1_Derives1_swap:
  assumes "i < j"
  and "Derives1 a j p b"
  and "Derives1 b i q c"
  shows "\<exists> b'. Derives1 a i q b' \<and> Derives1 b' (j - 1 + length (snd q)) p c"
proof -
  from Derives1_split[OF assms(2)] obtain a1 a2 where
    a_src: "a = a1 @ [fst p] @ a2" and a_dest: "b = a1 @ snd p @ a2"
    and a1_len: "length a1 = j" by blast
  note a = this
  from a have is_sentence_a1: "is_sentence a1"
    using Derives1_sentence2 assms(2) is_sentence_concat by blast
  from a have is_sentence_a2: "is_sentence a2"
    using Derives1_sentence2 assms(2) is_sentence_concat by blast
  from a have is_symbol_fst_p:  "is_symbol (fst p)"
    by (metis Derives1_sentence1 assms(2) is_sentence_concat is_sentence_cons)
  from Derives1_split[OF assms(3)] obtain b1 b2 where
    b_src: "b = b1 @ [fst q] @ b2" and b_dest: "c = b1 @ snd q @ b2"
    and b1_len: "length b1 = i" by blast
  have a_take_j: "a1 = take j a" by (metis a1_len a_src append_eq_conv_conj)
  have b_take_i: "b1 @ [fst q] = take (Suc i) b"
    by (metis append_assoc append_eq_conv_conj b1_len b_src length_append_singleton)
  from a_take_j b_take_i  take_eq_take_append[where j=j and i="Suc i" and a=a]
  have "\<exists> u. a1 = (b1 @ [fst q]) @ u"
    by (metis le_iff_add Suc_leI a1_len a_dest append_eq_conv_conj assms(1) take_add)
  then obtain u where u1: "a1 = (b1 @ [fst q]) @ u" by blast
  then have j_i_u: "j = i + 1 + length u"
    using Suc_eq_plus1 a1_len b1_len length_append length_append_singleton by auto
  from u1 is_sentence_a1 have is_sentence_b1_u: "is_sentence b1 \<and> is_sentence u"
    using is_sentence_concat by blast
  have u2: "b2 = u @ snd p @ a2" by (metis a_dest append_assoc b_src same_append_eq u1)
  let ?b = "b1 @ (snd q) @ u @ [fst p] @ a2"
  from assms have q_dom: "q \<in> \<RR>" by auto
  have a_b': "Derives1 a i q ?b"
    apply (subst Derives1_def)
    apply (rule exI[where x="b1"])
    apply (rule exI[where x="u@[fst p]@a2"])
    apply (rule exI[where x="fst q"])
    apply (rule exI[where x="snd q"])
    apply (auto simp add: b1_len is_sentence_cons is_sentence_concat
           is_sentence_a2 is_symbol_fst_p is_sentence_b1_u a_src u1 q_dom)
    done
  from assms have p_dom: "p \<in> \<RR>" by auto
  have is_sentence_snd_q: "is_sentence (snd q)"
    using Derives1_sentence2 a_b' is_sentence_concat by blast
  have b'_c: "Derives1 ?b (j - 1 + length (snd q)) p c"
    apply (subst Derives1_def)
    apply (rule exI[where x="b1 @ (snd q) @ u"])
    apply (rule exI[where x="a2"])
    apply (rule exI[where x="fst p"])
    apply (rule exI[where x="snd p"])
    apply (auto simp add: is_sentence_concat is_sentence_b1_u is_sentence_a2 p_dom
           is_sentence_snd_q b_dest u2 b1_len j_i_u)
    done
  show ?thesis
    apply (rule exI[where x="?b"])
    apply (rule conjI)
    apply (rule a_b')
    apply (rule b'_c)
    done
qed

definition derivation_shift :: "derivation \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> derivation"
where
  "derivation_shift D left right = map (\<lambda> d. (fst d - left + right, snd d)) D"

lemma derivation_shift_empty[simp]: "derivation_shift [] left right = []"
  by (auto simp add: derivation_shift_def)

lemma derivation_shift_cons[simp]:
  "derivation_shift (d#D) left right = ((fst d - left + right, snd d)#(derivation_shift D left right))"
by (simp add: derivation_shift_def)

lemma Derivation_append: "Derivation a (D@E) c = (\<exists> b. Derivation a D b \<and> Derivation b E c)"
proof(induct D arbitrary: a c E)
  case Nil thus ?case by auto
next
  case (Cons d D) thus ?case by auto
qed

lemma Derivation_implies_append:
  "Derivation a D b \<Longrightarrow> Derivation b E c \<Longrightarrow> Derivation a (D@E) c"
using Derivation_append by blast

lemma Derivation_swap_single_end_to_front:
  "i < j \<Longrightarrow> derivation_ge D j \<Longrightarrow> Derivation a (D@[(i,r)]) b \<Longrightarrow>
   Derivation a ((i,r)#(derivation_shift D 1 (length (snd r)))) b"
proof(induct D arbitrary: a)
  case Nil thus ?case by auto
next
  case (Cons d D)
  from Cons have "\<exists> c. Derives1 a (fst d) (snd d) c \<and> Derivation c (D @ [(i, r)]) b"
    by simp
  then obtain c where ac: "Derives1 a (fst d) (snd d) c"
    and cb: "Derivation c (D @ [(i, r)]) b" by blast
  from Cons(3) have D_j: "derivation_ge D j" by (simp add: derivation_ge_cons)
  from Cons(1)[OF Cons(2) D_j cb, simplified]
  obtain x where cx: "Derives1 c i r x" and
    xb: "Derivation x (derivation_shift D 1 (length (snd r))) b" by auto
  have i_fst_d: "i < fst d" using Cons derivation_ge_cons by auto
  from Derives1_Derives1_swap[OF i_fst_d ac cx]
  obtain b' where ab': "Derives1 a i r b'" and
    b'x: "Derives1 b' (fst d - 1 + length (snd r)) (snd d) x" by blast
  show ?case using ab' b'x xb by auto
qed

lemma Derivation_swap_single_mid_to_front:
  assumes "i < j"
  and "derivation_ge D j"
  and "Derivation a (D@[(i,r)]@E) b"
  shows "Derivation a ((i,r)#((derivation_shift D 1 (length (snd r)))@E)) b"
proof -
  from assms have "\<exists> x. Derivation a (D@[(i, r)]) x \<and> Derivation x E b"
    using Derivation_append by auto
  then obtain x where ax: "Derivation a (D@[(i, r)]) x" and xb: "Derivation x E b"
    by blast
  with assms have "Derivation a ((i, r)#(derivation_shift D 1 (length (snd r)))) x"
    using Derivation_swap_single_end_to_front by blast
  then show ?thesis using Derivation_append xb by auto
qed

lemma length_derivation_shift[simp]:
  "length(derivation_shift D left right) = length D"
  by (simp add: derivation_shift_def)

definition LeftDerives1 :: "sentence \<Rightarrow> nat \<Rightarrow> rule \<Rightarrow> sentence \<Rightarrow> bool"
where
  "LeftDerives1 u i r v = (leftmost i u \<and> Derives1 u i r v)"

lemma LeftDerives1_implies_leftderives1: "LeftDerives1 u i r v \<Longrightarrow> leftderives1 u v"
by (metis Derives1_def LeftDerives1_def append_eq_conv_conj leftderives1_def
    leftmost_def)

lemma leftmost_Derives1_leftderives:
  "leftmost i a \<Longrightarrow> Derives1 a i r b \<Longrightarrow> leftderives b c \<Longrightarrow> leftderives a c"
using LeftDerives1_def LeftDerives1_implies_leftderives1
  leftderives1_implies_leftderives leftderives_trans by blast

theorem Derivation_implies_leftderives_gen:
  "Derivation a D (u@v) \<Longrightarrow> is_word u \<Longrightarrow> (\<exists> w.
          leftderives a (u@w) \<and>
          (v = [] \<longrightarrow> w = []) \<and>
          (\<forall> X. is_first X v \<longrightarrow> is_first X w))"
proof (induct "length D" arbitrary: D a u v)
  case 0
    then have "a = u@v" by auto
    thus ?case by (rule_tac x = v in exI, auto)
next
  case (Suc n)
    from Suc have "D \<noteq> []" by auto
    with Suc Derivation_leftmost have "\<exists> i. leftmost i a" by auto
    then obtain i where i: "leftmost i a" by blast
    show "?case"
    proof (cases "derivation_ge D (Suc i)")
      case True
        with Suc have leftmost: "leftmost i (u@v)"
          by (rule_tac leftmost_unaffected_Derivation[OF True i], auto)
        have length_u: "length u \<le> i"
          using leftmost_append[OF leftmost Suc(4)] .
        have take_Suc: "take (Suc i) a = take (Suc i) (u@v)"
          using  Derivation_take[OF True Suc(3)] .
        with length_u have is_prefix_u: "is_prefix u a"
          by (metis append_assoc append_take_drop_id dual_order.strict_implies_order
              is_prefix_def le_imp_less_Suc take_all take_append)
        have a: "u @ drop (length u) a = a"
          using is_prefix_unsplit[OF is_prefix_u] .
        from take_Suc have length_take_Suc: "length (take (Suc i) a) = Suc i"
          by (metis Suc_leI i leftmost_def length_take min.absorb2)
        have v: "v \<noteq> []"
        proof(cases "v = []")
          case False thus ?thesis by auto
        next
          case True
          with length_u have right: "length(take (Suc i) (u@v)) = length u" by simp
          note left = length_take_Suc
          from left right take_Suc have "Suc i = length u" by auto
          with length_u show ?thesis by auto
        qed
        then have "\<exists> X w. v = X#w" by (cases v, auto)
        then obtain X w where v: "v = X#w" by blast
        have is_first_X: "is_first X (drop (length u) a)"
          apply (rule_tac is_first_drop_length[where v=v and w=w and k="Suc i"])
          apply (simp_all add: take_Suc v)
          apply (metis Suc_leI i leftmost_def)
          apply (insert length_u)
          apply arith
          done
        show ?thesis
          apply (rule exI[where x="drop (length u) a"])
          by (simp add: a v is_first_cons is_first_X)
    next
      case False
      have Di: "derivation_ge D i"
      using leftmost_Derivation[OF i Suc(3), where j=i, simplified] .
      from split_derivation_leftmost[OF Di False]
      obtain E F r where D_split: "D = E @ [(i, r)] @ F"
        and E_Suc: "derivation_ge E (Suc i)" by auto
      let ?D = "(derivation_shift E 1 (length (snd r)))@F"
      from D_split
      have "Derivation a ((i,r) # ?D) (u @ v)"
        using Derivation_swap_single_mid_to_front E_Suc Suc.prems(1) lessI by blast
      then have "\<exists> y. Derives1 a i r y \<and> Derivation y ?D (u @ v)" by simp
      then obtain y where ay:"Derives1 a i r y"
        and yuv: "Derivation y ?D (u @ v)" by blast
      have length_D': "length ?D = n" using D_split Suc.hyps(2) by auto
      from Suc(1)[OF length_D'[symmetric] yuv Suc(4)]
      obtain w where "leftderives y (u @ w)" and "(v = [] \<longrightarrow> w = [])"
        and "\<forall>X. is_first X v \<longrightarrow> is_first X w" by blast
      then show ?thesis using ay i leftmost_Derives1_leftderives by blast
    qed
qed

lemma derives_implies_leftderives_gen: "derives a (u@v) \<Longrightarrow> is_word u \<Longrightarrow> (\<exists> w.
          leftderives a (u@w) \<and>
          (v = [] \<longrightarrow> w = []) \<and>
          (\<forall> X. is_first X v \<longrightarrow> is_first X w))"
using Derivation_implies_leftderives_gen derives_implies_Derivation by blast

lemma derives_implies_leftderives: "derives a b \<Longrightarrow> is_word b \<Longrightarrow> leftderives a b"
using derives_implies_leftderives_gen by force

fun LeftDerivation :: "sentence \<Rightarrow> derivation \<Rightarrow> sentence \<Rightarrow> bool"
where
  "LeftDerivation a [] b = (a = b)"
| "LeftDerivation a (d#D) b = (\<exists> x. LeftDerives1 a (fst d) (snd d) x \<and> LeftDerivation x D b)"

lemma LeftDerives1_implies_Derives1: "LeftDerives1 a i r b \<Longrightarrow> Derives1 a i r b"
by (metis LeftDerives1_def)

lemma LeftDerivation_implies_Derivation:
  "LeftDerivation a D b \<Longrightarrow> Derivation a D b"
proof (induct D arbitrary: a)
  case (Nil) thus ?case by simp
next
  case (Cons d D)
  thus ?case
  using CFG.LeftDerivation.simps(2) CFG_axioms Derivation.simps(2)
    LeftDerives1_implies_Derives1 by blast
qed

lemma LeftDerivation_implies_leftderives: "LeftDerivation a D b \<Longrightarrow> leftderives a b"
proof (induct D arbitrary: a b)
  case Nil thus ?case by simp
next
  case (Cons d D)
    note ihyps = this
    from ihyps have "\<exists> x. LeftDerives1 a (fst d) (snd d) x \<and> LeftDerivation x D b" by auto
    then obtain x where "LeftDerives1 a (fst d) (snd d) x" and xb: "LeftDerivation x D b" by blast
    with LeftDerives1_implies_leftderives1 have d1: "leftderives a x" by auto
    from ihyps xb have d2:"leftderives x b" by simp
    show "leftderives a b" by (rule leftderives_trans[OF d1 d2])
qed

lemma leftmost_witness[simp]: "leftmost (length x) (x@(N#y)) = (is_word x \<and> is_nonterminal N)"
  by (auto simp add: leftmost_def)

lemma leftderives1_implies_LeftDerives1:
  assumes leftderives1: "leftderives1 u v"
  shows "\<exists> i r. LeftDerives1 u i r v"
proof -
  from leftderives1 have
    "\<exists>x y N \<alpha>. u = x @ [N] @ y \<and> v = x @ \<alpha> @ y \<and> is_word x \<and> is_sentence y \<and> (N, \<alpha>) \<in> \<RR>"
    by (simp add: leftderives1_def)
  then obtain x y N \<alpha> where
    u:"u = x @ [N] @ y" and
    v:"v = x @ \<alpha> @ y" and
    x:"is_word x" and
    y:"is_sentence y" and
    r:"(N, \<alpha>) \<in> \<RR>"
    by blast
  show ?thesis
    apply (rule_tac x="length x" in exI)
    apply (rule_tac x="(N, \<alpha>)" in exI)
    apply (auto simp add: LeftDerives1_def)
    apply (simp add: leftmost_def x u rule_nonterminal_type[OF r])
    apply (simp add: Derives1_def u v)
    apply (rule_tac x=x in exI)
    apply (rule_tac x=y in exI)
    apply (auto simp add: x y r)
    done
qed

lemma LeftDerivation_LeftDerives1:
  "LeftDerivation a S y \<Longrightarrow> LeftDerives1 y i r z \<Longrightarrow> LeftDerivation a (S@[(i,r)]) z"
proof (induct S arbitrary: a y z i r)
  case Nil thus ?case by simp
next
  case (Cons s S) thus ?case
    by (metis LeftDerivation.simps(2) append_Cons)
qed

lemma leftderives_implies_LeftDerivation: "leftderives a b \<Longrightarrow> \<exists> D. LeftDerivation a D b"
proof (induct rule: leftderives_induct)
  case Base
  show ?case by (rule exI[where x="[]"], simp)
next
  case (Step y z)
  note ihyps = this
  from ihyps obtain D where ay: "LeftDerivation a D y" by blast
  from ihyps leftderives1_implies_LeftDerives1 obtain i r where yz: "LeftDerives1 y i r z" by blast
  from LeftDerivation_LeftDerives1[OF ay yz] show ?case by auto
qed

lemma LeftDerivation_append:
  "LeftDerivation a (D@E) c = (\<exists> b. LeftDerivation a D b \<and> LeftDerivation b E c)"
proof(induct D arbitrary: a c E)
  case Nil thus ?case by auto
next
  case (Cons d D) thus ?case by auto
qed

lemma LeftDerivation_implies_append:
  "LeftDerivation a D b \<Longrightarrow> LeftDerivation b E c \<Longrightarrow> LeftDerivation a (D@E) c"
using LeftDerivation_append by blast

lemma Derivation_unique_dest: "Derivation a D b \<Longrightarrow> Derivation a D c \<Longrightarrow> b = c"
  apply (induct D arbitrary: a b c)
  apply auto
  using Derives1_unique_dest by blast

lemma Derivation_unique_src: "Derivation a D c \<Longrightarrow> Derivation b D c \<Longrightarrow> a = b"
  apply (induct D arbitrary: a b c)
  apply auto
  using Derives1_unique_src by blast

lemma LeftDerives1_unique: "LeftDerives1 a i r b \<Longrightarrow> LeftDerives1 a j s b \<Longrightarrow> i = j \<and> r = s"
using Derives1_def LeftDerives1_def leftmost_unique by auto

lemma leftlang: "\<L> = { v | v. is_word v \<and> is_leftderivation v }"
by (metis (no_types, lifting) CFG.is_derivation_def CFG.is_leftderivation_def
    CFG.leftderivation_implies_derivation CFG_axioms Collect_cong
    \<L>_def derives_implies_leftderives)

lemma leftprefixlang:  "\<L>\<^sub>P = { u | u v. is_word u \<and> is_leftderivation (u@v) }"
apply (auto simp add: \<L>\<^sub>P_def)
using derives_implies_leftderives_gen is_derivation_def is_leftderivation_def apply blast
using leftderivation_implies_derivation by blast

lemma derives_implies_leftderives_cons:
  "is_word a \<Longrightarrow> derives u (a@X#b) \<Longrightarrow> \<exists> c. leftderives u  (a@X#c)"
by (metis append_Cons append_Nil derives_implies_leftderives_gen is_first_def)

lemma is_word_append[simp]: "is_word (a@b) = (is_word a \<and> is_word b)"
  by (auto simp add: is_word_def)

lemma \<L>\<^sub>P_split: "a@b \<in> \<L>\<^sub>P \<Longrightarrow> a \<in> \<L>\<^sub>P"
  by (auto simp add: \<L>\<^sub>P_def)

lemma \<L>\<^sub>P_is_word: "a \<in> \<L>\<^sub>P \<Longrightarrow> is_word a"
  by (metis (no_types, lifting) leftprefixlang mem_Collect_eq)

definition Derive :: "sentence \<Rightarrow> derivation \<Rightarrow> sentence"
where
  "Derive a D = (THE b. Derivation a D b)"

lemma Derivation_dest_ex_unique: "Derivation a D b \<Longrightarrow> \<exists>! x. Derivation a D x"
using CFG.Derivation_unique_dest CFG_axioms by blast

lemma Derive:
  assumes ab: "Derivation a D b"
  shows "Derive a D = b"
proof -
  note the1_equality[OF Derivation_dest_ex_unique[OF ab] ab]
  thus ?thesis by (simp add: Derive_def)
qed

end

end


(*<*)theory WFrec imports Main begin(*>*)

text\<open>\noindent
So far, all recursive definitions were shown to terminate via measure
functions. Sometimes this can be inconvenient or
impossible. Fortunately, \isacommand{recdef} supports much more
general definitions. For example, termination of Ackermann's function
can be shown by means of the \rmindex{lexicographic product} \<open><*lex*>\<close>:
\<close>

consts ack :: "nat\<times>nat \<Rightarrow> nat"
recdef ack "measure(\<lambda>m. m) <*lex*> measure(\<lambda>n. n)"
  "ack(0,n)         = Suc n"
  "ack(Suc m,0)     = ack(m, 1)"
  "ack(Suc m,Suc n) = ack(m,ack(Suc m,n))"

text\<open>\noindent
The lexicographic product decreases if either its first component
decreases (as in the second equation and in the outer call in the
third equation) or its first component stays the same and the second
component decreases (as in the inner call in the third equation).

In general, \isacommand{recdef} supports termination proofs based on
arbitrary well-founded relations as introduced in \S\ref{sec:Well-founded}.
This is called \textbf{well-founded
recursion}\indexbold{recursion!well-founded}.  A function definition
is total if and only if the set of
all pairs $(r,l)$, where $l$ is the argument on the
left-hand side of an equation and $r$ the argument of some recursive call on
the corresponding right-hand side, induces a well-founded relation.  For a
systematic account of termination proofs via well-founded relations see, for
example, Baader and Nipkow~@{cite "Baader-Nipkow"}.

Each \isacommand{recdef} definition should be accompanied (after the function's
name) by a well-founded relation on the function's argument type.
Isabelle/HOL formalizes some of the most important
constructions of well-founded relations (see \S\ref{sec:Well-founded}). For
example, @{term"measure f"} is always well-founded.   The lexicographic
product of two well-founded relations is again well-founded, which we relied
on when defining Ackermann's function above.
Of course the lexicographic product can also be iterated:
\<close>

consts contrived :: "nat \<times> nat \<times> nat \<Rightarrow> nat"
recdef contrived
  "measure(\<lambda>i. i) <*lex*> measure(\<lambda>j. j) <*lex*> measure(\<lambda>k. k)"
"contrived(i,j,Suc k) = contrived(i,j,k)"
"contrived(i,Suc j,0) = contrived(i,j,j)"
"contrived(Suc i,0,0) = contrived(i,i,i)"
"contrived(0,0,0)     = 0"

text\<open>
Lexicographic products of measure functions already go a long
way. Furthermore, you may embed a type in an
existing well-founded relation via the inverse image construction @{term
inv_image}. All these constructions are known to \isacommand{recdef}. Thus you
will never have to prove well-foundedness of any relation composed
solely of these building blocks. But of course the proof of
termination of your function definition --- that the arguments
decrease with every recursive call --- may still require you to provide
additional lemmas.

It is also possible to use your own well-founded relations with
\isacommand{recdef}.  For example, the greater-than relation can be made
well-founded by cutting it off at a certain point.  Here is an example
of a recursive function that calls itself with increasing values up to ten:
\<close>

consts f :: "nat \<Rightarrow> nat"
recdef (*<*)(permissive)(*>*)f "{(i,j). j<i \<and> i \<le> (10::nat)}"
"f i = (if 10 \<le> i then 0 else i * f(Suc i))"

text\<open>\noindent
Since \isacommand{recdef} is not prepared for the relation supplied above,
Isabelle rejects the definition.  We should first have proved that
our relation was well-founded:
\<close>

lemma wf_greater: "wf {(i,j). j<i \<and> i \<le> (N::nat)}"

txt\<open>\noindent
The proof is by showing that our relation is a subset of another well-founded
relation: one given by a measure function.\index{*wf_subset (theorem)}
\<close>

apply (rule wf_subset [of "measure (\<lambda>k::nat. N-k)"], blast)

txt\<open>
@{subgoals[display,indent=0,margin=65]}

\noindent
The inclusion remains to be proved. After unfolding some definitions,
we are left with simple arithmetic that is dispatched automatically.
\<close>

by (clarify, simp add: measure_def inv_image_def)

text\<open>\noindent

Armed with this lemma, we use the \attrdx{recdef_wf} attribute to attach a
crucial hint\cmmdx{hints} to our definition:
\<close>
(*<*)
consts g :: "nat \<Rightarrow> nat"
recdef g "{(i,j). j<i \<and> i \<le> (10::nat)}"
"g i = (if 10 \<le> i then 0 else i * g(Suc i))"
(*>*)
(hints recdef_wf: wf_greater)

text\<open>\noindent
Alternatively, we could have given \<open>measure (\<lambda>k::nat. 10-k)\<close> for the
well-founded relation in our \isacommand{recdef}.  However, the arithmetic
goal in the lemma above would have arisen instead in the \isacommand{recdef}
termination proof, where we have less control.  A tailor-made termination
relation makes even more sense when it can be used in several function
declarations.
\<close>

(*<*)end(*>*)


(* 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.*)
  theory TIP_sort_BSortSorts
  imports "../../Test_Base"
begin

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

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

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "int list => int list => int list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((z <= y2) & (ordered (cons2 y2 xs)))"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

(*fun did not finish the proof*)
function bmerge :: "int list => int list => int list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: int list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "int list => int list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "ordered (bsort xs)"
  oops

end


(*  Title:  HOL/ex/Arith_Examples.thy
    Author: Tjark Weber
*)

section \<open>Arithmetic\<close>

theory Arith_Examples
imports MainRLT
begin

text \<open>
  The \<open>arith\<close> method is used frequently throughout the Isabelle
  distribution.  This file merely contains some additional tests and special
  corner cases.  Some rather technical remarks:

  \<^ML>\<open>Lin_Arith.simple_tac\<close> is a very basic version of the tactic.  It performs no
  meta-to-object-logic conversion, and only some splitting of operators.
  \<^ML>\<open>Lin_Arith.tac\<close> performs meta-to-object-logic conversion, full
  splitting of operators, and NNF normalization of the goal.  The \<open>arith\<close>
  method combines them both, and tries other methods (e.g.~\<open>presburger\<close>)
  as well.  This is the one that you should use in your proofs!

  An \<open>arith\<close>-based simproc is available as well (see \<^ML>\<open>Lin_Arith.simproc\<close>), which---for performance
  reasons---however does even less splitting than \<^ML>\<open>Lin_Arith.simple_tac\<close>
  at the moment (namely inequalities only).  (On the other hand, it
  does take apart conjunctions, which \<^ML>\<open>Lin_Arith.simple_tac\<close> currently
  does not do.)
\<close>

subsection \<open>Splitting of Operators: \<^term>\<open>max\<close>, \<^term>\<open>min\<close>, \<^term>\<open>abs\<close>,
           \<^term>\<open>minus\<close>, \<^term>\<open>nat\<close>, \<^term>\<open>modulo\<close>,
           \<^term>\<open>divide\<close>\<close>

lemma "(i::nat) <= max i j"
  by linarith

lemma "(i::int) <= max i j"
  by linarith

lemma "min i j <= (i::nat)"
  by linarith

lemma "min i j <= (i::int)"
  by linarith

lemma "min (i::nat) j <= max i j"
  by linarith

lemma "min (i::int) j <= max i j"
  by linarith

lemma "min (i::nat) j + max i j = i + j"
  by linarith

lemma "min (i::int) j + max i j = i + j"
  by linarith

lemma "(i::nat) < j ==> min i j < max i j"
  by linarith

lemma "(i::int) < j ==> min i j < max i j"
  by linarith

lemma "(0::int) <= \<bar>i\<bar>"
  by linarith

lemma "(i::int) <= \<bar>i\<bar>"
  by linarith

lemma "\<bar>\<bar>i::int\<bar>\<bar> = \<bar>i\<bar>"
  by linarith

text \<open>Also testing subgoals with bound variables.\<close>

lemma "!!x. (x::nat) <= y ==> x - y = 0"
  by linarith

lemma "!!x. (x::nat) - y = 0 ==> x <= y"
  by linarith

lemma "!!x. ((x::nat) <= y) = (x - y = 0)"
  by linarith

lemma "[| (x::nat) < y; d < 1 |] ==> x - y = d"
  by linarith

lemma "[| (x::nat) < y; d < 1 |] ==> x - y - x = d - x"
  by linarith

lemma "(x::int) < y ==> x - y < 0"
  by linarith

lemma "nat (i + j) <= nat i + nat j"
  by linarith

lemma "i < j ==> nat (i - j) = 0"
  by linarith

lemma "(i::nat) mod 0 = i"
  using split_mod [of _ _ 0, arith_split]
    \<comment> \<open>rule \<^text>\<open>split_mod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::nat) mod 1 = 0"
  (* rule split_mod is only declared by default for numerals *)
  using split_mod [of _ _ 1, arith_split]
    \<comment> \<open>rule \<^text>\<open>split_mod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::nat) mod 42 <= 41"
  by linarith

lemma "(i::int) mod 0 = i"
  using split_zmod [of _ _ 0, arith_split]
    \<comment> \<open>rule \<^text>\<open>split_zmod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::int) mod 1 = 0"
  using split_zmod [of _ _ "1", arith_split]
    \<comment> \<open>rule \<^text>\<open>split_zmod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::int) mod 42 <= 41"
  by linarith

lemma "-(i::int) * 1 = 0 ==> i = 0"
  by linarith

lemma "[| (0::int) < \<bar>i\<bar>; \<bar>i\<bar> * 1 < \<bar>i\<bar> * j |] ==> 1 < \<bar>i\<bar> * j"
  by linarith

subsection \<open>Meta-Logic\<close>

lemma "x < Suc y == x <= y"
  by linarith

lemma "((x::nat) == z ==> x ~= y) ==> x ~= y | z ~= y"
  by linarith

subsection \<open>Various Other Examples\<close>

lemma "(x < Suc y) = (x <= y)"
  by linarith

lemma "[| (x::nat) < y; y < z |] ==> x < z"
  by linarith

lemma "(x::nat) < y & y < z ==> x < z"
  by linarith

text \<open>This example involves no arithmetic at all, but is solved by
  preprocessing (i.e. NNF normalization) alone.\<close>

lemma "(P::bool) = Q ==> Q = P"
  by linarith

lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> min (x::nat) y = 0"
  by linarith

lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> max (x::nat) y = x + y"
  by linarith

lemma "[| (x::nat) ~= y; a + 2 = b; a < y; y < b; a < x; x < b |] ==> False"
  by linarith

lemma "[| (x::nat) > y; y > z; z > x |] ==> False"
  by linarith

lemma "(x::nat) - 5 > y ==> y < x"
  by linarith

lemma "(x::nat) ~= 0 ==> 0 < x"
  by linarith

lemma "[| (x::nat) ~= y; x <= y |] ==> x < y"
  by linarith

lemma "[| (x::nat) < y; P (x - y) |] ==> P 0"
  by linarith

lemma "(x - y) - (x::nat) = (x - x) - y"
  by linarith

lemma "[| (a::nat) < b; c < d |] ==> (a - b) = (c - d)"
  by linarith

lemma "((a::nat) - (b - (c - (d - e)))) = (a - (b - (c - (d - e))))"
  by linarith

lemma "(n < m & m < n') | (n < m & m = n') | (n < n' & n' < m) |
  (n = n' & n' < m) | (n = m & m < n') |
  (n' < m & m < n) | (n' < m & m = n) |
  (n' < n & n < m) | (n' = n & n < m) | (n' = m & m < n) |
  (m < n & n < n') | (m < n & n' = n) | (m < n' & n' < n) |
  (m = n & n < n') | (m = n' & n' < n) |
  (n' = m & m = (n::nat))"
(* FIXME: this should work in principle, but is extremely slow because     *)
(*        preprocessing negates the goal and tries to compute its negation *)
(*        normal form, which creates lots of separate cases for this       *)
(*        disjunction of conjunctions                                      *)
(* by (tactic {* Lin_Arith.tac 1 *}) *)
oops

lemma "2 * (x::nat) ~= 1"
(* FIXME: this is beyond the scope of the decision procedure at the moment, *)
(*        because its negation is satisfiable in the rationals?             *)
(* by (tactic {* Lin_Arith.simple_tac 1 *}) *)
oops

text \<open>Constants.\<close>

lemma "(0::nat) < 1"
  by linarith

lemma "(0::int) < 1"
  by linarith

lemma "(47::nat) + 11 < 8 * 15"
  by linarith

lemma "(47::int) + 11 < 8 * 15"
  by linarith

text \<open>Splitting of inequalities of different type.\<close>

lemma "[| (a::nat) ~= b; (i::int) ~= j; a < 2; b < 2 |] ==>
  a + b <= nat (max \<bar>i\<bar> \<bar>j\<bar>)"
  by linarith

text \<open>Again, but different order.\<close>

lemma "[| (i::int) ~= j; (a::nat) ~= b; a < 2; b < 2 |] ==>
  a + b <= nat (max \<bar>i\<bar> \<bar>j\<bar>)"
  by linarith

end


(* 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.*)
  theory TIP_sort_nat_StoogeSort2Permutes
  imports "../../Test_Base"
begin

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

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

datatype Nat = Z | S "Nat"

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

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun times :: "Nat => Nat => Nat" where
  "times (Z) z = Z"
| "times (S z2) z = plus z (times z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "Nat list => Nat list"
  and stoogesort2 :: "Nat list => Nat list"
  and stooge2sort1 :: "Nat list => Nat list" where
  "stooge2sort2 y =
   (case
      splitAt (idiv (S (times (S (S Z)) (length y))) (S (S (S Z)))) y
      of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort2 xs) xs"
  oops

end


(*  Title:       Isabelle Collections Framework
    Author:      Peter Lammich <lammich at in.tum.de>
    Maintainer:  Peter Lammich <lammich at in.tum.de>
*)
section \<open>\isaheader{More Generic Algorithms}\<close>
theory Algos
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
  "../spec/ListSpec"
begin
text_raw \<open>\label{thy:Algos}\<close>

subsection "Injective Map to Naturals"

text "Whether a set is an initial segment of the natural numbers"
definition inatseg :: "nat set \<Rightarrow> bool"
  where "inatseg s == \<exists>k. s = {i::nat. i<k}"

lemma inatseg_simps[simp]:
  "inatseg {}"
  "inatseg {0}"
  by (unfold inatseg_def)
    auto

text "Compute an injective map from objects into an initial
    segment of the natural numbers"
locale map_to_nat_loc =
  s: StdSet s_ops +
  m: StdMap m_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and m_ops :: "('x,nat,'m,'more2) map_ops_scheme"
begin

  definition map_to_nat
    :: "'s \<Rightarrow> 'm" where
    "map_to_nat s ==
      snd (s.iterate s (\<lambda>x (c,m). (c+1,m.update x c m)) (0,m.empty ()))"

  lemma map_to_nat_correct:
    assumes INV[simp]: "s.invar s"
    shows
      \<comment> \<open>All elements have got a number\<close>
      "dom (m.\<alpha> (map_to_nat s)) = s.\<alpha> s" (is ?T1) and
      \<comment> \<open>No two elements got the same number\<close>
      [rule_format]: "inj_on (m.\<alpha> (map_to_nat s)) (s.\<alpha> s)" (is ?T2) and
      \<comment> \<open>Numbering is inatseg\<close>
      [rule_format]: "inatseg (ran (m.\<alpha> (map_to_nat s)))" (is ?T3) and
      \<comment> \<open>The result satisfies the map invariant\<close>
      "m.invar (map_to_nat s)" (is ?T4)
    proof -
      have i_aux: "!!m S S' k v. \<lbrakk>inj_on m S; S' = insert k S; v\<notin>ran m\<rbrakk>
                                 \<Longrightarrow> inj_on (m(k\<mapsto>v)) S'"
        apply (rule inj_onI)
        apply (simp split: if_split_asm)
        apply (simp add: ran_def)
        apply (simp add: ran_def)
        apply blast
        apply (blast dest: inj_onD)
        done

      have "?T1 \<and> ?T2 \<and> ?T3 \<and> ?T4"
        apply (unfold map_to_nat_def)
        apply (rule_tac I="\<lambda>it (c,m).
          m.invar m \<and>
          dom (m.\<alpha> m) = s.\<alpha> s - it \<and>
          inj_on (m.\<alpha> m) (s.\<alpha> s - it) \<and>
          (ran (m.\<alpha> m) = {i. i<c})
          " in s.iterate_rule_P)
        apply simp
        apply (simp add: m.empty_correct)
        apply (case_tac \<sigma>)
        apply (simp add: m.empty_correct m.update_correct)
        apply (intro conjI)
        apply blast
        apply clarify
        apply (rule_tac m2="m.\<alpha> ba" and
                        k2=x and v2=aa and
                        S'2="(s.\<alpha> s - (it - {x}))" and
                        S2="(s.\<alpha> s - it)"
                        in i_aux)
        apply auto [3]
        apply auto [1]
        apply (case_tac \<sigma>)
        apply (auto simp add: inatseg_def)
        done
      thus ?T1 ?T2 ?T3 ?T4 by auto
    qed

end

subsection "Map from Set"
text "Build a map using a set of keys and a function to compute the values."

locale it_dom_fun_to_map_loc =
  s: StdSet s_ops
+ m: StdMap m_ops
  for s_ops :: "('k,'s,'more1) set_ops_scheme"
  and m_ops :: "('k,'v,'m,'more2) map_ops_scheme"
begin

  definition it_dom_fun_to_map ::
    "'s \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> 'm"
    where "it_dom_fun_to_map s f ==
           s.iterate s (\<lambda>k m. m.update_dj k (f k) m) (m.empty ())"

  lemma it_dom_fun_to_map_correct:
    assumes INV: "s.invar s"
    shows "m.\<alpha> (it_dom_fun_to_map s f) k
      = (if k \<in> s.\<alpha> s then Some (f k) else None)" (is ?G1)
    and "m.invar (it_dom_fun_to_map s f)" (is ?G2)
  proof -
    have "m.\<alpha> (it_dom_fun_to_map s f) k
      = (if k \<in> s.\<alpha> s then Some (f k) else None) \<and>
      m.invar (it_dom_fun_to_map s f)"
      unfolding it_dom_fun_to_map_def
      apply (rule s.iterate_rule_P[where
        I = "\<lambda>it res. m.invar res
        \<and> (\<forall>k. m.\<alpha> res k = (if (k \<in> (s.\<alpha> s) - it) then Some (f k) else None))"
        ])
        apply (simp add: INV)

        apply (simp add: m.empty_correct)

        apply (subgoal_tac "x\<notin>dom (m.\<alpha> \<sigma>)")

        apply (auto simp: INV m.empty_correct m.update_dj_correct) []

        apply auto [2]
      done
    thus ?G1 and ?G2
      by auto
  qed

end

locale set_to_list_defs_loc =
  s: StdSetDefs s_ops
+ l: StdListDefs l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  definition "g_set_to_listl s \<equiv> s.iterate s l.appendl (l.empty ())"
  definition "g_set_to_listr s \<equiv> s.iterate s l.appendr (l.empty ())"
end

locale set_to_list_loc = set_to_list_defs_loc s_ops l_ops
+ s: StdSet s_ops
+ l: StdList l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  lemma g_set_to_listl_correct:
    assumes I: "s.invar s"
    shows "List.set (l.\<alpha> (g_set_to_listl s)) = s.\<alpha> s"
    and "l.invar (g_set_to_listl s)"
    and "distinct (l.\<alpha> (g_set_to_listl s))"
    using I apply -
    unfolding g_set_to_listl_def
    apply (rule_tac I="\<lambda>it \<sigma>. l.invar \<sigma> \<and> List.set (l.\<alpha> \<sigma>) = it
      \<and> distinct (l.\<alpha> \<sigma>)"
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

  lemma g_set_to_listr_correct:
    assumes I: "s.invar s"
    shows "List.set (l.\<alpha> (g_set_to_listr s)) = s.\<alpha> s"
    and "l.invar (g_set_to_listr s)"
    and "distinct (l.\<alpha> (g_set_to_listr s))"
    using I apply -
    unfolding g_set_to_listr_def
    apply (rule_tac I="\<lambda>it \<sigma>. l.invar \<sigma> \<and> List.set (l.\<alpha> \<sigma>) = it
      \<and> distinct (l.\<alpha> \<sigma>)"
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

end

end


(*  Title:      CCL/Hered.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section \<open>Hereditary Termination -- cf. Martin Lo\"f\<close>

theory Hered
imports Type
begin

text \<open>
  Note that this is based on an untyped equality and so \<open>lam
  x. b(x)\<close> is only hereditarily terminating if \<open>ALL x. b(x)\<close>
  is.  Not so useful for functions!
\<close>

definition HTTgen :: "i set \<Rightarrow> i set" where
  "HTTgen(R) ==
    {t. t=true | t=false | (EX a b. t= <a, b> \<and> a : R \<and> b : R) |
      (EX f. t = lam x. f(x) \<and> (ALL x. f(x) : R))}"

definition HTT :: "i set"
  where "HTT == gfp(HTTgen)"

subsection \<open>Hereditary Termination\<close>

lemma HTTgen_mono: "mono(\<lambda>X. HTTgen(X))"
  apply (unfold HTTgen_def)
  apply (rule monoI)
  apply blast
  done

lemma HTTgenXH:
  "t : HTTgen(A) \<longleftrightarrow> t=true | t=false | (EX a b. t=<a,b> \<and> a : A \<and> b : A) |
                                        (EX f. t=lam x. f(x) \<and> (ALL x. f(x) : A))"
  apply (unfold HTTgen_def)
  apply blast
  done

lemma HTTXH:
  "t : HTT \<longleftrightarrow> t=true | t=false | (EX a b. t=<a,b> \<and> a : HTT \<and> b : HTT) |
                                   (EX f. t=lam x. f(x) \<and> (ALL x. f(x) : HTT))"
  apply (rule HTTgen_mono [THEN HTT_def [THEN def_gfp_Tarski], THEN XHlemma1, unfolded HTTgen_def])
  apply blast
  done

subsection \<open>Introduction Rules for HTT\<close>

lemma HTT_bot: "\<not> bot : HTT"
  by (blast dest: HTTXH [THEN iffD1])

lemma HTT_true: "true : HTT"
  by (blast intro: HTTXH [THEN iffD2])

lemma HTT_false: "false : HTT"
  by (blast intro: HTTXH [THEN iffD2])

lemma HTT_pair: "<a,b> : HTT \<longleftrightarrow> a : HTT \<and> b : HTT"
  apply (rule HTTXH [THEN iff_trans])
  apply blast
  done

lemma HTT_lam: "lam x. f(x) : HTT \<longleftrightarrow> (ALL x. f(x) : HTT)"
  apply (rule HTTXH [THEN iff_trans])
  apply auto
  done

lemmas HTT_rews1 = HTT_bot HTT_true HTT_false HTT_pair HTT_lam

lemma HTT_rews2:
  "one : HTT"
  "inl(a) : HTT \<longleftrightarrow> a : HTT"
  "inr(b) : HTT \<longleftrightarrow> b : HTT"
  "zero : HTT"
  "succ(n) : HTT \<longleftrightarrow> n : HTT"
  "[] : HTT"
  "x$xs : HTT \<longleftrightarrow> x : HTT \<and> xs : HTT"
  by (simp_all add: data_defs HTT_rews1)

lemmas HTT_rews = HTT_rews1 HTT_rews2

subsection \<open>Coinduction for HTT\<close>

lemma HTT_coinduct: "\<lbrakk>t : R; R <= HTTgen(R)\<rbrakk> \<Longrightarrow> t : HTT"
  apply (erule HTT_def [THEN def_coinduct])
  apply assumption
  done

lemma HTT_coinduct3: "\<lbrakk>t : R; R <= HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))\<rbrakk> \<Longrightarrow> t : HTT"
  apply (erule HTTgen_mono [THEN [3] HTT_def [THEN def_coinduct3]])
  apply assumption
  done

lemma HTTgenIs:
  "true : HTTgen(R)"
  "false : HTTgen(R)"
  "\<lbrakk>a : R; b : R\<rbrakk> \<Longrightarrow> <a,b> : HTTgen(R)"
  "\<And>b. (\<And>x. b(x) : R) \<Longrightarrow> lam x. b(x) : HTTgen(R)"
  "one : HTTgen(R)"
  "a : lfp(\<lambda>x. HTTgen(x) Un R Un HTT) \<Longrightarrow> inl(a) : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "b : lfp(\<lambda>x. HTTgen(x) Un R Un HTT) \<Longrightarrow> inr(b) : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "zero : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "n : lfp(\<lambda>x. HTTgen(x) Un R Un HTT) \<Longrightarrow> succ(n) : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "[] : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "\<lbrakk>h : lfp(\<lambda>x. HTTgen(x) Un R Un HTT); t : lfp(\<lambda>x. HTTgen(x) Un R Un HTT)\<rbrakk> \<Longrightarrow>
    h$t : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  unfolding data_defs by (genIs HTTgenXH HTTgen_mono)+

subsection \<open>Formation Rules for Types\<close>

lemma UnitF: "Unit <= HTT"
  by (simp add: subsetXH UnitXH HTT_rews)

lemma BoolF: "Bool <= HTT"
  by (fastforce simp: subsetXH BoolXH iff: HTT_rews)

lemma PlusF: "\<lbrakk>A <= HTT; B <= HTT\<rbrakk> \<Longrightarrow> A + B  <= HTT"
  by (fastforce simp: subsetXH PlusXH iff: HTT_rews)

lemma SigmaF: "\<lbrakk>A <= HTT; \<And>x. x:A \<Longrightarrow> B(x) <= HTT\<rbrakk> \<Longrightarrow> SUM x:A. B(x) <= HTT"
  by (fastforce simp: subsetXH SgXH HTT_rews)

(*** Formation Rules for Recursive types - using coinduction these only need ***)
(***                                          exhaution rule for type-former ***)

(*Proof by induction - needs induction rule for type*)
lemma "Nat <= HTT"
  apply (simp add: subsetXH)
  apply clarify
  apply (erule Nat_ind)
   apply (fastforce iff: HTT_rews)+
  done

lemma NatF: "Nat <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI] dest: NatXH [THEN iffD1])
  done

lemma ListF: "A <= HTT \<Longrightarrow> List(A) <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
    subsetD [THEN HTTgen_mono [THEN ci3_AI]]
    dest: ListXH [THEN iffD1])
  done

lemma ListsF: "A <= HTT \<Longrightarrow> Lists(A) <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
    subsetD [THEN HTTgen_mono [THEN ci3_AI]] dest: ListsXH [THEN iffD1])
  done

lemma IListsF: "A <= HTT \<Longrightarrow> ILists(A) <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
    subsetD [THEN HTTgen_mono [THEN ci3_AI]] dest: IListsXH [THEN iffD1])
  done

end


(* IsageoCoq2_R1

Highschool3.thy

Version 2.2.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Version 2.1.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)
theory Highschool3

imports
  Highschool2
  Tarski_Euclidean_2D

begin

lemma (in Tarski_Euclidean_2D) NewEX1:
  assumes "Square A B C D" and
    "Cong K A K C" and
    "Cong K A A C"
  shows "Col B K D"
proof -
  obtain M where "M Midpoint A C"
    using MidR_uniq_aux by blast
  have "Cong B A B C"
    using Cong_cases Square_def assms(1) by auto
  have "Per A M B"
    using Per_def \<open>Cong B A B C\<close> \<open>M Midpoint A C\<close> l8_2 by blast
  hence "A M Perp M B"
    by (metis Square_def Square_not_triv_3 \<open>M Midpoint A C\<close> assms(1)
        cong_diff_2 is_midpoint_id l8_7 midpoint_thales_reci per_perp rect_per)
  have "Cong D A D C"
    using Square_def assms(1)
    by (meson Square_Rhombus cong_inner_transitivity not_cong_4312 rmb_cong)
  hence "Per A M D"
    using Per_def Per_perm \<open>M Midpoint A C\<close> cong_left_commutativity by blast
  hence "A M Perp M D"
    by (metis Cong_cases Square_def \<open>A M Perp M B\<close> \<open>M Midpoint A C\<close>
        assms(1) between_cong between_trivial2 midpoint_cong
        midpoint_thales_reci_2 per_perp rect_per)
  moreover
  have "Per A M K"
    using Per_def \<open>M Midpoint A C\<close> assms(2) l8_2 by blast
  hence "A M Perp M K"
    by (metis \<open>A M Perp M B\<close> \<open>M Midpoint A C\<close> assms(3)
        between_cong midpoint_bet midpoint_distinct_2
        not_cong_2134 per_perp perp_distinct)
  ultimately
  show ?thesis
    by (metis Col_def \<open>Cong B A B C\<close> \<open>Cong D A D C\<close> assms(2) assms(3)
        cong_diff perp2__col perp_not_col upper_dim)
qed

end