section \<open>Binary Search_Tree\<close>

theory Search_Tree
imports Main
begin

datatype 'a search_tree =
  Leaf ("\<langle>\<rangle>") |
  Node "'a search_tree" ("value": 'a) "'a search_tree" ("(1\<langle>_,/ _,/ _\<rangle>)")

datatype_compat search_tree

primrec left :: "'a search_tree \<Rightarrow> 'a search_tree" where
"left (Node l v r) = l" |
"left Leaf = Leaf"

primrec right :: "'a search_tree \<Rightarrow> 'a search_tree" where
"right (Node l v r) = r" |
"right Leaf = Leaf"

text\<open>Counting the number of leaves rather than nodes:\<close>

fun size1 :: "'a search_tree \<Rightarrow> nat" where
"size1 \<langle>\<rangle> = 1" |
"size1 \<langle>l, x, r\<rangle> = size1 l + size1 r"

fun subsearch_trees :: "'a search_tree \<Rightarrow> 'a search_tree set" where
"subsearch_trees \<langle>\<rangle> = {\<langle>\<rangle>}" |
"subsearch_trees (\<langle>l, a, r\<rangle>) = {\<langle>l, a, r\<rangle>} \<union> subsearch_trees l \<union> subsearch_trees r"

fun mirror :: "'a search_tree \<Rightarrow> 'a search_tree" where
"mirror \<langle>\<rangle> = Leaf" |
"mirror \<langle>l,x,r\<rangle> = \<langle>mirror r, x, mirror l\<rangle>"

class height = fixes height :: "'a \<Rightarrow> nat"

instantiation search_tree :: (type)height
begin

fun height_search_tree :: "'a search_tree => nat" where
"height Leaf = 0" |
"height (Node l a r) = max (height l) (height r) + 1"

instance ..

end

fun min_height :: "'a search_tree \<Rightarrow> nat" where
"min_height Leaf = 0" |
"min_height (Node l _ r) = min (min_height l) (min_height r) + 1"

fun complete :: "'a search_tree \<Rightarrow> bool" where
"complete Leaf = True" |
"complete (Node l x r) = (height l = height r \<and> complete l \<and> complete r)"

text \<open>Almost complete:\<close>
definition acomplete :: "'a search_tree \<Rightarrow> bool" where
"acomplete t = (height t - min_height t \<le> 1)"

text \<open>Weight balanced:\<close>
fun wbalanced :: "'a search_tree \<Rightarrow> bool" where
"wbalanced Leaf = True" |
"wbalanced (Node l x r) = (abs(int(size l) - int(size r)) \<le> 1 \<and> wbalanced l \<and> wbalanced r)"

text \<open>Internal path length:\<close>
fun ipl :: "'a search_tree \<Rightarrow> nat" where
"ipl Leaf = 0 " |
"ipl (Node l _ r) = ipl l + size l + ipl r + size r"

fun preorder :: "'a search_tree \<Rightarrow> 'a list" where
"preorder \<langle>\<rangle> = []" |
"preorder \<langle>l, x, r\<rangle> = x # preorder l @ preorder r"

fun inorder :: "'a search_tree \<Rightarrow> 'a list" where
"inorder \<langle>\<rangle> = []" |
"inorder \<langle>l, x, r\<rangle> = inorder l @ [x] @ inorder r"

text\<open>A linear version avoiding append:\<close>
fun inorder2 :: "'a search_tree \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"inorder2 \<langle>\<rangle> xs = xs" |
"inorder2 \<langle>l, x, r\<rangle> xs = inorder2 l (x # inorder2 r xs)"

fun postorder :: "'a search_tree \<Rightarrow> 'a list" where
"postorder \<langle>\<rangle> = []" |
"postorder \<langle>l, x, r\<rangle> = postorder l @ postorder r @ [x]"

text\<open>Binary Search Tree:\<close>
fun bst_wrt :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a search_tree \<Rightarrow> bool" where
"bst_wrt P \<langle>\<rangle> \<longleftrightarrow> True" |
"bst_wrt P \<langle>l, a, r\<rangle> \<longleftrightarrow>
 (\<forall>x\<in>set_search_tree l. P x a) \<and> (\<forall>x\<in>set_search_tree r. P a x) \<and> bst_wrt P l \<and> bst_wrt P r"

abbreviation bst :: "('a::linorder) search_tree \<Rightarrow> bool" where
"bst \<equiv> bst_wrt (<)"

fun (in linorder) heap :: "'a search_tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node l m r) =
  ((\<forall>x \<in> set_search_tree l \<union> set_search_tree r. m \<le> x) \<and> heap l \<and> heap r)"

subsection \<open>\<^const>\<open>map_search_tree\<close>\<close>

lemma eq_map_search_tree_Leaf[simp]: "map_search_tree f t = Leaf \<longleftrightarrow> t = Leaf"
by (rule search_tree.map_disc_iff)

lemma eq_Leaf_map_search_tree[simp]: "Leaf = map_search_tree f t \<longleftrightarrow> t = Leaf"
by (cases t) auto

subsection \<open>\<^const>\<open>size\<close>\<close>

lemma size1_size: "size1 t = size t + 1"
by (induction t) simp_all

lemma size1_ge0[simp]: "0 < size1 t"
by (simp add: size1_size)

lemma eq_size_0[simp]: "size t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma eq_0_size[simp]: "0 = size t \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma neq_Leaf_iff: "(t \<noteq> \<langle>\<rangle>) = (\<exists>l a r. t = \<langle>l, a, r\<rangle>)"
by (cases t) auto

lemma size_map_search_tree[simp]: "size (map_search_tree f t) = size t"
by (induction t) auto

lemma size1_map_search_tree[simp]: "size1 (map_search_tree f t) = size1 t"
by (simp add: size1_size)

subsection \<open>\<^const>\<open>set_search_tree\<close>\<close>

lemma eq_set_search_tree_empty[simp]: "set_search_tree t = {} \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma eq_empty_set_search_tree[simp]: "{} = set_search_tree t \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma finite_set_search_tree[simp]: "finite(set_search_tree t)"
by(induction t) auto

subsection \<open>\<^const>\<open>subsearch_trees\<close>\<close>

lemma neq_subsearch_trees_empty[simp]: "subsearch_trees t \<noteq> {}"
by (cases t)(auto)

lemma neq_empty_subsearch_trees[simp]: "{} \<noteq> subsearch_trees t"
by (cases t)(auto)

lemma size_subsearch_trees: "s \<in> subsearch_trees t \<Longrightarrow> size s \<le> size t"
by(induction t)(auto)

lemma set_search_treeE: "a \<in> set_search_tree t \<Longrightarrow> \<exists>l r. \<langle>l, a, r\<rangle> \<in> subsearch_trees t"
by (induction t)(auto)

lemma Node_notin_subsearch_trees_if[simp]: "a \<notin> set_search_tree t \<Longrightarrow> Node l a r \<notin> subsearch_trees t"
by (induction t) auto

lemma in_set_search_tree_if: "\<langle>l, a, r\<rangle> \<in> subsearch_trees t \<Longrightarrow> a \<in> set_search_tree t"
by (metis Node_notin_subsearch_trees_if)

subsection \<open>\<^const>\<open>height\<close> and \<^const>\<open>min_height\<close>\<close>

lemma eq_height_0[simp]: "height t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma eq_0_height[simp]: "0 = height t \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma height_map_search_tree[simp]: "height (map_search_tree f t) = height t"
by (induction t) auto

lemma height_le_size_search_tree: "height t \<le> size (t::'a search_tree)"
by (induction t) auto

lemma size1_height: "size1 t \<le> 2 ^ height (t::'a search_tree)"
proof(induction t)
  case (Node l a r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size1(Node l a r) = size1 l + size1 r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node l a r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size1(Node l a r) = size1 l + size1 r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

corollary size_height: "size t \<le> 2 ^ height (t::'a search_tree) - 1"
using size1_height[of t, unfolded size1_size] by(arith)

lemma height_subsearch_trees: "s \<in> subsearch_trees t \<Longrightarrow> height s \<le> height t"
by (induction t) auto

lemma min_height_le_height: "min_height t \<le> height t"
by(induction t) auto

lemma min_height_map_search_tree[simp]: "min_height (map_search_tree f t) = min_height t"
by (induction t) auto

lemma min_height_size1: "2 ^ min_height t \<le> size1 t"
proof(induction t)
  case (Node l a r)
  have "(2::nat) ^ min_height (Node l a r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size1(Node l a r)" using Node.IH by simp
  finally show ?case .
qed simp

subsection \<open>\<^const>\<open>complete\<close>\<close>

lemma complete_iff_height: "complete t \<longleftrightarrow> (min_height t = height t)"
apply(induction t)
 apply simp
apply (simp add: min_def max_def)
by (metis le_antisym le_trans min_height_le_height)

lemma size1_if_complete: "complete t \<Longrightarrow> size1 t = 2 ^ height t"
by (induction t) auto

lemma size_if_complete: "complete t \<Longrightarrow> size t = 2 ^ height t - 1"
using size1_if_complete[simplified size1_size] by fastforce

lemma size1_height_if_incomplete:
  "\<not> complete t \<Longrightarrow> size1 t < 2 ^ height t"
proof(induction t)
  case Leaf thus ?case by simp
next
  case (Node l x r)
  have 1: ?case if h: "height l < height r"
    using h size1_height[of l] size1_height[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 2: ?case if h: "height l > height r"
    using h size1_height[of l] size1_height[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 3: ?case if h: "height l = height r" and c: "\<not> complete l"
    using h size1_height[of r] Node.IH(1)[OF c] by(simp)
  have 4: ?case if h: "height l = height r" and c: "\<not> complete r"
    using h size1_height[of l] Node.IH(2)[OF c] by(simp)
  from 1 2 3 4 Node.prems show ?case apply (simp add: max_def) by linarith
qed

lemma complete_iff_min_height: "complete t \<longleftrightarrow> (height t = min_height t)"
by(auto simp add: complete_iff_height)

lemma min_height_size1_if_incomplete:
  "\<not> complete t \<Longrightarrow> 2 ^ min_height t < size1 t"
proof(induction t)
  case Leaf thus ?case by simp
next
  case (Node l x r)
  have 1: ?case if h: "min_height l < min_height r"
    using h min_height_size1[of l] min_height_size1[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 2: ?case if h: "min_height l > min_height r"
    using h min_height_size1[of l] min_height_size1[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 3: ?case if h: "min_height l = min_height r" and c: "\<not> complete l"
    using h min_height_size1[of r] Node.IH(1)[OF c] by(simp add: complete_iff_min_height)
  have 4: ?case if h: "min_height l = min_height r" and c: "\<not> complete r"
    using h min_height_size1[of l] Node.IH(2)[OF c] by(simp add: complete_iff_min_height)
  from 1 2 3 4 Node.prems show ?case
    by (fastforce simp: complete_iff_min_height[THEN iffD1])
qed

lemma complete_if_size1_height: "size1 t = 2 ^ height t \<Longrightarrow> complete t"
using  size1_height_if_incomplete by fastforce

lemma complete_if_size1_min_height: "size1 t = 2 ^ min_height t \<Longrightarrow> complete t"
using min_height_size1_if_incomplete by fastforce

lemma complete_iff_size1: "complete t \<longleftrightarrow> size1 t = 2 ^ height t"
using complete_if_size1_height size1_if_complete by blast

subsection \<open>\<^const>\<open>acomplete\<close>\<close>

lemma acomplete_subsearch_treeL: "acomplete (Node l x r) \<Longrightarrow> acomplete l"
by(simp add: acomplete_def)

lemma acomplete_subsearch_treeR: "acomplete (Node l x r) \<Longrightarrow> acomplete r"
by(simp add: acomplete_def)

lemma acomplete_subsearch_trees: "\<lbrakk> acomplete t; s \<in> subsearch_trees t \<rbrakk> \<Longrightarrow> acomplete s"
using [[simp_depth_limit=1]]
by(induction t arbitrary: s)
  (auto simp add: acomplete_subsearch_treeL acomplete_subsearch_treeR)

text\<open>Balanced search_trees have optimal height:\<close>

lemma acomplete_optimal:
fixes t :: "'a search_tree" and t' :: "'b search_tree"
assumes "acomplete t" "size t \<le> size t'" shows "height t \<le> height t'"
proof (cases "complete t")
  case True
  have "(2::nat) ^ height t \<le> 2 ^ height t'"
  proof -
    have "2 ^ height t = size1 t"
      using True by (simp add: size1_if_complete)
    also have "\<dots> \<le> size1 t'" using assms(2) by(simp add: size1_size)
    also have "\<dots> \<le> 2 ^ height t'" by (rule size1_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height t < 2 ^ height t'"
  proof -
    have "(2::nat) ^ min_height t < size1 t"
      by(rule min_height_size1_if_incomplete[OF False])
    also have "\<dots> \<le> size1 t'" using assms(2) by (simp add: size1_size)
    also have "\<dots> \<le> 2 ^ height t'"  by(rule size1_height)
    finally have "(2::nat) ^ min_height t < (2::nat) ^ height t'" .
    thus ?thesis .
  qed
  hence *: "min_height t < height t'" by simp
  have "min_height t + 1 = height t"
    using min_height_le_height[of t] assms(1) False
    by (simp add: complete_iff_height acomplete_def)
  with * show ?thesis by arith
qed

subsection \<open>\<^const>\<open>wbalanced\<close>\<close>

lemma wbalanced_subsearch_trees: "\<lbrakk> wbalanced t; s \<in> subsearch_trees t \<rbrakk> \<Longrightarrow> wbalanced s"
using [[simp_depth_limit=1]] by(induction t arbitrary: s) auto

subsection \<open>\<^const>\<open>ipl\<close>\<close>

text \<open>The internal path length of a search_tree:\<close>

lemma ipl_if_complete_int:
  "complete t \<Longrightarrow> int(ipl t) = (int(height t) - 2) * 2^(height t) + 2"
apply(induction t)
 apply simp
apply simp
apply (simp add: algebra_simps size_if_complete of_nat_diff)
done

subsection "List of entries"

lemma eq_inorder_Nil[simp]: "inorder t = [] \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma eq_Nil_inorder[simp]: "[] = inorder t \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma set_inorder[simp]: "set (inorder t) = set_search_tree t"
by (induction t) auto

lemma set_preorder[simp]: "set (preorder t) = set_search_tree t"
by (induction t) auto

lemma set_postorder[simp]: "set (postorder t) = set_search_tree t"
by (induction t) auto

lemma length_preorder[simp]: "length (preorder t) = size t"
by (induction t) auto

lemma length_inorder[simp]: "length (inorder t) = size t"
by (induction t) auto

lemma length_postorder[simp]: "length (postorder t) = size t"
by (induction t) auto

lemma preorder_map: "preorder (map_search_tree f t) = map f (preorder t)"
by (induction t) auto

lemma inorder_map: "inorder (map_search_tree f t) = map f (inorder t)"
by (induction t) auto

lemma postorder_map: "postorder (map_search_tree f t) = map f (postorder t)"
by (induction t) auto

lemma inorder2_inorder: "inorder2 t xs = inorder t @ xs"
by (induction t arbitrary: xs) auto

subsection \<open>Binary Search Tree\<close>

lemma bst_wrt_mono: "(\<And>x y. P x y \<Longrightarrow> Q x y) \<Longrightarrow> bst_wrt P t \<Longrightarrow> bst_wrt Q t"
by (induction t) (auto)

lemma bst_wrt_le_if_bst: "bst t \<Longrightarrow> bst_wrt (\<le>) t"
using bst_wrt_mono less_imp_le by blast

lemma bst_wrt_le_iff_sorted: "bst_wrt (\<le>) t \<longleftrightarrow> sorted (inorder t)"
apply (induction t)
 apply(simp)
by (fastforce simp: sorted_append intro: less_imp_le less_trans)

lemma bst_iff_sorted_wrt_less: "bst t \<longleftrightarrow> sorted_wrt (<) (inorder t)"
apply (induction t)
 apply simp
apply (fastforce simp: sorted_wrt_append)
done

subsection \<open>\<^const>\<open>heap\<close>\<close>

subsection \<open>\<^const>\<open>mirror\<close>\<close>

lemma mirror_Leaf[simp]: "mirror t = \<langle>\<rangle> \<longleftrightarrow> t = \<langle>\<rangle>"
by (induction t) simp_all

lemma Leaf_mirror[simp]: "\<langle>\<rangle> = mirror t \<longleftrightarrow> t = \<langle>\<rangle>"
using mirror_Leaf by fastforce

lemma size_mirror[simp]: "size(mirror t) = size t"
by (induction t) simp_all

lemma size1_mirror[simp]: "size1(mirror t) = size1 t"
by (simp add: size1_size)

lemma height_mirror[simp]: "height(mirror t) = height t"
by (induction t) simp_all

lemma min_height_mirror [simp]: "min_height (mirror t) = min_height t"
by (induction t) simp_all

lemma ipl_mirror [simp]: "ipl (mirror t) = ipl t"
by (induction t) simp_all

lemma inorder_mirror: "inorder(mirror t) = rev(inorder t)"
by (induction t) simp_all

lemma map_mirror: "map_search_tree f (mirror t) = mirror (map_search_tree f t)"
by (induction t) simp_all

lemma mirror_mirror[simp]: "mirror(mirror t) = t"
by (induction t) simp_all

end


section \<open>\isaheader{Examples from ITP-2010 slides (adopted to ICF v2)}\<close>
theory itp_2010
imports
  Collections.Collections
  Collections.Code_Target_ICF
begin

text \<open>
  Illustrates the various possibilities how to use the ICF in your own
  algorithms by simple examples. The examples all use the data refinement
  scheme, and either define a generic algorithm or fix the operations.
\<close>

subsection "List to Set"
text \<open>
  In this simple example we do conversion from a list to a set.
  We define an abstract algorithm.
  This is then refined by a generic algorithm using a locale and by a generic
  algorithm fixing its operations as parameters.
\<close>
  subsubsection "Straightforward version"
  \<comment> \<open>Abstract algorithm\<close>
  fun set_a where
    "set_a [] s = s" |
    "set_a (a#l) s = set_a l (insert a s)"

  \<comment> \<open>Correctness of aa\<close>
  lemma set_a_correct: "set_a l s = set l \<union> s"
    by (induct l arbitrary: s) auto

  \<comment> \<open>Generic algorithm\<close>

  setup Locale_Code.open_block \<comment> \<open>Required to make definitions inside locales
    executable\<close>
  fun (in StdSetDefs) set_i where
    "set_i [] s = s" |
    "set_i (a#l) s = set_i l (ins a s)"
  setup Locale_Code.close_block

  \<comment> \<open>Correct implementation of ca\<close>
  lemma (in StdSet) set_i_impl: "invar s \<Longrightarrow> invar (set_i l s) \<and> \<alpha> (set_i l s) = set_a l (\<alpha> s)"
    by (induct l arbitrary: s) (auto simp add: correct)

  \<comment> \<open>Instantiation\<close>
  (* We need to declare a constant to make the code generator work *)

  definition "hs_seti == hs.set_i"
  (*declare hs.set_i.simps[folded hs_seti_def, code]*)

  lemmas hs_set_i_impl = hs.set_i_impl[folded hs_seti_def]

export_code hs_seti checking SML

  \<comment> \<open>Code generation\<close>
  ML \<open>@{code hs_seti}\<close>
  (*value "hs_seti [1,2,3::nat] hs_empty"*)

  subsubsection "Tail-Recursive version"
  \<comment> \<open>Abstract algorithm\<close>
  fun set_a2 where
    "set_a2 [] = {}" |
    "set_a2 (a#l) = (insert a (set_a2 l))"

  \<comment> \<open>Correctness of aa\<close>
  lemma set_a2_correct: "set_a2 l = set l"
    by (induct l) auto

  \<comment> \<open>Generic algorithm\<close>
  setup Locale_Code.open_block
  fun (in StdSetDefs) set_i2 where
    "set_i2 [] = empty ()" |
    "set_i2 (a#l) = (ins a (set_i2 l))"
  setup Locale_Code.close_block

  \<comment> \<open>Correct implementation of ca\<close>
  lemma (in StdSet) set_i2_impl: "invar s \<Longrightarrow> invar (set_i2 l) \<and> \<alpha> (set_i2 l) = set_a2 l"
    by (induct l) (auto simp add: correct)

  \<comment> \<open>Instantiation\<close>
  definition "hs_seti2 == hs.set_i2"
  (*declare hsr.set_i2.simps[folded hs_seti2_def, code]*)

  lemmas hs_set_i2_impl = hs.set_i2_impl[folded hs_seti2_def]

  \<comment> \<open>Code generation\<close>
  ML \<open>@{code hs_seti2}\<close>
  (*value "hs_seti [1,2,3::nat] hs_empty"*)

subsubsection "With explicit operation parameters"

  \<comment> \<open>Alternative for few operation parameters\<close>
  fun set_i' where
    "!!ins. set_i' ins [] s = s" |
    "!!ins. set_i' ins (a#l) s = set_i' ins l (ins a s)"

  lemma (in StdSet) set_i'_impl:
    "invar s \<Longrightarrow> invar (set_i' ins l s) \<and> \<alpha> (set_i' ins l s) = set_a l (\<alpha> s)"
    by (induct l arbitrary: s) (auto simp add: correct)

  \<comment> \<open>Instantiation\<close>
  definition "hs_seti' == set_i' hs.ins"
  lemmas hs_set_i'_impl = hs.set_i'_impl[folded hs_seti'_def]

  \<comment> \<open>Code generation\<close>
  ML \<open>@{code hs_seti'}\<close>
  (*value "hs_seti' [1,2,3::nat] hs_empty"*)

subsection "Filter Average"
text \<open>
  In this more complex example, we develop a function that filters from a set all
  numbers that are above the average of the set.

  First, we formulate this as a generic algorithm using a locale.
  This solution shows how the ICF v2 overcomes some technical problems that
  ICF v1 had:
  \begin{itemize}
    \item Iterators are now polymorphic in the type, even inside locales.
      Hence, there is no special handling of iterators, as it was required
      in ICF v1.
    \item The Locale-Code package handles code generation for the instantiated
      locale. There is no need for lengthy boilerplate code as it was required
      in ICF v1.
  \end{itemize}

  Another possibility is to fix the used
  implementations beforehand. Changing the implementation is still easy by
  changing the used operations. In this example, all used operations are
  introduced by abbbreviations, localizing the required changes to a small part
  of the theory. This approach is more powerful, as operations are now
  polymorphic also in the element type. However, it only allows as single
  instantiation at a time, which is no option for generic algorithms.
\<close>

  abbreviation "average S == \<Sum>S div card S"

subsubsection "Generic Algorithm"
  locale MyContext =
    StdSet ops for ops :: "(nat,'s,'more) set_ops_scheme"
  begin
    definition avg_aux :: "'s \<Rightarrow> nat\<times>nat"
      where
      "avg_aux s == iterate s (\<lambda>x (c,s). (c+1, s+x)) (0,0)"

    definition "avg s == case avg_aux s of (c,s) \<Rightarrow> s div c"

    definition "filter_le_avg s == let a=avg s in
      iterate s (\<lambda>x s. if x\<le>a then ins x s else s) (empty ())"

    lemma avg_aux_correct: "invar s \<Longrightarrow> avg_aux s = (card (\<alpha> s), \<Sum>(\<alpha> s) )"
      apply (unfold avg_aux_def)
      apply (rule_tac
        I="\<lambda>it (c,sum). c=card (\<alpha> s - it) \<and> sum=\<Sum>(\<alpha> s - it)"
        in iterate_rule_P)
      apply auto
      apply (subgoal_tac "\<alpha> s - (it - {x}) = insert x (\<alpha> s - it)")
      apply auto
      apply (subgoal_tac "\<alpha> s - (it - {x}) = insert x (\<alpha> s - it)")
      apply auto
      done

    lemma avg_correct: "invar s \<Longrightarrow> avg s = average (\<alpha> s)"
      unfolding avg_def
      using avg_aux_correct
      by auto

    lemma filter_le_avg_correct:
      "invar s \<Longrightarrow>
        invar (filter_le_avg s) \<and>
        \<alpha> (filter_le_avg s) = {x\<in>\<alpha> s. x\<le>average (\<alpha> s)}"
      unfolding filter_le_avg_def Let_def
      apply (rule_tac
        I="\<lambda>it r. invar r \<and> \<alpha> r = {x\<in>\<alpha> s - it. x\<le>average (\<alpha> s)}"
        in iterate_rule_P)
      apply (auto simp add: correct avg_correct)
      done
  end

  setup Locale_Code.open_block
  interpretation hs_ctx: MyContext hs_ops by unfold_locales
  interpretation rs_ctx: MyContext rs_ops by unfold_locales
  setup Locale_Code.close_block

  definition "hs_flt_avg_test \<equiv> hs.to_list
    o hs_ctx.filter_le_avg
    o hs.from_list"
  definition "rs_flt_avg_test \<equiv> rs.to_list
    o rs_ctx.filter_le_avg
    o rs.from_list"

  text "Code generation"
  ML_val \<open>
    if @{code hs_flt_avg_test} (map @{code nat_of_integer} [1,2,3,4,6,7])
    <> @{code rs_flt_avg_test} (map @{code nat_of_integer} [1,2,3,4,6,7])
    then error "Oops"
    else ()
\<close>

subsubsection "Using abbreviations"

  type_synonym 'a my_set = "'a hs"
  abbreviation "my_\<alpha> == hs.\<alpha>"
  abbreviation "my_invar == hs.invar"
  abbreviation "my_empty == hs.empty"
  abbreviation "my_ins == hs.ins"
  abbreviation "my_iterate == hs.iteratei"
  lemmas my_correct = hs.correct
  lemmas my_iterate_rule_P = hs.iterate_rule_P

  definition avg_aux :: "nat my_set \<Rightarrow> nat\<times>nat"
    where
    "avg_aux s == my_iterate s (\<lambda>_. True) (\<lambda>x (c,s). (c+1, s+x)) (0,0)"

  definition "avg s == case avg_aux s of (c,s) \<Rightarrow> s div c"

  definition "filter_le_avg s == let a=avg s in
    my_iterate s (\<lambda>_. True) (\<lambda>x s. if x\<le>a then my_ins x s else s) (my_empty ())"

  lemma avg_aux_correct: "my_invar s \<Longrightarrow> avg_aux s = (card (my_\<alpha> s), \<Sum>(my_\<alpha> s) )"
    apply (unfold avg_aux_def)
    apply (rule_tac
      I="\<lambda>it (c,sum). c=card (my_\<alpha> s - it) \<and> sum=\<Sum>(my_\<alpha> s - it)"
      in my_iterate_rule_P)
    apply auto
    apply (subgoal_tac "my_\<alpha> s - (it - {x}) = insert x (my_\<alpha> s - it)")
    apply auto
    apply (subgoal_tac "my_\<alpha> s - (it - {x}) = insert x (my_\<alpha> s - it)")
    apply auto
    done

  lemma avg_correct: "my_invar s \<Longrightarrow> avg s = average (my_\<alpha> s)"
    unfolding avg_def
    using avg_aux_correct
    by auto

  lemma filter_le_avg_correct:
    "my_invar s \<Longrightarrow>
    my_invar (filter_le_avg s) \<and>
    my_\<alpha> (filter_le_avg s) = {x\<in>my_\<alpha> s. x\<le>average (my_\<alpha> s)}"
    unfolding filter_le_avg_def Let_def
    apply (rule_tac
      I="\<lambda>it r. my_invar r \<and> my_\<alpha> r = {x\<in>my_\<alpha> s - it. x\<le>average (my_\<alpha> s)}"
      in my_iterate_rule_P)
    apply (auto simp add: my_correct avg_correct)
    done

  definition "test_set == my_ins (1::nat) (my_ins 2 (my_ins 3 (my_empty ())))"

  export_code avg_aux avg filter_le_avg test_set in SML module_name Test

end


theory natDed imports Main
begin
text{* Regras de Dedução Natural no Isabelle. A seta dupla separa
       premissas da conclusão. *}

text{* Premissas \<turnstile> Conclusão (Premissas \<Longrightarrow> Conclusão) *}

thm conjI (* introdução da conjunção *)
thm conjunct1 (* eliminação da conjunção *)
thm conjunct2 (* eliminação da conjunção *)
thm disjI1 (* introdução da disjunção *)
thm disjI2 (* introdução da disjunção *)
thm disjE (* eliminação da disjunção *)
thm impI (* introdução da implicação *)
thm mp (* eliminação da implicação - modus ponens *)
thm notI (* introdução da negação *)
thm notE (* eliminação da negação *)
thm FalseE (* elimnação do Falso - bottom *)
thm ccontr (* contra-clássica - redução ao absurdo *)
thm allI (* introdução do quantificador universal *)
thm spec (* eliminação do quantificador universal *)
thm allE (* eliminação do quantificador universal *)
thm exI (* introdução do quantificador existencial *)
thm exE (* eliminação do quantificador existencial *)
thm refl (* introdução da igualdade - reflexividade *)
thm subst (* eliminação da igualdade *)
thm ssubst (* eliminação da igualdade *)
thm sym (* simetria da igualdade *)
thm trans (* transitividade da igualdade *)

text{* Hello World *}

theorem helloisar01:
assumes prem: "A \<and> B"
shows "B \<and> A"
  proof -
    from prem have d: "A" by (rule conjunct1)
    from prem have    "B" by (rule conjunct2)
    from this and d show "B \<and> A" by (rule conjI)
  qed

theorem helloisar02:
assumes prem: "A \<and> B"
shows "B \<and> A"
  proof (rule conjI)
    from prem show "B" by (rule conjunct2)
    from prem show "A" by (rule conjunct1)
  qed

text{* Exercício 1 *}

theorem ex1:
assumes prem: "(\<forall>x. F x) \<or> (\<forall>x. G x)"
shows "\<forall>x. F x \<or> G x"
  proof (rule allI) (* \<forall>I *)
    fix x0 (* hyp *)
    show "F x0 \<or> G x0"
      proof (rule disjE[OF prem]) (* \<or>E *)
        assume h1: "\<forall>x. F x"
          from h1 have "F x0" by (rule spec) (* \<forall>E *)
          from this show "F x0 \<or> G x0" by (rule disjI1) (* \<or>I1 *)
        next
        assume h1: "\<forall>x. G x"
          from h1 have "G x0" by (rule spec) (* \<forall>E *)
          from this show "F x0 \<or> G x0" by (rule disjI2) (* \<or>I2 *)
      qed
  qed

text{* Exercício 2 *}
text{* Exercício 3 *}
text{* Exercício 4 *}
text{* Exercício 5 *}

end


section\<open>Antichains\<close>

(*<*)
theory Antichain
  imports
    Auxiliary
begin
(*>*)

definition incomparable where
  "incomparable A = (\<forall>x \<in> A. \<forall>y \<in> A. x \<noteq> y \<longrightarrow> \<not> x < y \<and> \<not> y < x)"

lemma incomparable_empty[simp, intro]: "incomparable {}"
  unfolding incomparable_def by auto

typedef (overloaded) 'a :: order antichain =
  "{A :: 'a set. finite A \<and> incomparable A}"
  morphisms set_antichain antichain
  by auto

setup_lifting type_definition_antichain

lift_definition member_antichain :: "'a :: order \<Rightarrow> 'a antichain \<Rightarrow> bool" ("(_/ \<in>\<^sub>A _)" [51, 51] 50) is "Set.member" .

abbreviation not_member_antichain :: "'a :: order \<Rightarrow> 'a antichain \<Rightarrow> bool" ("(_/ \<notin>\<^sub>A _)" [51, 51] 50) where
  "x \<notin>\<^sub>A A \<equiv> \<not> x \<in>\<^sub>A A"

lift_definition empty_antichain :: "'a :: order antichain" ("{}\<^sub>A") is "{}" by simp

lemma mem_antichain_nonempty[simp]: "s \<in>\<^sub>A A \<Longrightarrow> A \<noteq> {}\<^sub>A"
  by transfer auto

definition "minimal_antichain A = {x \<in> A. \<not>(\<exists>y \<in> A. y < x)}"

lemma in_minimal_antichain: "x \<in> minimal_antichain A \<longleftrightarrow> x \<in> A \<and> \<not>(\<exists>y \<in> A. y < x)"
  unfolding minimal_antichain_def by auto

lemma in_antichain_minimal_antichain[simp]: "finite M \<Longrightarrow> x \<in>\<^sub>A antichain (minimal_antichain M) \<longleftrightarrow> x \<in> minimal_antichain M"
  apply (clarsimp simp: minimal_antichain_def member_antichain.rep_eq)
  apply (intro conjI iffI)
    apply (subst (asm) antichain_inverse)
     apply (simp add: incomparable_def)
    apply simp
   apply (subst (asm) antichain_inverse)
    apply (simp add: incomparable_def)
   apply simp
  apply (subst antichain_inverse)
   apply (simp add: incomparable_def)
  apply simp
  done

lemma incomparable_minimal_antichain[simp]: "incomparable (minimal_antichain A)"
  unfolding incomparable_def minimal_antichain_def
  by auto

lemma finite_minimal_antichain[simp]: "finite A \<Longrightarrow> finite (minimal_antichain A)"
  unfolding minimal_antichain_def by auto

lemma finite_set_antichain[simp, intro]: "finite (set_antichain A)"
  by transfer auto

lemma minimal_antichain_subset: "minimal_antichain A \<subseteq> A"
  unfolding minimal_antichain_def by auto

lift_definition frontier :: "'t :: order zmultiset \<Rightarrow> 't antichain" is
  "\<lambda>M. minimal_antichain {t. zcount M t > 0}"
  by (auto simp: finite_subset[OF minimal_antichain_subset finite_zcount_pos])

lemma member_frontier_pos_zmset: "t \<in>\<^sub>A frontier M \<Longrightarrow> 0 < zcount M t"
  by (simp add: frontier_def in_minimal_antichain)

lemma frontier_comparable_False[simp]: "x \<in>\<^sub>A frontier M \<Longrightarrow> y \<in>\<^sub>A frontier M \<Longrightarrow> x < y \<Longrightarrow> False"
  by transfer (auto simp: minimal_antichain_def)

lemma minimal_antichain_idempotent[simp]: "minimal_antichain (minimal_antichain A) = minimal_antichain A"
  by (auto simp: minimal_antichain_def)

instantiation antichain :: (order) minus begin
lift_definition minus_antichain :: "'a antichain \<Rightarrow> 'a antichain \<Rightarrow> 'a antichain" is "(-)"
  by (auto simp: incomparable_def)
instance ..
end

instantiation antichain :: (order) plus begin
lift_definition plus_antichain :: "'a antichain \<Rightarrow> 'a antichain \<Rightarrow> 'a antichain" is "\<lambda>M N. minimal_antichain (M \<union> N)"
  by (auto simp: incomparable_def minimal_antichain_def)
instance ..
end

lemma antichain_add_commute: "(M :: 'a :: order antichain) + N = N + M"
  by transfer (auto simp: incomparable_def sup_commute)

lift_definition filter_antichain :: "('a :: order \<Rightarrow> bool) \<Rightarrow> 'a antichain \<Rightarrow> 'a antichain" is "Set.filter"
  by (auto simp: incomparable_def)

syntax (ASCII)
  "_ACCollect" :: "pttrn \<Rightarrow> 'a :: order antichain \<Rightarrow> bool \<Rightarrow> 'a antichain" ("(1{_ :\<^sub>A _./ _})")
syntax
  "_ACCollect" :: "pttrn \<Rightarrow> 'a :: order antichain \<Rightarrow> bool \<Rightarrow> 'a antichain" ("(1{_ \<in>\<^sub>A _./ _})")
translations
  "{x \<in>\<^sub>A M. P}" == "CONST filter_antichain (\<lambda>x. P) M"

declare empty_antichain.rep_eq[simp]

lemma minimal_antichain_empty[simp]: "minimal_antichain {} = {}"
  by (simp add: minimal_antichain_def)

lemma minimal_antichain_singleton[simp]: "minimal_antichain {x::_ ::order} = {x}"
  by (auto simp: minimal_antichain_def)

lemma minimal_antichain_nonempty:
  "finite A \<Longrightarrow> (t::_::order) \<in> A \<Longrightarrow> minimal_antichain A \<noteq> {}"
  by (auto simp: minimal_antichain_def dest: order_finite_set_exists_foundation[of _ t])

lemma minimal_antichain_member:
  "finite A \<Longrightarrow> (t::_::order) \<in> A \<Longrightarrow> \<exists>t'. t' \<in> minimal_antichain A \<and> t' \<le> t"
  by (auto simp: minimal_antichain_def dest: order_finite_set_exists_foundation[of _ t])

lemma minimal_antichain_union: "minimal_antichain ((A::(_ :: order) set) \<union> B) \<subseteq> minimal_antichain (minimal_antichain A \<union> minimal_antichain B)"
  by (auto simp: minimal_antichain_def)

lemma ac_Diff_iff: "c \<in>\<^sub>A A - B \<longleftrightarrow> c \<in>\<^sub>A A \<and> c \<notin>\<^sub>A B"
  by transfer simp

lemma ac_DiffD2: "c \<in>\<^sub>A A - B \<Longrightarrow> c \<in>\<^sub>A B \<Longrightarrow> P"
  by transfer simp

lemma ac_notin_Diff: "\<not> x \<in>\<^sub>A A - B \<Longrightarrow> \<not> x \<in>\<^sub>A A \<or> x \<in>\<^sub>A B"
  by transfer simp

lemma ac_eq_iff: "A = B \<longleftrightarrow> (\<forall>x. x \<in>\<^sub>A A \<longleftrightarrow> x \<in>\<^sub>A B)"
  by transfer auto

lemma antichain_obtain_foundation:
  assumes   "t \<in>\<^sub>A M"
  obtains s where "s \<in>\<^sub>A M \<and> s \<le> t \<and> (\<forall>u. u\<in>\<^sub>AM \<longrightarrow> \<not> u < s)"
  using assms unfolding member_antichain.rep_eq
  by - (rule order_finite_set_obtain_foundation[of "set_antichain M" t]; auto)

lemma set_antichain1[simp]: "x \<in> set_antichain X \<Longrightarrow> x \<in>\<^sub>A X"
  by transfer simp

lemma set_antichain2[simp]: "x \<in>\<^sub>A X \<Longrightarrow> x \<in> set_antichain X"
  by transfer simp

(*<*)
end
(*>*)


theory Pascal_Property
  imports Main Projective_Plane_Axioms Pappus_Property
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> A hexagon is pascal if its three opposite sides meet in collinear points [is_pascal].
\<^item> A plane is pascal, or has Pascal's property, if for every hexagon of that plane
Pascal property is stable under any permutation of that hexagon.
\<close>

section \<open>Pascal's Property\<close>

definition inters :: "Lines \<Rightarrow> Lines \<Rightarrow> Points set" where
"inters l m \<equiv> {P. incid P l \<and> incid P m}"

lemma inters_is_singleton:
  assumes "l \<noteq> m" and "P \<in> inters l m" and "Q \<in> inters l m"
  shows "P = Q"
  using assms ax_uniqueness inters_def
  by blast

definition inter :: "Lines \<Rightarrow> Lines \<Rightarrow> Points" where
"inter l m \<equiv> @P. P \<in> inters l m"

lemma uniq_inter:
  assumes "l \<noteq> m" and "incid P l" and "incid P m"
  shows "inter l m = P"
proof -
  have "P \<in> inters l m"
    by (simp add: assms(2) assms(3) inters_def)
  have "\<forall>Q. Q \<in> inters l m \<longrightarrow> Q = P"
    using \<open>P \<in> inters l m\<close> assms(1) inters_is_singleton
    by blast
  show "inter l m = P"
    using \<open>P \<in> inters l m\<close> assms(1) inter_def inters_is_singleton
    by auto
qed

(* The configuration of a hexagon where the three pairs of opposite sides meet in
collinear points *)
definition is_pascal :: "[Points, Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"is_pascal A B C D E F \<equiv> distinct6 A B C D E F \<longrightarrow> line B C \<noteq> line E F \<longrightarrow> line C D \<noteq> line A F
\<longrightarrow> line A B \<noteq> line D E \<longrightarrow>
(let P = inter (line B C) (line E F) in
let Q = inter (line C D) (line A F) in
let R = inter (line A B) (line D E) in
col P Q R)"

lemma col_rot_CW:
  assumes "col P Q R"
  shows "col R P Q"
  using assms col_def
  by auto

lemma col_2cycle:
  assumes "col P Q R"
  shows "col P R Q"
  using assms col_def
  by auto

lemma distinct6_rot_CW:
  assumes "distinct6 A B C D E F"
  shows "distinct6 F A B C D E"
  using assms distinct6_def
  by auto

lemma lines_comm: "lines P Q = lines Q P"
  using lines_def
  by auto

lemma line_comm:
  assumes "P \<noteq> Q"
  shows "line P Q = line Q P"
  by (metis ax_uniqueness incidA_lAB incidB_lAB)

lemma inters_comm: "inters l m = inters m l"
  using inters_def
  by auto

lemma inter_comm: "inter l m = inter m l"
  by (simp add: inter_def inters_comm)

lemma inter_line_line_comm:
  assumes "C \<noteq> D"
  shows "inter (line A B) (line C D) = inter (line A B) (line D C)"
  using assms line_comm
  by auto

lemma inter_line_comm_line:
  assumes "A \<noteq> B"
  shows "inter (line A B) (line C D) = inter (line B A) (line C D)"
  using assms line_comm
  by auto

lemma inter_comm_line_line_comm:
  assumes "C \<noteq> D" and "line A B \<noteq> line C D"
  shows "inter (line A B) (line C D) = inter (line D C) (line A B)"
  by (metis inter_comm line_comm)

(* Pascal's property is stable under the 6-cycle [A B C D E F] *)
lemma is_pascal_rot_CW:
  assumes "is_pascal A B C D E F"
  shows "is_pascal F A B C D E"
proof -
  define P Q R where "P = inter (line A B) (line D E)" and "Q = inter (line B C) (line E F)" and
    "R = inter (line F A) (line C D)"
  have "col P Q R" if "distinct6 F A B C D E" and "line A B \<noteq> line D E" and "line B C \<noteq> line E F"
    and "line F A \<noteq> line C D"
    using P_def Q_def R_def assms col_rot_CW distinct6_def inter_comm is_pascal_def line_comm
      that(1) that(2) that(3) that(4)
    by auto
  then show "is_pascal F A B C D E"
    by (metis P_def Q_def R_def is_pascal_def line_comm)
qed

(* We recall that the group of permutations S_6 is generated by the 2-cycle [1 2]
and the 6-cycle [1 2 3 4 5 6] *)

(* Assuming Pappus's property, Pascal's property is stable under the 2-cycle [A B] *)

lemma incid_C_AB:
  assumes "A \<noteq> B" and "incid A l" and "incid B l" and "incid C l"
  shows "incid C (line A B)"
  using assms ax_uniqueness incidA_lAB incidB_lAB
  by blast

lemma incid_inters_left:
  assumes "P \<in> inters l m"
  shows "incid P l"
  using assms inters_def
  by auto

lemma incid_inters_right:
  assumes "P \<in> inters l m"
  shows "incid P m"
  using assms incid_inters_left inters_comm
  by blast

lemma inter_in_inters: "inter l m \<in> inters l m"
proof -
  have "\<exists>P. P \<in> inters l m"
    using inters_def ax2
    by auto
  show "inter l m \<in> inters l m"
    by (metis \<open>\<exists>P. P \<in> inters l m\<close> inter_def some_eq_ex)
qed

lemma incid_inter_left: "incid (inter l m) l"
  using incid_inters_left inter_in_inters
  by blast

lemma incid_inter_right: "incid (inter l m) m"
  using incid_inter_left inter_comm
  by fastforce

lemma col_A_B_ABl: "col A B (inter (line A B) l)"
  using col_def incidA_lAB incidB_lAB incid_inter_left
  by blast

lemma col_A_B_lAB: "col A B (inter l (line A B))"
  using col_A_B_ABl inter_comm
  by auto

lemma inter_is_a_intersec: "is_a_intersec (inter (line A B) (line C D)) A B C D"
  by (simp add: col_A_B_ABl col_A_B_lAB col_rot_CW is_a_intersec_def)

definition line_ext :: "Lines \<Rightarrow> Points set" where
"line_ext l \<equiv> {P. incid P l}"

lemma line_left_inter_1:
  assumes "P \<in> line_ext l" and "P \<notin> line_ext m"
  shows "line (inter l m) P = l"
  by (metis CollectD CollectI assms(1) assms(2) incidA_lAB incidB_lAB incid_inter_left
      incid_inter_right line_ext_def uniq_inter)

lemma line_left_inter_2:
  assumes "P \<in> line_ext m" and "P \<notin> line_ext l"
  shows "line (inter l m) P = m"
  using assms inter_comm line_left_inter_1
  by fastforce

lemma line_right_inter_1:
  assumes "P \<in> line_ext l" and "P \<notin> line_ext m"
  shows "line P (inter l m) = l"
  by (metis assms line_comm line_left_inter_1)

lemma line_right_inter_2:
  assumes "P \<in> line_ext m" and "P \<notin> line_ext l"
  shows "line P (inter l m) = m"
  by (metis assms inter_comm line_comm line_left_inter_1)

lemma inter_ABC_1:
  assumes "line A B \<noteq> line C A"
  shows "inter (line A B) (line C A) = A"
  using assms ax_uniqueness incidA_lAB incidB_lAB incid_inter_left incid_inter_right
  by blast

lemma line_inter_2:
  assumes "inter l m \<noteq> inter l' m"
  shows "line (inter l m) (inter l' m) = m"
  using assms ax_uniqueness incidA_lAB incidB_lAB incid_inter_right
  by blast

lemma col_line_ext_1:
  assumes "col A B C" and "A \<noteq> C"
  shows "B \<in> line_ext (line A C)"
  by (metis CollectI assms ax_uniqueness col_def incidA_lAB incidB_lAB line_ext_def)

lemma inter_line_ext_1:
  assumes "inter l m \<in> line_ext n" and "l \<noteq> m" and "l \<noteq> n"
  shows "inter l m = inter l n"
  using assms(1) assms(3) ax_uniqueness incid_inter_left incid_inter_right line_ext_def
  by blast

lemma inter_line_ext_2:
  assumes "inter l m \<in> line_ext n" and "l \<noteq> m" and "m \<noteq> n"
  shows "inter l m = inter m n"
  by (metis assms inter_comm inter_line_ext_1)

definition pascal_prop :: "bool" where
"pascal_prop \<equiv> \<forall>A B C D E F. is_pascal A B C D E F \<longrightarrow> is_pascal B A C D E F"

lemma pappus_pascal:
  assumes "is_pappus"
  shows "pascal_prop"
proof-
  have "is_pascal B A C D E F" if "is_pascal A B C D E F" for A B C D E F
  proof-
    define X Y Z where "X = inter (line A C) (line E F)" and "Y = inter (line C D) (line B F)"
      and "Z = inter (line B A) (line D E)"
    have "col X Y Z" if "distinct6 B A C D E F" and "line A C \<noteq> line E F" and "line C D \<noteq> line B F"
      and "line B A \<noteq> line D E" and "line B C = line E F"
      by (smt X_def Y_def ax_uniqueness col_ABA col_rot_CW distinct6_def incidB_lAB incid_inter_left
          incid_inter_right line_comm that(1) that(2) that(3) that(5))
    have "col X Y Z" if "distinct6 B A C D E F" and "line A C \<noteq> line E F" and "line C D \<noteq> line B F"
      and "line B A \<noteq> line D E" and "line C D = line A F"
      by (metis X_def Y_def col_ABA col_rot_CW distinct6_def inter_ABC_1 line_comm that(1) that(2)
          that(3) that(5))
    have "col X Y Z" if "distinct6 B A C D E F" and "line A C \<noteq> line E F" and "line C D \<noteq> line B F"
      and "line B A \<noteq> line D E" and "line B C \<noteq> line E F" and "line C D \<noteq> line A F"
    proof-
      define W where "W = inter (line A C) (line E F)"
      have "col A C W"
        by (simp add: col_A_B_ABl W_def)
      define P Q R where "P = inter (line B C) (line E F)"
        and "Q = inter (line A B) (line D E)"
        and "R = inter (line C D) (line A F)"
      have "col P Q R"
        using P_def Q_def R_def \<open>is_pascal A B C D E F\<close> col_2cycle distinct6_def is_pascal_def
          line_comm that(1) that(4) that(5) that(6)
        by auto
          (* Below we take care of a few degenerate cases *)
      have "col X Y Z" if "P = Q"
        by (smt P_def Q_def X_def Y_def Z_def \<open>distinct6 B A C D E F\<close> ax_uniqueness col_ABA col_def
            distinct6_def incidA_lAB incidB_lAB incid_inter_left inter_comm that)
      have "col X Y Z" if "P = R"
        by (smt P_def R_def X_def Y_def Z_def \<open>distinct6 B A C D E F\<close> \<open>line A C \<noteq> line E F\<close>
            \<open>line C D \<noteq> line B F\<close> col_2cycle col_A_B_ABl col_rot_CW distinct6_def incidA_lAB
            incidB_lAB incid_inter_left incid_inter_right that uniq_inter)
      have "col X Y Z" if "P = A"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>P = Q \<Longrightarrow> col X Y Z\<close> \<open>P = R \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>line B C \<noteq> line E F\<close> ax_uniqueness col_def incidA_lAB incid_inter_left
            incid_inter_right line_comm that)
      have "col X Y Z" if "P = C"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>P = R \<Longrightarrow> col X Y Z\<close> \<open>col P Q R\<close>
            \<open>line A C \<noteq> line E F\<close> ax_uniqueness col_def incidA_lAB incid_inter_left
            incid_inter_right line_comm that)
      have "col X Y Z" if "P = W"
        by (smt P_def Q_def R_def W_def X_def Y_def Z_def \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>P = Q \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>distinct6 B A C D E F\<close> ax_uniqueness col_def distinct6_def incidB_lAB
            incid_inter_left incid_inter_right line_comm that)
      have "col X Y Z" if "Q = R"
        by (smt Q_def R_def X_def Y_def Z_def \<open>distinct6 B A C D E F\<close> ax_uniqueness col_A_B_lAB
            col_rot_CW distinct6_def incidB_lAB incid_inter_right inter_comm line_comm that)
      have "col X Y Z" if "Q = A"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>col P Q R\<close> \<open>distinct6 B A C D E F\<close>
            \<open>line C D \<noteq> line B F\<close> ax_uniqueness col_ABA col_def distinct6_def incidA_lAB incidB_lAB
            incid_inter_left incid_inter_right that)
      have "col X Y Z" if "Q = C"
        by (metis P_def Q_def W_def \<open>P = W \<Longrightarrow> col X Y Z\<close> \<open>distinct6 B A C D E F\<close> ax_uniqueness
            distinct6_def incidA_lAB incid_inter_left line_comm that)
      have "col X Y Z" if "Q = W"
        by (metis Q_def W_def X_def Z_def col_ABA line_comm that)
      have "col X Y Z" if "R = A"
        by (smt P_def Q_def R_def W_def X_def Y_def \<open>P = W \<Longrightarrow> col X Y Z\<close> \<open>Q = A \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>distinct6 B A C D E F\<close> ax_uniqueness col_ABA col_def col_rot_CW distinct6_def
            incidA_lAB incidB_lAB incid_inter_right inter_comm that)
      have "col X Y Z" if "R = C"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>col P Q R\<close> \<open>distinct6 B A C D E F\<close>
            \<open>line A C \<noteq> line E F\<close> ax_uniqueness col_def distinct6_def incidA_lAB incidB_lAB
            incid_inter_left inter_comm that)
      have "col X Y Z" if "R = W"
        by (metis R_def W_def \<open>R = A \<Longrightarrow> col X Y Z\<close> \<open>R = C \<Longrightarrow> col X Y Z\<close> \<open>line C D \<noteq> line A F\<close>
            ax_uniqueness incidA_lAB incidB_lAB incid_inter_left incid_inter_right that)
      have "col X Y Z" if "A = W"
        by (smt P_def Q_def R_def W_def X_def Y_def Z_def \<open>P = R \<Longrightarrow> col X Y Z\<close> \<open>Q = A \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>distinct6 B A C D E F\<close> ax_uniqueness col_def distinct6_def incidA_lAB
            incidB_lAB incid_inter_left incid_inter_right that)
      have "col X Y Z" if "C = W"
        by (metis P_def W_def \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>line B C \<noteq> line E F\<close> ax_uniqueness incidB_lAB
            incid_inter_left incid_inter_right that)
      have f1:"col (inter (line P C) (line A Q)) (inter (line Q W) (line C R))
      (inter (line P W) (line A R))" if "distinct6 P Q R A C W"
        using assms(1) is_pappus_def is_pappus2_def \<open>distinct6 P Q R A C W\<close> \<open>col P Q R\<close>
          \<open>col A C W\<close> inter_is_a_intersec inter_line_line_comm
        by metis
      have "col X Y Z" if "C \<in> line_ext (line E F)"
        using P_def \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>line B C \<noteq> line E F\<close> incidB_lAB line_ext_def that uniq_inter
        by auto
      have "col X Y Z" if "A \<in> line_ext (line D E)"
        by (metis Q_def \<open>Q = A \<Longrightarrow> col X Y Z\<close> \<open>line B A \<noteq> line D E\<close> ax_uniqueness incidA_lAB
            incid_inter_left incid_inter_right line_comm line_ext_def mem_Collect_eq that)
      have "col X Y Z" if "line B C = line A B"
        by (metis P_def W_def \<open>P = W \<Longrightarrow> col X Y Z\<close> \<open>distinct6 B A C D E F\<close> ax_uniqueness
            distinct6_def incidA_lAB incidB_lAB that)
          (* We can resume our proof with the non-degenerate case *)
      have f2:"inter (line P C) (line A Q) = B" if
        "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        by (smt CollectI P_def Q_def ax_uniqueness incidA_lAB incidB_lAB incid_inter_left
            incid_inter_right line_ext_def that(1) that(2) that(3))
          (* Again, we need to take care of a few particular cases *)
      have "col X Y Z" if "line E F = line A F"
        by (metis W_def \<open>A = W \<Longrightarrow> col X Y Z\<close> \<open>line A C \<noteq> line E F\<close> inter_ABC_1 inter_comm that)
      have "col X Y Z" if "A \<in> line_ext (line C D)"
        using R_def \<open>R = A \<Longrightarrow> col X Y Z\<close> \<open>line C D \<noteq> line A F\<close> ax_uniqueness incidA_lAB
          incid_inter_left incid_inter_right line_ext_def that
        by blast
      have "col X Y Z" if "inter (line B C) (line E F) = inter (line A C) (line E F)"
        by (simp add: P_def W_def \<open>P = W \<Longrightarrow> col X Y Z\<close> that)
          (* We resume the general case *)
      have f3:"inter (line P W) (line A R) = F" if "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (smt CollectI P_def R_def W_def ax_uniqueness incidA_lAB incidB_lAB incid_inter_left
            incid_inter_right line_ext_def that(1) that(2) that(3))
          (* Once again, first we need to handle a particular case, namely C \<in> AF, then
            we resume the general case *)
      have "col X Y Z" if "C \<in> line_ext (line A F)"
        using R_def \<open>R = C \<Longrightarrow> col X Y Z\<close> \<open>line C D \<noteq> line A F\<close> ax_uniqueness incidA_lAB
          incid_inter_left incid_inter_right line_ext_def that
        by blast
      have f4:"inter (line Q W) (line C R) = inter (line Q W) (line C D)" if "C \<notin> line_ext (line A F)"
        using R_def incidA_lAB line_ext_def line_right_inter_1 that
        by auto
      then have "inter (line Q W) (line C D) \<in> line_ext (line B F)" if "distinct6 P Q R A C W"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (smt R_def \<open>distinct6 B A C D E F\<close> ax_uniqueness col_line_ext_1 distinct6_def f1 f2 f3
            incidA_lAB incidB_lAB incid_inter_left that(1) that(2) that(3) that(5) that(6) that(7))
      then have "inter (line Q W) (line C D) = inter (line C D) (line B F)" if "distinct6 P Q R A C W"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (smt W_def \<open>distinct6 B A C D E F\<close> \<open>line C D \<noteq> line B F\<close> ax_uniqueness distinct6_def f2
            incidA_lAB incidB_lAB incid_inter_left incid_inter_right inter_line_ext_2 that(1) that(2)
            that(3) that(5) that(6) that(7))
      moreover have "inter (line C D) (line B F) \<in> line_ext (line Q W)" if "distinct6 P Q R A C W"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (metis calculation col_2cycle col_A_B_ABl col_line_ext_1 distinct6_def that(1) that(2)
            that(3) that(4) that(5) that(6) that(7))
      ultimately have "col (inter (line A C) (line E F)) (inter (line C D) (line B F))
      (inter (line A B) (line D E))" if "distinct6 P Q R A C W"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (metis Q_def W_def col_A_B_ABl col_rot_CW that(1) that(2) that(3) that(4) that(5) that(6)
            that(7))
      show "col X Y Z"
        by (metis P_def W_def X_def Y_def Z_def \<open>A = W \<Longrightarrow> col X Y Z\<close> \<open>A \<in> line_ext (line C D) \<Longrightarrow> col X Y Z\<close>
            \<open>A \<in> line_ext (line D E) \<Longrightarrow> col X Y Z\<close> \<open>C = W \<Longrightarrow> col X Y Z\<close> \<open>C \<in> line_ext (line E F) \<Longrightarrow> col X Y Z\<close>
            \<open>P = A \<Longrightarrow> col X Y Z\<close> \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>P = Q \<Longrightarrow> col X Y Z\<close> \<open>P = R \<Longrightarrow> col X Y Z\<close>
            \<open>Pascal_Property.inter (line B C) (line E F) = Pascal_Property.inter (line A C) (line E F) \<Longrightarrow> col X Y Z\<close>
            \<open>Q = A \<Longrightarrow> col X Y Z\<close> \<open>Q = C \<Longrightarrow> col X Y Z\<close> \<open>Q = R \<Longrightarrow> col X Y Z\<close> \<open>Q = W \<Longrightarrow> col X Y Z\<close> \<open>R = A \<Longrightarrow> col X Y Z\<close>
            \<open>R = C \<Longrightarrow> col X Y Z\<close> \<open>R = W \<Longrightarrow> col X Y Z\<close> \<open>\<lbrakk>distinct6 P Q R A C W; C \<notin> line_ext (line E F); A \<notin> line_ext (line D E); line B C \<noteq> line A B; line E F \<noteq> line A F; A \<notin> line_ext (line C D); Pascal_Property.inter (line B C) (line E F) \<noteq> Pascal_Property.inter (line A C) (line E F)\<rbrakk> \<Longrightarrow> col (Pascal_Property.inter (line A C) (line E F)) (Pascal_Property.inter (line C D) (line B F)) (Pascal_Property.inter (line A B) (line D E))\<close>
            \<open>line B C = line A B \<Longrightarrow> col X Y Z\<close> \<open>line E F = line A F \<Longrightarrow> col X Y Z\<close> distinct6_def line_comm)
     qed
     show "is_pascal B A C D E F"
       using X_def Y_def Z_def \<open>\<lbrakk>distinct6 B A C D E F; line A C \<noteq> line E F; line C D \<noteq> line B F; line B A \<noteq> line D E; line B C = line E F\<rbrakk> \<Longrightarrow> col X Y Z\<close>
         \<open>\<lbrakk>distinct6 B A C D E F; line A C \<noteq> line E F; line C D \<noteq> line B F; line B A \<noteq> line D E; line B C \<noteq> line E F; line C D \<noteq> line A F\<rbrakk> \<Longrightarrow> col X Y Z\<close>
         \<open>\<lbrakk>distinct6 B A C D E F; line A C \<noteq> line E F; line C D \<noteq> line B F; line B A \<noteq> line D E; line C D = line A F\<rbrakk> \<Longrightarrow> col X Y Z\<close>
         is_pascal_def
       by force
  qed
  thus "pascal_prop" using pascal_prop_def
    by auto
qed

lemma is_pascal_under_alternate_vertices:
  assumes "pascal_prop" and "is_pascal A B C A' B' C'"
  shows "is_pascal A B' C A' B C'"
  using assms pascal_prop_def is_pascal_rot_CW
  by presburger

lemma col_inter:
  assumes "distinct6 A B C D E F" and "col A B C" and "col D E F"
  shows "inter (line B C) (line E F) = inter (line A B) (line D E)"
  by (smt assms ax_uniqueness col_def distinct6_def incidA_lAB incidB_lAB)

lemma pascal_pappus1:
  assumes "pascal_prop"
  shows "is_pappus1 A B C A' B' C' P Q R"
proof-
  define a1 a2 a3 a4 a5 a6 where "a1 = distinct6 A B C A' B' C'"  and "a2 = col A B C" and
"a3 = col A' B' C'" and "a4 = is_a_proper_intersec P A B' A' B" and "a5 = is_a_proper_intersec Q B C' B' C"
and "a6 = is_a_proper_intersec R A C' A' C"
  (* i.e. we have assumed a Pappus configuration *)
  have "inter (line B C) (line B' C') = inter (line A B) (line A' B')" if a1 a2 a3 a4 a5 a6
    using a1_def a2_def a3_def col_inter that(1) that(2) that(3)
    by blast
  then have "is_pascal A B C A' B' C'" if a1 a2 a3 a4 a5 a6
    using a1_def col_ABA is_pascal_def that(1) that(2) that(3) that(4) that(5) that(6)
    by auto
  then have "is_pascal A B' C A' B C'" if a1 a2 a3 a4 a5 a6
    using assms is_pascal_under_alternate_vertices that(1) that(2) that(3) that(4) that(5) that(6)
    by blast
  then have "col P Q R" if a1 a2 a3 a4 a5 a6
    by (smt a1_def a4_def a5_def a6_def ax_uniqueness col_def distinct6_def incidB_lAB incid_inter_left
        incid_inter_right is_a_proper_intersec_def is_pascal_def line_comm that(1) that(2) that(3)
        that(4) that(5) that(6))
  show "is_pappus1 A B C A' B' C' P Q R"
    by (simp add: \<open>\<lbrakk>a1; a2; a3; a4; a5; a6\<rbrakk> \<Longrightarrow> col P Q R\<close> a1_def a2_def a3_def a4_def a5_def a6_def
        is_pappus1_def)
qed

lemma pascal_pappus:
  assumes "pascal_prop"
  shows "is_pappus"
  by (simp add: assms is_pappus_def pappus12 pascal_pappus1)

theorem pappus_iff_pascal: "is_pappus = pascal_prop"
  using pappus_pascal pascal_pappus
  by blast

end