(* Author: Bernhard Stöckl *)

theory JoinTree
  imports Complex_Main "HOL-Library.Multiset" "Selectivities"
begin

section \<open>Join Tree\<close>

text\<open>
  Relations have an identifier and cardinalities. Joins have two children and a result cardinality.
  The datatype only represents the structure while cardinalities are given by a separate function.
\<close>
datatype (relations:'a) joinTree = Relation 'a | Join "'a joinTree" "'a joinTree"

type_synonym 'a card = "'a \<Rightarrow> real"

subsection \<open>Functions\<close>

subsubsection \<open>Functions for Information Retrieval\<close>

fun inorder :: "'a joinTree \<Rightarrow> 'a list" where
  "inorder (Relation rel) = [rel]"
| "inorder (Join l r) = inorder l @ inorder r"

fun revorder :: "'a joinTree \<Rightarrow> 'a list" where
  "revorder (Relation rel) = [rel]"
| "revorder (Join l r) = revorder r @ revorder l"

fun relations_mset :: "'a joinTree \<Rightarrow> 'a multiset" where
  "relations_mset (Relation rel) = {#rel#}"
| "relations_mset (Join l r) = relations_mset l + relations_mset r"

fun card :: "'a card \<Rightarrow> 'a selectivity \<Rightarrow> 'a joinTree \<Rightarrow> real" where
  "card cf f (Relation rel) = cf rel"
| "card cf f (Join l r) =
    list_sel f (inorder l) (inorder r) * card cf f l * card cf f r"

fun cards_list :: "'a card \<Rightarrow> 'a joinTree \<Rightarrow> ('a\<times>real) list" where
  "cards_list cf (Relation rel) = [(rel,cf rel)]"
| "cards_list cf (Join l r) = cards_list cf l @ cards_list cf r"

fun height :: "'a joinTree \<Rightarrow> nat" where
  "height (Relation _) = 0"
| "height (Join l r) = max (height l) (height r) + 1"

fun num_relations :: "'a joinTree \<Rightarrow> nat" where
  "num_relations (Relation _) = 1"
| "num_relations (Join l r) = num_relations l + num_relations r"

fun first_node :: "'a joinTree \<Rightarrow> 'a" where
  "first_node (Relation r) = r"
| "first_node (Join l _) = first_node l"

subsubsection \<open>Functions for Correctness Checks\<close>

text \<open>
  Cardinalities must be positive and selectivities need to be @{text "\<in> (0,1]"}.
\<close>
fun reasonable_cards :: "'a card \<Rightarrow> 'a selectivity \<Rightarrow> 'a joinTree \<Rightarrow> bool" where
  "reasonable_cards cf f (Relation rel) = (cf rel > 0)"
| "reasonable_cards cf f (Join l r) = (let c = card cf f (Join l r) in
    c \<le> card cf f l * card cf f r \<and> c > 0 \<and> reasonable_cards cf f l \<and> reasonable_cards cf f r)"

definition pos_rel_cards :: "'a card \<Rightarrow> 'a joinTree \<Rightarrow> bool" where
  "pos_rel_cards cf t = (\<forall>(_,c)\<in>set (cards_list cf t). c > 0)"

definition pos_list_cards :: "'a card \<Rightarrow> 'a list \<Rightarrow> bool" where
  "pos_list_cards cf xs = (\<forall>x\<in>set xs. cf x > 0)"

text\<open>
  Each node should have a unique identifier.
\<close>
definition distinct_relations :: "'a joinTree \<Rightarrow> bool" where
  "distinct_relations t = distinct (inorder t)"

subsubsection \<open>Functions for Modifications\<close>

fun mirror :: "'a joinTree \<Rightarrow> 'a joinTree" where
  "mirror (Relation rel) = Relation rel"
| "mirror (Join l r) = Join (mirror r) (mirror l)"

fun create_rdeep :: "'a list \<Rightarrow> 'a joinTree" where
  "create_rdeep [] = undefined"
| "create_rdeep [x] = Relation x"
| "create_rdeep (x#xs) = Join (Relation x) (create_rdeep xs)"

fun create_ldeep_rev :: "'a list \<Rightarrow> 'a joinTree" where
  "create_ldeep_rev [] = undefined"
| "create_ldeep_rev [x] = Relation x"
| "create_ldeep_rev (x#xs) = Join (create_ldeep_rev xs) (Relation x)"

definition create_ldeep :: "'a list \<Rightarrow> 'a joinTree" where
  "create_ldeep xs = create_ldeep_rev (rev xs)"

subsubsection \<open>Additional properties\<close>
(** functions that check for certain properties **)

fun left_deep :: "'a joinTree \<Rightarrow> bool" where
  "left_deep (Relation _) = True"
| "left_deep (Join l (Relation _)) = left_deep l"
| "left_deep _ = False"

fun right_deep :: "'a joinTree \<Rightarrow> bool" where
  "right_deep (Relation _) = True"
| "right_deep (Join (Relation _) r) = right_deep r"
| "right_deep _ = False"

fun zig_zag :: "'a joinTree \<Rightarrow> bool" where
  "zig_zag (Relation _) = True"
| "zig_zag (Join l (Relation _)) = zig_zag l"
| "zig_zag (Join (Relation _) r) = zig_zag r"
| "zig_zag _ = False"

subsubsection \<open>Cardinality Calculations for Left-deep Trees\<close>

text \<open>
  Expects a reversed list of relations rs and calculates the cardinality of a left-deep tree.
\<close>

fun ldeep_n :: "'a selectivity \<Rightarrow> 'a card \<Rightarrow> 'a list \<Rightarrow> real" where
  "ldeep_n f cf [] = 1"
| "ldeep_n f cf (r#rs) = cf r * (list_sel_aux' f rs r) * ldeep_n f cf rs"

definition ldeep_T :: "('a \<Rightarrow> real) \<Rightarrow> 'a card \<Rightarrow> 'a list \<Rightarrow> real" where
  "ldeep_T sf cf xs = foldl (\<lambda>a b. a * cf b * sf b) 1 xs"

fun ldeep_T' :: "('a \<Rightarrow> real) \<Rightarrow> 'a card \<Rightarrow> 'a list \<Rightarrow> real" where
  "ldeep_T' f cf [] = 1"
| "ldeep_T' f cf (r#rs) = cf r * f r * ldeep_T' f cf rs"

subsection \<open>Proofs\<close>
(** proofs that properties are maintained **)

lemma ldeep_eq_rdeep: "left_deep t = right_deep (mirror t)"
  by(induction t rule: left_deep.induct) (auto)

lemma mirror_twice_id[simp]: "mirror (mirror t) = t"
  by(induction t) auto

lemma rdeep_eq_ldeep: "right_deep t = left_deep (mirror t)"
  apply(induction t rule: right_deep.induct)
  by(auto)

lemma mirror_zig_zag_preserv: "zig_zag (mirror t) = zig_zag t"
  apply(induction t rule: zig_zag.induct)
  using zig_zag.elims(2) by fastforce+

lemma ldeep_zig_zag: "left_deep t \<Longrightarrow> zig_zag t"
  by(induction t rule: zig_zag.induct) auto

lemma rdeep_zig_zag: "right_deep t \<Longrightarrow> zig_zag t"
  using rdeep_eq_ldeep ldeep_zig_zag mirror_zig_zag_preserv by blast

lemma relations_nempty: "relations t \<noteq> {}"
  by (induction t) auto

lemma set_implies_mset: "x \<in> relations t \<Longrightarrow> x \<in># relations_mset t"
  by(induction t) (auto)

lemma mset_implies_set: "x \<in># relations_mset t \<Longrightarrow> x \<in> relations t"
  by(induction t) (auto)

lemma inorder_eq_mset: "mset (inorder t) = relations_mset t"
  by(induction t) (auto)

lemma relations_set_eq_mset: "set_mset (relations_mset t) = relations t"
  using mset_implies_set set_implies_mset by fast

lemma inorder_eq_set: "set (inorder t) = relations t"
  by(induction t) (auto)

lemma revorder_eq_mset: "mset (revorder t) = relations_mset t"
  by(induction t) (auto)

lemma revorder_eq_set: "set (revorder t) = relations t"
  by(induction t) (auto)

lemma revorder_eq_rev_inorder: "revorder t = rev (inorder t)"
  by(induction t) (auto)

lemma inorder_eq_rev_revorder: "inorder t = rev (revorder t)"
  by(induction t) (auto)

lemma mirror_mset_eq[simp]: "relations_mset (mirror t) = relations_mset t"
  by(induction t) auto

lemma distinct_rels_alt: "distinct_relations t \<longleftrightarrow> distinct (revorder t)"
  unfolding distinct_relations_def inorder_eq_rev_revorder by simp

lemma distinct_rels_alt':
  "distinct_relations t \<longleftrightarrow> (let multi=relations_mset t in \<forall>x\<in># multi. count multi x = 1)"
  using distinct_relations_def inorder_eq_mset distinct_alt by metis

lemma inorder_nempty: "inorder t \<noteq> []"
  by (induction t) auto

lemma revorder_nempty: "revorder t \<noteq> []"
  by (induction t) auto

lemma mirror_distinct: "distinct_relations t \<Longrightarrow> distinct_relations (mirror t)"
  by(simp add: distinct_rels_alt')

lemma mirror_set_eq[simp]: "relations (mirror t) = relations t"
  by(induction t) auto

lemma mirror_inorder_rev: "inorder (mirror t) = rev (inorder t)"
  by(induction t) auto

lemma mirror_revorder_rev: "revorder (mirror t) = rev (revorder t)"
  by(induction t) auto

corollary mirror_revorder_inorder: "revorder (mirror t) = inorder t"
  unfolding mirror_revorder_rev inorder_eq_rev_revorder by simp

corollary mirror_inorder_revorder: "inorder (mirror t) = revorder t"
  unfolding mirror_inorder_rev revorder_eq_rev_inorder by simp

lemma mirror_card_eq[simp]: "sel_symm f \<Longrightarrow> card cf f (mirror t) = card cf f t"
proof(induction t)
  case (Join l r)
  let ?r = "mirror r" and ?l = "mirror l"
  have 0: "mset (inorder ?r) = mset (inorder r)" by (simp add: inorder_eq_mset)
  have 1: "mset (inorder ?l) = mset (inorder l)" by (simp add: inorder_eq_mset)
  have "card cf f (mirror (Join l r)) = card cf f (Join (mirror r) (mirror l))" by simp
  also have "\<dots> = list_sel f (inorder ?r) (inorder ?l) * card cf f r * card cf f l"
    using Join by simp
  also have "\<dots> = list_sel f (inorder r) (inorder ?l) * card cf f r * card cf f l"
    using 0 mset_x_eq_list_sel_eq by auto
  also have "\<dots> = list_sel f (inorder r) (inorder l) * card cf f r * card cf f l"
    using 1 mset_y_eq_list_sel_eq by auto
  finally show ?case using list_sel_symm Join.prems by auto
qed(simp)

lemma mirror_reasonable_cards:
  "\<lbrakk>sel_symm f; reasonable_cards cf f t\<rbrakk> \<Longrightarrow> reasonable_cards cf f (mirror t)"
proof(induction t)
  case (Join l r)
  let ?r = "mirror r" and ?l = "mirror l"
  let ?c = "card cf f (mirror (Join l r))"
  let ?c' = "card cf f (Join l r)"
  have "reasonable_cards cf f (mirror (Join l r))
      = reasonable_cards cf f (Join (mirror r) (mirror l))" by simp
  also have "\<dots> = (?c \<le> card cf f ?r * card cf f ?l \<and> ?c>0
             \<and> reasonable_cards cf f ?l \<and> reasonable_cards cf f ?r)"
    by (auto simp: Let_def)
  also have "\<dots> = (?c \<le> card cf f ?r * card cf f ?l \<and> ?c>0)"
    using Join by fastforce
  also have "\<dots> = (?c' \<le> card cf f r * card cf f l \<and> ?c'>0)"
    using mirror_card_eq Join.prems by metis
  also have "\<dots> = (?c' \<le> card cf f r * card cf f l \<and> ?c'>0
            \<and> reasonable_cards cf f l \<and> reasonable_cards cf f r)"
    using Join.prems by auto
  also have "\<dots> = (?c' \<le> card cf f l * card cf f r \<and> ?c'>0
            \<and> reasonable_cards cf f l \<and> reasonable_cards cf f r)"
    by argo
  finally show ?case using Join.prems by force
qed(simp)

lemma joinTree_cases: "(\<exists>r. t=(Relation r)) \<or> (\<exists>l rr. t=(Join l (Relation rr)))
    \<or> (\<exists>l lr rr. t=(Join l (Join lr rr)))"
  apply(cases t)
   apply(auto)[2]
  by (meson joinTree.exhaust)

lemma joinTree_cases_ldeep: "left_deep t
    \<Longrightarrow> (\<exists>r. t=(Relation r)) \<or> (\<exists>l rr. t=(Join l (Relation rr)))"
  apply(cases t)
   apply(auto)[2]
  using joinTree_cases by fastforce

lemma ldeep_trans: "left_deep (Join l r) \<Longrightarrow> left_deep l"
  by(cases r) auto

lemma subtree_elem_count_l:
  assumes "\<forall>x\<in># (relations_mset (Join l r)). count (relations_mset (Join l r)) x = 1"
      and "x \<in># relations_mset l"
    shows "count (relations_mset l) x = 1"
proof -
  have 0: "count (relations_mset l) x \<ge> 1" using assms by auto
  have "count (relations_mset l) x \<le> 1" using assms by force
  then show ?thesis using 0 by linarith
qed

lemma subtree_elem_count_r:
  assumes "\<forall>x\<in># (relations_mset (Join l r)). count (relations_mset (Join l r)) x = 1"
      and "x \<in># relations_mset r"
    shows "count (relations_mset r) x = 1"
proof -
  have 0: "count (relations_mset r) x \<ge> 1" using assms by auto
  have "count (relations_mset r) x \<le> 1" using assms by force
  then show ?thesis using 0 by linarith
qed

lemma first_node_first_inorder: "\<exists>xs. inorder t = first_node t # xs"
  by(induction t) auto

lemma first_node_last_revorder: "\<exists>xs. revorder t = xs @ [first_node t]"
  by(induction t) auto

lemma first_node_eq_hd: "first_node t = hd (inorder t)"
  using first_node_first_inorder[of t] by auto

lemma distinct_elem_right_not_left:
  assumes "distinct_relations (Join l r)"
      and "x \<in> relations r"
    shows "x \<notin> relations l"
proof
  assume "x \<in> relations l"
  then have "x \<in># relations_mset l" using set_implies_mset by fast
  then have 0: "count (relations_mset l) x \<ge> 1" by simp
  have "x \<in># relations_mset r" using set_implies_mset assms(2) by fast
  then have "count (relations_mset r) x \<ge> 1" by simp
  moreover have "count (relations_mset l + relations_mset r) x
      = count (relations_mset l) x + count (relations_mset r) x" by simp
  ultimately have "count (relations_mset l + relations_mset r) x \<ge> 2" using 0 by linarith
  then have "count (relations_mset (Join l r)) x \<ge> 2" by simp
  then have 1: "count (relations_mset (Join l r)) x \<noteq> 1" by simp
  let ?multi = "(relations_mset (Join l r))"
  have "distinct_relations (Join l r) = (\<forall>y\<in># ?multi. count ?multi y = 1)"
    by (simp add: distinct_rels_alt')
  then show False using 1 assms set_implies_mset by fastforce
qed

lemma distinct_elem_left_not_right:
  assumes "distinct_relations (Join l r)"
      and "x \<in> relations l"
    shows "x \<notin> relations r"
  using distinct_elem_right_not_left assms by fast

lemma distinct_relations_disjoint: "distinct_relations (Join l r) \<Longrightarrow> relations l \<inter> relations r = {}"
  using distinct_elem_right_not_left by fast

lemma distinct_trans_l: "distinct_relations (Join l r) \<Longrightarrow> distinct_relations l"
  using subtree_elem_count_l by (fastforce simp: distinct_rels_alt)

lemma distinct_trans_r: "distinct_relations (Join l r) \<Longrightarrow> distinct_relations r"
  using subtree_elem_count_r by (fastforce simp: distinct_rels_alt)

lemma distinct_and_disjoint_impl_count1:
  assumes "distinct_relations l"
      and "distinct_relations r"
      and "relations l \<inter> relations r = {}"
      and "x \<in># relations_mset (Join l r)"
  shows "count (relations_mset (Join l r)) x = 1"
proof -
  show ?thesis
  proof(cases "x\<in>relations l")
    case True
    then have "x\<in># relations_mset l" using set_implies_mset by fast
    then have 0: "count (relations_mset l) x = 1" using assms(1) distinct_rels_alt' by metis
    have "x\<notin># relations_mset r" using True assms(3) disjoint_iff mset_implies_set by fast
    then have "count (relations_mset r) x = 0" by (simp add: count_eq_zero_iff)
    then show ?thesis using 0 by simp
  next
    case False
    have "x\<in># relations_mset r" using False assms(4) using mset_implies_set by force
    then have 0: "count (relations_mset r) x = 1" using assms(2) distinct_rels_alt' by metis
    have "x\<notin># relations_mset l" using False assms(3) disjoint_iff mset_implies_set by fast
    then have "count (relations_mset l) x = 0" by (simp add: count_eq_zero_iff)
    then show ?thesis using 0 by simp
  qed
qed

lemma distinct_and_disjoint_impl_distinct:
  "\<lbrakk>distinct_relations l; distinct_relations r; relations l \<inter> relations r = {}\<rbrakk>
    \<Longrightarrow> distinct_relations (Join l r)"
  using distinct_and_disjoint_impl_count1 distinct_rels_alt' by fastforce

lemma reasonable_trans:
  "reasonable_cards cf f (Join l r) \<Longrightarrow> reasonable_cards cf f l \<and> reasonable_cards cf f r"
  by (simp add: Let_def)

lemma mirror_height_eq: "height (mirror t) = height t"
  by(induction t) auto

lemma height_0_rel: "height t = 0 \<Longrightarrow> \<exists>r. t = Relation r"
  by(cases t) auto

lemma height_gt_0_join: "height t > 0 \<Longrightarrow> \<exists>l r. t = Join l r"
  by(cases t) auto

lemma height_decr_l: "height (Join l r) > height l"
  by simp

lemma height_decr_r: "height (Join l r) > height r"
  by simp

lemma mirror_num_relations_eq: "num_relations (mirror t) = num_relations t"
  by(induction t) auto

lemma zig_zag_num_relations_height: "zig_zag t \<Longrightarrow> num_relations t = height t + 1"
  by(induction t rule: zig_zag.induct) auto

lemma ldeep_num_relations_height: "left_deep t \<Longrightarrow> num_relations t = height t + 1"
  by (simp add: zig_zag_num_relations_height ldeep_zig_zag)

lemma rdeep_num_relations_height: "right_deep t \<Longrightarrow> num_relations t = height t + 1"
  by (simp add: zig_zag_num_relations_height rdeep_zig_zag)

lemma num_relations_eq_length: "num_relations t = length (inorder t)"
  by(induction t) auto

lemma reasonable_impl_pos: "reasonable_cards cf f t \<Longrightarrow> pos_rel_cards cf t"
  by(induction t) (auto simp: pos_rel_cards_def Let_def)

lemma cards_list_eq_inorder: "map (\<lambda>(a,_). a) (cards_list cf t) = inorder t"
  by(induction t) auto

lemma cards_list_eq_relations: "(\<lambda>(a,_). a) ` set (cards_list cf t) = relations t"
  by (simp add: cards_list_eq_inorder image_set inorder_eq_set)

lemma cards_eq_c: "(rel,c)\<in>set(cards_list cf t) \<Longrightarrow> cf rel = c"
  by(induction t) auto

lemma finite_trans: "finite (relations (Join l r)) \<Longrightarrow> finite (relations l) \<and> finite (relations r)"
  by simp

lemma distinct_impl_card_eq_length:
  "finite (relations t) \<Longrightarrow> height t \<le> n \<Longrightarrow> distinct_relations t
    \<Longrightarrow> Finite_Set.card (relations t) = length (inorder t)"
proof(induction n arbitrary: t)
  case 0
  then obtain r where "Relation r = t" using height_0_rel by auto
  then show ?case using distinct_relations_def by force
next
  case (Suc n)
  then show ?case
  proof(cases "height t = Suc n")
    case True
    then have "0 < height t" by simp
    then obtain l r where join[simp]: "Join l r = t" using height_gt_0_join by blast
    then have 0: "finite (relations l) \<and> finite (relations r)"
      using Suc.prems(1) finite_trans by blast
    have 1: "height l \<le> n" using True join by (metis height_decr_l less_Suc_eq_le)
    have 2: "height r \<le> n" using True join by (metis height_decr_r less_Suc_eq_le)
    have "Finite_Set.card (relations t) + Finite_Set.card (relations l \<inter> relations r)
              = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
      using card_Un_Int join 0 by (metis JoinTree.joinTree.simps(16))
    then have "Finite_Set.card (relations t)
              = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
      by (simp add: local.Suc.prems(3) distinct_relations_disjoint)
    moreover have "length (inorder t)
              = length (inorder l) + length (inorder r)"
      by (metis JoinTree.inorder.simps(2) join length_append)
    moreover have "Finite_Set.card (relations l) = length (inorder l)"
      using Suc.IH Suc.prems(3) distinct_trans_l 0 1 join by blast
    moreover have "Finite_Set.card (relations r) = length (inorder r)"
      using Suc.IH Suc.prems(3) distinct_trans_r 0 2 join by blast
    ultimately show ?thesis by simp
  next
    case False
    then show ?thesis using Suc by simp
  qed
qed

lemma card_le_length: "Finite_Set.card (relations t) \<le> length (inorder t)"
  apply(induction t)
   apply(auto)[2]
  by (meson add_mono card_Un_le le_trans)

lemma card_eq_length_impl_disjunct:
  assumes "finite (relations (Join l r))"
      and "Finite_Set.card (relations (Join l r)) = length (inorder (Join l r))"
    shows "relations l \<inter> relations r = {}"
proof (rule ccontr)
  assume 0: "relations l \<inter> relations r \<noteq> {}"
  have 1: "finite (relations l) \<and> finite (relations r)" using assms(1) by simp
  then have 2: "Finite_Set.card (relations (Join l r)) + Finite_Set.card (relations l \<inter> relations r)
            = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
    using card_Un_Int by (metis JoinTree.joinTree.simps(16))
  moreover have "Finite_Set.card (relations l \<inter> relations r) > 0" using 0 1 by auto
  ultimately have "Finite_Set.card (relations (Join l r))
            < Finite_Set.card (relations l) + Finite_Set.card (relations r)" by simp
  also have "\<dots> \<le> length (inorder l) + Finite_Set.card (relations r)"
    by (simp add: card_le_length)
  also have "\<dots> \<le> length (inorder l) + length (inorder r)"
    by (simp add: card_le_length)
  finally have "Finite_Set.card (relations (Join l r)) < length (inorder (Join l r))"
    by simp
  then show "False" using assms(2) by simp
qed

lemma card_eq_length_trans_l:
  assumes "finite (relations (Join l r))"
      and "Finite_Set.card (relations (Join l r)) = length (inorder (Join l r))"
    shows "Finite_Set.card (relations l) = length (inorder l)"
proof (rule ccontr)
  assume 0: "Finite_Set.card (relations l) \<noteq> length (inorder l)"
  have "Finite_Set.card (relations (Join l r))
      = length (inorder l) + length (inorder r)"
    using assms(2) by simp
  have "finite (relations l) \<and> finite (relations r)" using assms(1) by simp
  then have "Finite_Set.card (relations (Join l r)) + Finite_Set.card (relations l \<inter> relations r)
            = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
    using card_Un_Int by (metis JoinTree.joinTree.simps(16))
  then have "Finite_Set.card (relations (Join l r))
            = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
    using assms by (simp add: card_eq_length_impl_disjunct)
  moreover have "Finite_Set.card (relations l) < length (inorder l)"
    using 0 card_le_length le_imp_less_or_eq by blast
  ultimately have "Finite_Set.card (relations (Join l r))
            < length (inorder l) + Finite_Set.card (relations r)"
    by simp
  also have "\<dots> \<le> length (inorder l) + length (inorder r)"
    by (simp add: card_le_length)
  finally have "Finite_Set.card (relations (Join l r)) < length (inorder (Join l r))"
    by simp
  then show "False" using assms(2) by simp
qed

lemma card_eq_length_trans_r:
  assumes "finite (relations (Join l r))"
      and "Finite_Set.card (relations (Join l r)) = length (inorder (Join l r))"
    shows "Finite_Set.card (relations r) = length (inorder r)"
  using assms card_eq_length_trans_l mirror_set_eq
  by (metis JoinTree.mirror.simps(2) mirror_num_relations_eq num_relations_eq_length)

lemma card_eq_length_impl_distinct:
  "\<lbrakk>finite (relations t); height t \<le> n; Finite_Set.card (relations t) = length (inorder t)\<rbrakk>
    \<Longrightarrow> distinct_relations t"
proof(induction n arbitrary: t)
  case 0
  then obtain r where "Relation r = t" using height_0_rel by auto
  then show ?case using distinct_relations_def by force
next
  case (Suc n)
  then show ?case
  proof(cases "height t = Suc n")
    case True
    then have "0 < height t" by simp
    then obtain l r where join[simp]: "Join l r = t" using height_gt_0_join by blast
    then have 0: "finite (relations l) \<and> finite (relations r)"
      using Suc.prems(1) finite_trans by blast
    have 1: "height l \<le> n" using True join by (metis height_decr_l less_Suc_eq_le)
    have 2: "height r \<le> n" using True join by (metis height_decr_r less_Suc_eq_le)
    have "Finite_Set.card (relations t) + Finite_Set.card (relations l \<inter> relations r)
              = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
      using card_Un_Int join 0 by (metis JoinTree.joinTree.simps(16))
    then have "Finite_Set.card (relations t)
              = Finite_Set.card (relations l) + Finite_Set.card (relations r)"
      using Suc.prems(1,3) by (simp add: card_eq_length_impl_disjunct)

    have "Finite_Set.card (relations l) = length (inorder l)"
      using Suc.prems(1,3) card_eq_length_trans_l join by blast
    then have 3: "distinct_relations l" using Suc.IH 0 1 by blast
    have "Finite_Set.card (relations r) = length (inorder r)"
      using Suc.IH Suc.prems(1,3) card_eq_length_trans_r join by blast
    then have 4: "distinct_relations r" using Suc.IH 0 2 by blast
    have "relations l \<inter> relations r = {}"
      using card_eq_length_impl_disjunct join Suc.prems(1,3) by blast
    then show ?thesis using 3 4 distinct_and_disjoint_impl_distinct by fastforce
  next
    case False
    then show ?thesis using Suc by simp
  qed
qed

lemma list_sel_revorder_eq_inorder_x: "list_sel f (revorder l) ys = list_sel f (inorder l) ys"
  unfolding revorder_eq_rev_inorder using mset_x_eq_list_sel_eq mset_rev by blast

lemma list_sel_revorder_eq_inorder_y: "list_sel f xs (revorder r) = list_sel f xs (inorder r)"
  unfolding revorder_eq_rev_inorder using mset_y_eq_list_sel_eq mset_rev by blast

lemma list_sel_revorder_eq_inorder:
  "list_sel f (revorder l) (revorder r) = list_sel f (inorder l) (inorder r)"
  unfolding list_sel_revorder_eq_inorder_x list_sel_revorder_eq_inorder_y by simp

lemma card_join_alt:
  "card cf f (Join l r) = list_sel f (revorder l) (revorder r) * card cf f l * card cf f r"
  unfolding list_sel_revorder_eq_inorder by simp

lemma distinct_alt:
  "finite (relations t)
    \<Longrightarrow> distinct_relations t \<longleftrightarrow> Finite_Set.card (relations t) = length (inorder t)"
  using card_eq_length_impl_distinct distinct_impl_card_eq_length by auto

lemma distinct_alt2:
  "distinct_relations (Join l r)
    \<longleftrightarrow> distinct_relations l \<and> distinct_relations r \<and> relations l \<inter> relations r = {}"
  using distinct_relations_disjoint distinct_trans_l distinct_trans_r
  by (auto elim: distinct_and_disjoint_impl_distinct)

lemma pos_rel_cards_subtrees:
  "pos_rel_cards cf (Join l r) = (pos_rel_cards cf l \<and> pos_rel_cards cf r)"
proof -
  have "pos_rel_cards cf (Join l r) = (\<forall>(_,c)\<in>set (cards_list cf (Join l r)). c>0)"
    by (simp add: pos_rel_cards_def)
  also have "\<dots> = (\<forall>(_,c)\<in>set (cards_list cf l @ cards_list cf r). c>0)" by simp
  also have "\<dots> = ((\<forall>(_,c)\<in>set (cards_list cf l). c>0) \<and> (\<forall>(_,c)\<in>set (cards_list cf r). c>0))"
    by auto
  also have "\<dots> = (pos_rel_cards cf l \<and> pos_rel_cards cf r)"
    by (simp add: pos_rel_cards_def)
  finally show ?thesis by simp
qed

lemma pos_rel_cards_eq_pos_list_cards:
  "pos_rel_cards cf t \<longleftrightarrow> pos_list_cards cf (inorder t)"
  by(induction t) (auto simp: pos_rel_cards_def pos_list_cards_def)

lemma pos_list_cards_split:
  "pos_list_cards cf (xs@ys) \<longleftrightarrow> pos_list_cards cf xs \<and> pos_list_cards cf ys"
  by(induction xs) (auto simp: pos_list_cards_def)

lemma pos_sel_reason_impl_reason:
  "\<lbrakk>pos_rel_cards cf t; sel_reasonable sel\<rbrakk> \<Longrightarrow> reasonable_cards cf sel t"
proof(induction t)
  case (Join l r)
  then have "pos_rel_cards cf l \<and> pos_rel_cards cf r" using pos_rel_cards_subtrees by blast
  then have 0: "reasonable_cards cf sel l \<and> reasonable_cards cf sel r" using Join by simp
  have "list_sel sel (inorder l) (inorder r) \<le> 1"
    using Join.prems(2) sel_reasonable_def list_sel_reasonable by fast
  obtain c where 1:
    "list_sel sel (inorder l) (inorder r) * card cf sel l * card cf sel r = c"
    by simp
  then have "c = list_sel sel (inorder l) (inorder r) * card cf sel l * card cf sel r"
    by simp
  then have 2: "c \<le> 1 * card cf sel l * card cf sel r"
    using Join.prems(2) list_sel_reasonable 0 mult_left_le_one_le mult_right_less_imp_less
    by (smt (verit, ccfv_SIG) card.simps(1) card.simps(2) reasonable_cards.elims(2))
  from 1 have "c > 0 * card cf sel l * card cf sel r"
    using Join.prems(2) list_sel_reasonable 0 mult_pos_pos
    by (metis card.simps(1) card.simps(2) mult_eq_0_iff reasonable_cards.elims(2))
  then show ?case using 0 1 2 by simp
qed(simp add: pos_rel_cards_def)

lemma create_rdeep_order: "xs \<noteq> [] \<Longrightarrow> inorder (create_rdeep xs) = xs"
proof(induction xs)
  case (Cons x xs)
  then show ?case by(cases xs) auto
qed(simp)

lemma create_ldeep_rev_order: "xs \<noteq> [] \<Longrightarrow> inorder (create_ldeep_rev xs) = rev xs"
proof(induction xs)
  case (Cons x xs)
  then show ?case by(cases xs) auto
qed(simp)

lemma create_ldeep_order: "xs \<noteq> [] \<Longrightarrow> inorder (create_ldeep xs) = xs"
  by (simp add: create_ldeep_def create_ldeep_rev_order)

lemma create_rdeep_rdeep: "xs \<noteq> [] \<Longrightarrow> right_deep (create_rdeep xs)"
proof(induction xs)
  case (Cons x xs)
  then show ?case by(cases xs) auto
qed(simp)

lemma create_ldeep_rev_ldeep: "xs \<noteq> [] \<Longrightarrow> left_deep (create_ldeep_rev xs)"
proof(induction xs)
  case (Cons x xs)
  then show ?case by(cases xs) auto
qed(simp)

lemma create_ldeep_ldeep: "xs \<noteq> [] \<Longrightarrow> left_deep (create_ldeep xs)"
  by (simp add: create_ldeep_rev_ldeep create_ldeep_def)

lemma create_ldeep_rev_relations: "xs \<noteq> [] \<Longrightarrow> relations (create_ldeep_rev xs) = set xs"
  using create_ldeep_rev_order[of xs] inorder_eq_set by force

lemma create_ldeep_relations: "xs \<noteq> [] \<Longrightarrow> relations (create_ldeep xs) = set xs"
  by (simp add: create_ldeep_rev_relations create_ldeep_def)

lemma create_ldeep_rev_Cons:
  "xs \<noteq> [] \<Longrightarrow> create_ldeep_rev (x#xs) = Join (create_ldeep_rev xs) (Relation x)"
  using create_ldeep_rev.simps(3) neq_Nil_conv by metis

lemma create_ldeep_snoc: "xs \<noteq> [] \<Longrightarrow> create_ldeep (xs@[x]) = Join (create_ldeep xs) (Relation x)"
  by (simp add: create_ldeep_rev_Cons create_ldeep_def)

lemma create_ldeep_inorder[simp]: "left_deep t \<Longrightarrow> create_ldeep (inorder t) = t"
  apply(induction t)
   apply (simp add: create_ldeep_def)
  by (metis Nil_is_append_conv create_ldeep_snoc inorder.simps
      ldeep_trans left_deep.simps(3) not_Cons_self2 relations_mset.cases)

lemma create_rdeep_inorder[simp]: "right_deep t \<Longrightarrow> create_rdeep (inorder t) = t"
  apply(induction t)
   apply simp
  by (metis create_rdeep.simps(3) create_rdeep_order first_node_first_inorder
      joinTree.distinct(1) joinTree.inject(2) neq_Nil_conv right_deep.elims(2))

lemma ldeep_div_eq_sel:
  assumes "reasonable_cards cf f (Join l (Relation rel))"
      and "c = card cf f (Join l (Relation rel))"
      and "cr = card cf f (Relation rel)"
    shows "c / (card cf f l * cr) = list_sel f (inorder l) [rel]"
  using assms by auto

lemma ldeep_n_eq_card:
  "\<lbrakk>distinct_relations t; left_deep t\<rbrakk> \<Longrightarrow> ldeep_n f cf (revorder t) = card cf f t"
proof(induction t arbitrary: cf rule: left_deep.induct)
  case (2 l rr)
  let ?rev = "revorder (Join l (Relation rr))"
  have "?rev = rr # revorder l" by simp
  have "ldeep_n f cf ?rev = ldeep_n f cf (rr#revorder l)" by simp
  also have "\<dots> = list_sel_aux' f (revorder l) rr
      * cf rr * ldeep_n f cf (revorder l)" by simp
  also have "\<dots> = list_sel_aux' f (inorder l) rr * cf rr
              * ldeep_n f cf (revorder l)"
    using mset_x_eq_list_sel_aux'_eq mset_rev by (fastforce simp: revorder_eq_rev_inorder)
  also have "\<dots> = list_sel_aux' f (inorder l) rr * cf rr * card cf f l"
    using 2 distinct_trans_l by auto
  finally show ?case
    using list_sel_sing_aux' card.simps mult.commute
    by (metis ab_semigroup_mult_class.mult_ac(1) inorder.simps(1))
qed(auto)

lemma ldeep_n_eq_card_subtree:
  "\<lbrakk>distinct_relations (Join t r'); left_deep t\<rbrakk> \<Longrightarrow> ldeep_n f cf (revorder t) = card cf f t"
  using ldeep_n_eq_card distinct_trans_l by blast

lemma distinct_ldeep_T'_prepend:
  "distinct (ys@xs) \<Longrightarrow> ldeep_T' (ldeep_s f (ys@xs)) cf xs = ldeep_T' (ldeep_s f xs) cf xs"
proof(induction xs arbitrary: ys)
  case (Cons x xs)
  then have 0: "distinct (x#xs)" by simp
  have "ldeep_T' (ldeep_s f (ys@x#xs)) cf (x#xs)
           = cf x * (ldeep_s f (ys@x#xs)) x * ldeep_T' (ldeep_s f (ys@x#xs)) cf xs" by simp
  also have "\<dots> = cf x * (ldeep_s f (ys@x#xs)) x * ldeep_T' (ldeep_s f xs) cf xs"
    using Cons.IH[of "ys@[x]"] Cons.prems by simp
  also have "\<dots> = cf x * list_sel_aux' f xs x * ldeep_T' (ldeep_s f xs) cf xs"
    using distinct_ldeep_s_eq_aux[OF Cons.prems] by simp
  also have "\<dots> = cf x * (ldeep_s f (x#xs)) x * ldeep_T' (ldeep_s f xs) cf xs"
    using distinct_ldeep_s_eq_aux Cons.prems by simp
  also have "\<dots> = cf x * (ldeep_s f (x#xs)) x * ldeep_T' (ldeep_s f (x#xs)) cf xs"
    using Cons.IH[of "[x]"] 0 by simp
  finally show ?case by simp
qed(simp)

lemma ldeep_T'_eq_ldeep_n: "distinct xs \<Longrightarrow> ldeep_T' (ldeep_s f xs) cf xs = ldeep_n f cf xs"
proof(induction xs)
  case (Cons x xs)
  then have 0: "distinct xs" by simp
  have "ldeep_T' (ldeep_s f (x # xs)) cf (x # xs)
           = cf x * (ldeep_s f (x # xs)) x * ldeep_T' (ldeep_s f (x # xs)) cf xs" by simp
  also have "\<dots> = cf x * list_sel_aux' f xs x * ldeep_T' (ldeep_s f (x # xs)) cf xs" by simp
  also have "\<dots> = cf x * list_sel_aux' f xs x * ldeep_T' (ldeep_s f xs) cf xs"
    using distinct_ldeep_T'_prepend[of "[x]"] Cons.prems by simp
  also have "\<dots> = cf x * list_sel_aux' f xs x * ldeep_n f cf xs"
    using Cons.IH 0 by simp
  finally show ?case by simp
qed(simp)

lemma ldeep_T'_eq_foldl: "acc * ldeep_T' f cf xs = foldl (\<lambda>a b. a * cf b * f b) acc xs"
proof(induction xs arbitrary: acc)
  case (Cons x xs)
  have "acc * ldeep_T' f cf (x # xs) = acc * cf x * f x * ldeep_T' f cf xs" by simp
  also have "\<dots> = foldl (\<lambda>a b. a * cf b * f b) (acc * cf x * f x) xs" using Cons by simp
  finally show ?case by simp
qed(simp)

lemma distinct_ldeep_T_prepend:
  "distinct (ys@xs) \<Longrightarrow> ldeep_T (ldeep_s f (ys@xs)) cf xs = ldeep_T (ldeep_s f xs) cf xs"
  using ldeep_T'_eq_foldl[of 1 "ldeep_s f (ys@xs)" cf xs]
  by (simp add: distinct_ldeep_T'_prepend ldeep_T_def ldeep_T'_eq_foldl)

lemma ldeep_T_eq_ldeep_T'_aux: "ldeep_T sf cf xs = ldeep_T' sf cf xs"
  using ldeep_T'_eq_foldl[of 1 sf] ldeep_T_def by fastforce

lemma ldeep_T_eq_ldeep_T': "ldeep_T = ldeep_T'"
  using ldeep_T_eq_ldeep_T'_aux by blast

lemma ldeep_T_eq_ldeep_n: "distinct xs \<Longrightarrow> ldeep_T (ldeep_s f xs) cf xs = ldeep_n f cf xs"
  by (simp add: ldeep_T_eq_ldeep_T' ldeep_T'_eq_ldeep_n)

lemma ldeep_T_app: "ldeep_T f cf (xs@ys) = ldeep_T f cf xs * ldeep_T f cf ys"
  using ldeep_T_def foldl_append ldeep_T'_eq_foldl
  by (metis (mono_tags, lifting) monoid.left_neutral mult.monoid_axioms)

lemma ldeep_T_empty: "ldeep_T f cf [] = 1"
  by (simp add: ldeep_T_def)

lemma ldeep_T_eq_if_cf_eq: "\<forall>x \<in> set xs. f x = g x \<Longrightarrow> ldeep_T sf f xs = ldeep_T sf g xs"
  unfolding ldeep_T_eq_ldeep_T' by (induction xs) auto

lemma ldeep_n_pos: "\<lbrakk>pos_list_cards cf xs; sel_reasonable f\<rbrakk> \<Longrightarrow> ldeep_n f cf xs > 0"
proof(induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case
    using list_sel_aux'_reasonable pos_list_cards_def mult_pos_pos set_subset_Cons
    by (metis list.set_intros(1) ldeep_n.simps(2) subset_code(1))
qed

lemma ldeep_T_eq_card:
  "\<lbrakk>distinct_relations t; left_deep t\<rbrakk>
    \<Longrightarrow> ldeep_T (ldeep_s f (revorder t)) cf (revorder t) = card cf f t"
  using ldeep_T_eq_ldeep_n[of "revorder t"] ldeep_n_eq_card distinct_rels_alt by fastforce

lemma ldeep_T_pos':
  "\<lbrakk>distinct xs; pos_list_cards cf xs; sel_reasonable f\<rbrakk> \<Longrightarrow> ldeep_T (ldeep_s f xs) cf xs > 0"
  by (simp add: ldeep_T_eq_ldeep_n ldeep_n_pos)

lemma ldeep_T_pos: "\<lbrakk>\<forall>x\<in> set ys. cf x > 0; sel_reasonable f\<rbrakk> \<Longrightarrow> ldeep_T (ldeep_s f xs) cf ys > 0"
  apply(induction ys arbitrary: xs)
   apply(auto simp: ldeep_T_def)[2]
  by (metis Groups.comm_monoid_mult_class.mult_1 ldeep_T'_eq_foldl ldeep_s_pos zero_less_mult_iff)

end


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

Standard notation for Vset(i) is V(i), but users might want V for a
variable.

NOTE: univ(A) could be a translation; would simplify many proofs!
  But Ind_Syntax.univ refers to the constant "Univ.univ"
*)

section\<open>The Cumulative Hierarchy and a Small Universe for Recursive Types\<close>

theory Univ imports Epsilon Cardinal begin

definition
  Vfrom       :: "[i,i]\<Rightarrow>i"  where
    "Vfrom(A,i) \<equiv> transrec(i, \<lambda>x f. A \<union> (\<Union>y\<in>x. Pow(f`y)))"

abbreviation
  Vset :: "i\<Rightarrow>i" where
  "Vset(x) \<equiv> Vfrom(0,x)"

definition
  Vrec        :: "[i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
    "Vrec(a,H) \<equiv> transrec(rank(a), \<lambda>x g. \<lambda>z\<in>Vset(succ(x)).
                           H(z, \<lambda>w\<in>Vset(x). g`rank(w)`w)) ` a"

definition
  Vrecursor   :: "[[i,i]\<Rightarrow>i, i] \<Rightarrow>i"  where
    "Vrecursor(H,a) \<equiv> transrec(rank(a), \<lambda>x g. \<lambda>z\<in>Vset(succ(x)).
                                H(\<lambda>w\<in>Vset(x). g`rank(w)`w, z)) ` a"

definition
  univ        :: "i\<Rightarrow>i"  where
    "univ(A) \<equiv> Vfrom(A,nat)"

subsection\<open>Immediate Consequences of the Definition of \<^term>\<open>Vfrom(A,i)\<close>\<close>

text\<open>NOT SUITABLE FOR REWRITING -- RECURSIVE!\<close>
lemma Vfrom: "Vfrom(A,i) = A \<union> (\<Union>j\<in>i. Pow(Vfrom(A,j)))"
by (subst Vfrom_def [THEN def_transrec], simp)

subsubsection\<open>Monotonicity\<close>

lemma Vfrom_mono [rule_format]:
     "A<=B \<Longrightarrow> \<forall>j. i<=j \<longrightarrow> Vfrom(A,i) \<subseteq> Vfrom(B,j)"
apply (rule_tac a=i in eps_induct)
apply (rule impI [THEN allI])
apply (subst Vfrom [of A])
apply (subst Vfrom [of B])
apply (erule Un_mono)
apply (erule UN_mono, blast)
done

lemma VfromI: "\<lbrakk>a \<in> Vfrom(A,j);  j<i\<rbrakk> \<Longrightarrow> a \<in> Vfrom(A,i)"
by (blast dest: Vfrom_mono [OF subset_refl le_imp_subset [OF leI]])

subsubsection\<open>A fundamental equality: Vfrom does not require ordinals!\<close>

lemma Vfrom_rank_subset1: "Vfrom(A,x) \<subseteq> Vfrom(A,rank(x))"
proof (induct x rule: eps_induct)
  fix x
  assume "\<forall>y\<in>x. Vfrom(A,y) \<subseteq> Vfrom(A,rank(y))"
  thus "Vfrom(A, x) \<subseteq> Vfrom(A, rank(x))"
    by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"],
        blast intro!: rank_lt [THEN ltD])
qed

lemma Vfrom_rank_subset2: "Vfrom(A,rank(x)) \<subseteq> Vfrom(A,x)"
apply (rule_tac a=x in eps_induct)
apply (subst Vfrom)
apply (subst Vfrom, rule subset_refl [THEN Un_mono])
apply (rule UN_least)
txt\<open>expand \<open>rank(x1) = (\<Union>y\<in>x1. succ(rank(y)))\<close> in assumptions\<close>
apply (erule rank [THEN equalityD1, THEN subsetD, THEN UN_E])
apply (rule subset_trans)
apply (erule_tac [2] UN_upper)
apply (rule subset_refl [THEN Vfrom_mono, THEN subset_trans, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (rule Ord_rank [THEN Ord_succ])
apply (erule bspec, assumption)
done

lemma Vfrom_rank_eq: "Vfrom(A,rank(x)) = Vfrom(A,x)"
apply (rule equalityI)
apply (rule Vfrom_rank_subset2)
apply (rule Vfrom_rank_subset1)
done

subsection\<open>Basic Closure Properties\<close>

lemma zero_in_Vfrom: "y:x \<Longrightarrow> 0 \<in> Vfrom(A,x)"
by (subst Vfrom, blast)

lemma i_subset_Vfrom: "i \<subseteq> Vfrom(A,i)"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom, blast)
done

lemma A_subset_Vfrom: "A \<subseteq> Vfrom(A,i)"
apply (subst Vfrom)
apply (rule Un_upper1)
done

lemmas A_into_Vfrom = A_subset_Vfrom [THEN subsetD]

lemma subset_mem_Vfrom: "a \<subseteq> Vfrom(A,i) \<Longrightarrow> a \<in> Vfrom(A,succ(i))"
by (subst Vfrom, blast)

subsubsection\<open>Finite sets and ordered pairs\<close>

lemma singleton_in_Vfrom: "a \<in> Vfrom(A,i) \<Longrightarrow> {a} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma doubleton_in_Vfrom:
     "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i)\<rbrakk> \<Longrightarrow> {a,b} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma Pair_in_Vfrom:
    "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> Vfrom(A,succ(succ(i)))"
  unfolding Pair_def
apply (blast intro: doubleton_in_Vfrom)
done

lemma succ_in_Vfrom: "a \<subseteq> Vfrom(A,i) \<Longrightarrow> succ(a) \<in> Vfrom(A,succ(succ(i)))"
apply (intro subset_mem_Vfrom succ_subsetI, assumption)
apply (erule subset_trans)
apply (rule Vfrom_mono [OF subset_refl subset_succI])
done

subsection\<open>0, Successor and Limit Equations for \<^term>\<open>Vfrom\<close>\<close>

lemma Vfrom_0: "Vfrom(A,0) = A"
by (subst Vfrom, blast)

lemma Vfrom_succ_lemma: "Ord(i) \<Longrightarrow> Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule Vfrom [THEN trans])
apply (rule equalityI [THEN subst_context,
                       OF _ succI1 [THEN RepFunI, THEN Union_upper]])
apply (rule UN_least)
apply (rule subset_refl [THEN Vfrom_mono, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (erule Ord_succ)
done

lemma Vfrom_succ: "Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule_tac x1 = "succ (i)" in Vfrom_rank_eq [THEN subst])
apply (rule_tac x1 = i in Vfrom_rank_eq [THEN subst])
apply (subst rank_succ)
apply (rule Ord_rank [THEN Vfrom_succ_lemma])
done

(*The premise distinguishes this from Vfrom(A,0);  allowing X=0 forces
  the conclusion to be Vfrom(A,\<Union>(X)) = A \<union> (\<Union>y\<in>X. Vfrom(A,y)) *)
lemma Vfrom_Union: "y:X \<Longrightarrow> Vfrom(A,\<Union>(X)) = (\<Union>y\<in>X. Vfrom(A,y))"
apply (subst Vfrom)
apply (rule equalityI)
txt\<open>first inclusion\<close>
apply (rule Un_least)
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (rule UN_upper, assumption)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] UN_upper,
       subst Vfrom, erule subset_trans [OF UN_upper Un_upper2])
txt\<open>opposite inclusion\<close>
apply (rule UN_least)
apply (subst Vfrom, blast)
done

subsection\<open>\<^term>\<open>Vfrom\<close> applied to Limit Ordinals\<close>

(*NB. limit ordinals are non-empty:
      Vfrom(A,0) = A = A \<union> (\<Union>y\<in>0. Vfrom(A,y)) *)
lemma Limit_Vfrom_eq:
    "Limit(i) \<Longrightarrow> Vfrom(A,i) = (\<Union>y\<in>i. Vfrom(A,y))"
apply (rule Limit_has_0 [THEN ltD, THEN Vfrom_Union, THEN subst], assumption)
apply (simp add: Limit_Union_eq)
done

lemma Limit_VfromE:
    "\<lbrakk>a \<in> Vfrom(A,i);  \<not>R \<Longrightarrow> Limit(i);
        \<And>x. \<lbrakk>x<i;  a \<in> Vfrom(A,x)\<rbrakk> \<Longrightarrow> R
\<rbrakk> \<Longrightarrow> R"
apply (rule classical)
apply (rule Limit_Vfrom_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI Limit_is_Ord)
done

lemma singleton_in_VLimit:
    "\<lbrakk>a \<in> Vfrom(A,i);  Limit(i)\<rbrakk> \<Longrightarrow> {a} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule singleton_in_Vfrom [THEN VfromI])
apply (blast intro: Limit_has_succ)
done

lemmas Vfrom_UnI1 =
    Un_upper1 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]
lemmas Vfrom_UnI2 =
    Un_upper2 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]

text\<open>Hard work is finding a single j:i such that {a,b}<=Vfrom(A,j)\<close>
lemma doubleton_in_VLimit:
    "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i)\<rbrakk> \<Longrightarrow> {a,b} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
apply (blast intro:  VfromI [OF doubleton_in_Vfrom]
                     Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma Pair_in_VLimit:
    "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> Vfrom(A,i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
txt\<open>Infer that \<^term>\<open>succ(succ(x \<union> xa)) < i\<close>\<close>
apply (blast intro: VfromI [OF Pair_in_Vfrom]
                    Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma product_VLimit: "Limit(i) \<Longrightarrow> Vfrom(A,i) * Vfrom(A,i) \<subseteq> Vfrom(A,i)"
by (blast intro: Pair_in_VLimit)

lemmas Sigma_subset_VLimit =
     subset_trans [OF Sigma_mono product_VLimit]

lemmas nat_subset_VLimit =
     subset_trans [OF nat_le_Limit [THEN le_imp_subset] i_subset_Vfrom]

lemma nat_into_VLimit: "\<lbrakk>n: nat;  Limit(i)\<rbrakk> \<Longrightarrow> n \<in> Vfrom(A,i)"
by (blast intro: nat_subset_VLimit [THEN subsetD])

subsubsection\<open>Closure under Disjoint Union\<close>

lemmas zero_in_VLimit = Limit_has_0 [THEN ltD, THEN zero_in_Vfrom]

lemma one_in_VLimit: "Limit(i) \<Longrightarrow> 1 \<in> Vfrom(A,i)"
by (blast intro: nat_into_VLimit)

lemma Inl_in_VLimit:
    "\<lbrakk>a \<in> Vfrom(A,i); Limit(i)\<rbrakk> \<Longrightarrow> Inl(a) \<in> Vfrom(A,i)"
  unfolding Inl_def
apply (blast intro: zero_in_VLimit Pair_in_VLimit)
done

lemma Inr_in_VLimit:
    "\<lbrakk>b \<in> Vfrom(A,i); Limit(i)\<rbrakk> \<Longrightarrow> Inr(b) \<in> Vfrom(A,i)"
  unfolding Inr_def
apply (blast intro: one_in_VLimit Pair_in_VLimit)
done

lemma sum_VLimit: "Limit(i) \<Longrightarrow> Vfrom(C,i)+Vfrom(C,i) \<subseteq> Vfrom(C,i)"
by (blast intro!: Inl_in_VLimit Inr_in_VLimit)

lemmas sum_subset_VLimit = subset_trans [OF sum_mono sum_VLimit]

subsection\<open>Properties assuming \<^term>\<open>Transset(A)\<close>\<close>

lemma Transset_Vfrom: "Transset(A) \<Longrightarrow> Transset(Vfrom(A,i))"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom)
apply (blast intro!: Transset_Union_family Transset_Un Transset_Pow)
done

lemma Transset_Vfrom_succ:
     "Transset(A) \<Longrightarrow> Vfrom(A, succ(i)) = Pow(Vfrom(A,i))"
apply (rule Vfrom_succ [THEN trans])
apply (rule equalityI [OF _ Un_upper2])
apply (rule Un_least [OF _ subset_refl])
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (erule Transset_Vfrom [THEN Transset_iff_Pow [THEN iffD1]])
done

lemma Transset_Pair_subset: "\<lbrakk>\<langle>a,b\<rangle> \<subseteq> C; Transset(C)\<rbrakk> \<Longrightarrow> a: C \<and> b: C"
by (unfold Pair_def Transset_def, blast)

lemma Transset_Pair_subset_VLimit:
     "\<lbrakk>\<langle>a,b\<rangle> \<subseteq> Vfrom(A,i);  Transset(A);  Limit(i)\<rbrakk>
      \<Longrightarrow> \<langle>a,b\<rangle> \<in> Vfrom(A,i)"
apply (erule Transset_Pair_subset [THEN conjE])
apply (erule Transset_Vfrom)
apply (blast intro: Pair_in_VLimit)
done

lemma Union_in_Vfrom:
     "\<lbrakk>X \<in> Vfrom(A,j);  Transset(A)\<rbrakk> \<Longrightarrow> \<Union>(X) \<in> Vfrom(A, succ(j))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def, blast)
done

lemma Union_in_VLimit:
     "\<lbrakk>X \<in> Vfrom(A,i);  Limit(i);  Transset(A)\<rbrakk> \<Longrightarrow> \<Union>(X) \<in> Vfrom(A,i)"
apply (rule Limit_VfromE, assumption+)
apply (blast intro: Limit_has_succ VfromI Union_in_Vfrom)
done

(*** Closure under product/sum applied to elements -- thus Vfrom(A,i)
     is a model of simple type theory provided A is a transitive set
     and i is a limit ordinal
***)

text\<open>General theorem for membership in Vfrom(A,i) when i is a limit ordinal\<close>
lemma in_VLimit:
  "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);
      \<And>x y j. \<lbrakk>j<i; 1:j; x \<in> Vfrom(A,j); y \<in> Vfrom(A,j)\<rbrakk>
               \<Longrightarrow> \<exists>k. h(x,y) \<in> Vfrom(A,k) \<and> k<i\<rbrakk>
   \<Longrightarrow> h(a,b) \<in> Vfrom(A,i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption, atomize)
apply (drule_tac x=a in spec)
apply (drule_tac x=b in spec)
apply (drule_tac x="x \<union> xa \<union> 2" in spec)
apply (simp add: Un_least_lt_iff lt_Ord Vfrom_UnI1 Vfrom_UnI2)
apply (blast intro: Limit_has_0 Limit_has_succ VfromI)
done

subsubsection\<open>Products\<close>

lemma prod_in_Vfrom:
    "\<lbrakk>a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A)\<rbrakk>
     \<Longrightarrow> a*b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
  unfolding Transset_def
apply (blast intro: Pair_in_Vfrom)
done

lemma prod_in_VLimit:
  "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A)\<rbrakk>
   \<Longrightarrow> a*b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: prod_in_Vfrom Limit_has_succ)
done

subsubsection\<open>Disjoint Sums, or Quine Ordered Pairs\<close>

lemma sum_in_Vfrom:
    "\<lbrakk>a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A);  1:j\<rbrakk>
     \<Longrightarrow> a+b \<in> Vfrom(A, succ(succ(succ(j))))"
  unfolding sum_def
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
  unfolding Transset_def
apply (blast intro: zero_in_Vfrom Pair_in_Vfrom i_subset_Vfrom [THEN subsetD])
done

lemma sum_in_VLimit:
  "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A)\<rbrakk>
   \<Longrightarrow> a+b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: sum_in_Vfrom Limit_has_succ)
done

subsubsection\<open>Function Space!\<close>

lemma fun_in_Vfrom:
    "\<lbrakk>a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A)\<rbrakk> \<Longrightarrow>
          a->b \<in> Vfrom(A, succ(succ(succ(succ(j)))))"
  unfolding Pi_def
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (rule Collect_subset [THEN subset_trans])
apply (subst Vfrom)
apply (rule subset_trans [THEN subset_trans])
apply (rule_tac [3] Un_upper2)
apply (rule_tac [2] succI1 [THEN UN_upper])
apply (rule Pow_mono)
  unfolding Transset_def
apply (blast intro: Pair_in_Vfrom)
done

lemma fun_in_VLimit:
  "\<lbrakk>a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A)\<rbrakk>
   \<Longrightarrow> a->b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: fun_in_Vfrom Limit_has_succ)
done

lemma Pow_in_Vfrom:
    "\<lbrakk>a \<in> Vfrom(A,j);  Transset(A)\<rbrakk> \<Longrightarrow> Pow(a) \<in> Vfrom(A, succ(succ(j)))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
  unfolding Transset_def
apply (subst Vfrom, blast)
done

lemma Pow_in_VLimit:
     "\<lbrakk>a \<in> Vfrom(A,i);  Limit(i);  Transset(A)\<rbrakk> \<Longrightarrow> Pow(a) \<in> Vfrom(A,i)"
by (blast elim: Limit_VfromE intro: Limit_has_succ Pow_in_Vfrom VfromI)

subsection\<open>The Set \<^term>\<open>Vset(i)\<close>\<close>

lemma Vset: "Vset(i) = (\<Union>j\<in>i. Pow(Vset(j)))"
by (subst Vfrom, blast)

lemmas Vset_succ = Transset_0 [THEN Transset_Vfrom_succ]
lemmas Transset_Vset = Transset_0 [THEN Transset_Vfrom]

subsubsection\<open>Characterisation of the elements of \<^term>\<open>Vset(i)\<close>\<close>

lemma VsetD [rule_format]: "Ord(i) \<Longrightarrow> \<forall>b. b \<in> Vset(i) \<longrightarrow> rank(b) < i"
apply (erule trans_induct)
apply (subst Vset, safe)
apply (subst rank)
apply (blast intro: ltI UN_succ_least_lt)
done

lemma VsetI_lemma [rule_format]:
     "Ord(i) \<Longrightarrow> \<forall>b. rank(b) \<in> i \<longrightarrow> b \<in> Vset(i)"
apply (erule trans_induct)
apply (rule allI)
apply (subst Vset)
apply (blast intro!: rank_lt [THEN ltD])
done

lemma VsetI: "rank(x)<i \<Longrightarrow> x \<in> Vset(i)"
by (blast intro: VsetI_lemma elim: ltE)

text\<open>Merely a lemma for the next result\<close>
lemma Vset_Ord_rank_iff: "Ord(i) \<Longrightarrow> b \<in> Vset(i) \<longleftrightarrow> rank(b) < i"
by (blast intro: VsetD VsetI)

lemma Vset_rank_iff [simp]: "b \<in> Vset(a) \<longleftrightarrow> rank(b) < rank(a)"
apply (rule Vfrom_rank_eq [THEN subst])
apply (rule Ord_rank [THEN Vset_Ord_rank_iff])
done

text\<open>This is rank(rank(a)) = rank(a)\<close>
declare Ord_rank [THEN rank_of_Ord, simp]

lemma rank_Vset: "Ord(i) \<Longrightarrow> rank(Vset(i)) = i"
apply (subst rank)
apply (rule equalityI, safe)
apply (blast intro: VsetD [THEN ltD])
apply (blast intro: VsetD [THEN ltD] Ord_trans)
apply (blast intro: i_subset_Vfrom [THEN subsetD]
                    Ord_in_Ord [THEN rank_of_Ord, THEN ssubst])
done

lemma Finite_Vset: "i \<in> nat \<Longrightarrow> Finite(Vset(i))"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Vset_succ)
done

subsubsection\<open>Reasoning about Sets in Terms of Their Elements' Ranks\<close>

lemma arg_subset_Vset_rank: "a \<subseteq> Vset(rank(a))"
apply (rule subsetI)
apply (erule rank_lt [THEN VsetI])
done

lemma Int_Vset_subset:
    "\<lbrakk>\<And>i. Ord(i) \<Longrightarrow> a \<inter> Vset(i) \<subseteq> b\<rbrakk> \<Longrightarrow> a \<subseteq> b"
apply (rule subset_trans)
apply (rule Int_greatest [OF subset_refl arg_subset_Vset_rank])
apply (blast intro: Ord_rank)
done

subsubsection\<open>Set Up an Environment for Simplification\<close>

lemma rank_Inl: "rank(a) < rank(Inl(a))"
  unfolding Inl_def
apply (rule rank_pair2)
done

lemma rank_Inr: "rank(a) < rank(Inr(a))"
  unfolding Inr_def
apply (rule rank_pair2)
done

lemmas rank_rls = rank_Inl rank_Inr rank_pair1 rank_pair2

subsubsection\<open>Recursion over Vset Levels!\<close>

text\<open>NOT SUITABLE FOR REWRITING: recursive!\<close>
lemma Vrec: "Vrec(a,H) = H(a, \<lambda>x\<in>Vset(rank(a)). Vrec(x,H))"
  unfolding Vrec_def
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text\<open>This form avoids giant explosions in proofs. NOTE the form of the premise!\<close>
lemma def_Vrec:
    "\<lbrakk>\<And>x. h(x)\<equiv>Vrec(x,H)\<rbrakk> \<Longrightarrow>
     h(a) = H(a, \<lambda>x\<in>Vset(rank(a)). h(x))"
apply simp
apply (rule Vrec)
done

text\<open>NOT SUITABLE FOR REWRITING: recursive!\<close>
lemma Vrecursor:
     "Vrecursor(H,a) = H(\<lambda>x\<in>Vset(rank(a)). Vrecursor(H,x),  a)"
  unfolding Vrecursor_def
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text\<open>This form avoids giant explosions in proofs. NOTE the form of the premise!\<close>
lemma def_Vrecursor:
     "h \<equiv> Vrecursor(H) \<Longrightarrow> h(a) = H(\<lambda>x\<in>Vset(rank(a)). h(x),  a)"
apply simp
apply (rule Vrecursor)
done

subsection\<open>The Datatype Universe: \<^term>\<open>univ(A)\<close>\<close>

lemma univ_mono: "A<=B \<Longrightarrow> univ(A) \<subseteq> univ(B)"
  unfolding univ_def
apply (erule Vfrom_mono)
apply (rule subset_refl)
done

lemma Transset_univ: "Transset(A) \<Longrightarrow> Transset(univ(A))"
  unfolding univ_def
apply (erule Transset_Vfrom)
done

subsubsection\<open>The Set \<^term>\<open>univ(A)\<close> as a Limit\<close>

lemma univ_eq_UN: "univ(A) = (\<Union>i\<in>nat. Vfrom(A,i))"
  unfolding univ_def
apply (rule Limit_nat [THEN Limit_Vfrom_eq])
done

lemma subset_univ_eq_Int: "c \<subseteq> univ(A) \<Longrightarrow> c = (\<Union>i\<in>nat. c \<inter> Vfrom(A,i))"
apply (rule subset_UN_iff_eq [THEN iffD1])
apply (erule univ_eq_UN [THEN subst])
done

lemma univ_Int_Vfrom_subset:
    "\<lbrakk>a \<subseteq> univ(X);
        \<And>i. i:nat \<Longrightarrow> a \<inter> Vfrom(X,i) \<subseteq> b\<rbrakk>
     \<Longrightarrow> a \<subseteq> b"
apply (subst subset_univ_eq_Int, assumption)
apply (rule UN_least, simp)
done

lemma univ_Int_Vfrom_eq:
    "\<lbrakk>a \<subseteq> univ(X);   b \<subseteq> univ(X);
        \<And>i. i:nat \<Longrightarrow> a \<inter> Vfrom(X,i) = b \<inter> Vfrom(X,i)
\<rbrakk> \<Longrightarrow> a = b"
apply (rule equalityI)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
done

subsection\<open>Closure Properties for \<^term>\<open>univ(A)\<close>\<close>

lemma zero_in_univ: "0 \<in> univ(A)"
  unfolding univ_def
apply (rule nat_0I [THEN zero_in_Vfrom])
done

lemma zero_subset_univ: "{0} \<subseteq> univ(A)"
by (blast intro: zero_in_univ)

lemma A_subset_univ: "A \<subseteq> univ(A)"
  unfolding univ_def
apply (rule A_subset_Vfrom)
done

lemmas A_into_univ = A_subset_univ [THEN subsetD]

subsubsection\<open>Closure under Unordered and Ordered Pairs\<close>

lemma singleton_in_univ: "a: univ(A) \<Longrightarrow> {a} \<in> univ(A)"
  unfolding univ_def
apply (blast intro: singleton_in_VLimit Limit_nat)
done

lemma doubleton_in_univ:
    "\<lbrakk>a: univ(A);  b: univ(A)\<rbrakk> \<Longrightarrow> {a,b} \<in> univ(A)"
  unfolding univ_def
apply (blast intro: doubleton_in_VLimit Limit_nat)
done

lemma Pair_in_univ:
    "\<lbrakk>a: univ(A);  b: univ(A)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> univ(A)"
  unfolding univ_def
apply (blast intro: Pair_in_VLimit Limit_nat)
done

lemma Union_in_univ:
     "\<lbrakk>X: univ(A);  Transset(A)\<rbrakk> \<Longrightarrow> \<Union>(X) \<in> univ(A)"
  unfolding univ_def
apply (blast intro: Union_in_VLimit Limit_nat)
done

lemma product_univ: "univ(A)*univ(A) \<subseteq> univ(A)"
  unfolding univ_def
apply (rule Limit_nat [THEN product_VLimit])
done

subsubsection\<open>The Natural Numbers\<close>

lemma nat_subset_univ: "nat \<subseteq> univ(A)"
  unfolding univ_def
apply (rule i_subset_Vfrom)
done

lemma nat_into_univ: "n \<in> nat \<Longrightarrow> n \<in> univ(A)"
  by (rule nat_subset_univ [THEN subsetD])

subsubsection\<open>Instances for 1 and 2\<close>

lemma one_in_univ: "1 \<in> univ(A)"
  unfolding univ_def
apply (rule Limit_nat [THEN one_in_VLimit])
done

text\<open>unused!\<close>
lemma two_in_univ: "2 \<in> univ(A)"
by (blast intro: nat_into_univ)

lemma bool_subset_univ: "bool \<subseteq> univ(A)"
  unfolding bool_def
apply (blast intro!: zero_in_univ one_in_univ)
done

lemmas bool_into_univ = bool_subset_univ [THEN subsetD]

subsubsection\<open>Closure under Disjoint Union\<close>

lemma Inl_in_univ: "a: univ(A) \<Longrightarrow> Inl(a) \<in> univ(A)"
  unfolding univ_def
apply (erule Inl_in_VLimit [OF _ Limit_nat])
done

lemma Inr_in_univ: "b: univ(A) \<Longrightarrow> Inr(b) \<in> univ(A)"
  unfolding univ_def
apply (erule Inr_in_VLimit [OF _ Limit_nat])
done

lemma sum_univ: "univ(C)+univ(C) \<subseteq> univ(C)"
  unfolding univ_def
apply (rule Limit_nat [THEN sum_VLimit])
done

lemmas sum_subset_univ = subset_trans [OF sum_mono sum_univ]

lemma Sigma_subset_univ:
  "\<lbrakk>A \<subseteq> univ(D); \<And>x. x \<in> A \<Longrightarrow> B(x) \<subseteq> univ(D)\<rbrakk> \<Longrightarrow> Sigma(A,B) \<subseteq> univ(D)"
apply (simp add: univ_def)
apply (blast intro: Sigma_subset_VLimit del: subsetI)
done

(*Closure under binary union -- use Un_least
  Closure under Collect -- use  Collect_subset [THEN subset_trans]
  Closure under RepFun -- use   RepFun_subset *)

subsection\<open>Finite Branching Closure Properties\<close>

subsubsection\<open>Closure under Finite Powerset\<close>

lemma Fin_Vfrom_lemma:
     "\<lbrakk>b: Fin(Vfrom(A,i));  Limit(i)\<rbrakk> \<Longrightarrow> \<exists>j. b \<subseteq> Vfrom(A,j) \<and> j<i"
apply (erule Fin_induct)
apply (blast dest!: Limit_has_0, safe)
apply (erule Limit_VfromE, assumption)
apply (blast intro!: Un_least_lt intro: Vfrom_UnI1 Vfrom_UnI2)
done

lemma Fin_VLimit: "Limit(i) \<Longrightarrow> Fin(Vfrom(A,i)) \<subseteq> Vfrom(A,i)"
apply (rule subsetI)
apply (drule Fin_Vfrom_lemma, safe)
apply (rule Vfrom [THEN ssubst])
apply (blast dest!: ltD)
done

lemmas Fin_subset_VLimit = subset_trans [OF Fin_mono Fin_VLimit]

lemma Fin_univ: "Fin(univ(A)) \<subseteq> univ(A)"
  unfolding univ_def
apply (rule Limit_nat [THEN Fin_VLimit])
done

subsubsection\<open>Closure under Finite Powers: Functions from a Natural Number\<close>

lemma nat_fun_VLimit:
     "\<lbrakk>n: nat;  Limit(i)\<rbrakk> \<Longrightarrow> n -> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (erule nat_fun_subset_Fin [THEN subset_trans])
apply (blast del: subsetI
    intro: subset_refl Fin_subset_VLimit Sigma_subset_VLimit nat_subset_VLimit)
done

lemmas nat_fun_subset_VLimit = subset_trans [OF Pi_mono nat_fun_VLimit]

lemma nat_fun_univ: "n: nat \<Longrightarrow> n -> univ(A) \<subseteq> univ(A)"
  unfolding univ_def
apply (erule nat_fun_VLimit [OF _ Limit_nat])
done

subsubsection\<open>Closure under Finite Function Space\<close>

text\<open>General but seldom-used version; normally the domain is fixed\<close>
lemma FiniteFun_VLimit1:
     "Limit(i) \<Longrightarrow> Vfrom(A,i) -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule FiniteFun.dom_subset [THEN subset_trans])
apply (blast del: subsetI
             intro: Fin_subset_VLimit Sigma_subset_VLimit subset_refl)
done

lemma FiniteFun_univ1: "univ(A) -||> univ(A) \<subseteq> univ(A)"
  unfolding univ_def
apply (rule Limit_nat [THEN FiniteFun_VLimit1])
done

text\<open>Version for a fixed domain\<close>
lemma FiniteFun_VLimit:
     "\<lbrakk>W \<subseteq> Vfrom(A,i); Limit(i)\<rbrakk> \<Longrightarrow> W -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule subset_trans)
apply (erule FiniteFun_mono [OF _ subset_refl])
apply (erule FiniteFun_VLimit1)
done

lemma FiniteFun_univ:
    "W \<subseteq> univ(A) \<Longrightarrow> W -||> univ(A) \<subseteq> univ(A)"
  unfolding univ_def
apply (erule FiniteFun_VLimit [OF _ Limit_nat])
done

lemma FiniteFun_in_univ:
     "\<lbrakk>f: W -||> univ(A);  W \<subseteq> univ(A)\<rbrakk> \<Longrightarrow> f \<in> univ(A)"
by (erule FiniteFun_univ [THEN subsetD], assumption)

text\<open>Remove \<open>\<subseteq>\<close> from the rule above\<close>
lemmas FiniteFun_in_univ' = FiniteFun_in_univ [OF _ subsetI]

subsection\<open>* For QUniv.  Properties of Vfrom analogous to the "take-lemma" *\<close>

text\<open>Intersecting a*b with Vfrom...\<close>

text\<open>This version says a, b exist one level down, in the smaller set Vfrom(X,i)\<close>
lemma doubleton_in_Vfrom_D:
     "\<lbrakk>{a,b} \<in> Vfrom(X,succ(i));  Transset(X)\<rbrakk>
      \<Longrightarrow> a \<in> Vfrom(X,i)  \<and>  b \<in> Vfrom(X,i)"
by (drule Transset_Vfrom_succ [THEN equalityD1, THEN subsetD, THEN PowD],
    assumption, fast)

text\<open>This weaker version says a, b exist at the same level\<close>
lemmas Vfrom_doubleton_D = Transset_Vfrom [THEN Transset_doubleton_D]

(** Using only the weaker theorem would prove \<langle>a,b\<rangle> \<in> Vfrom(X,i)
      implies a, b \<in> Vfrom(X,i), which is useless for induction.
    Using only the stronger theorem would prove \<langle>a,b\<rangle> \<in> Vfrom(X,succ(succ(i)))
      implies a, b \<in> Vfrom(X,i), leaving the succ(i) case untreated.
    The combination gives a reduction by precisely one level, which is
      most convenient for proofs.
**)

lemma Pair_in_Vfrom_D:
    "\<lbrakk>\<langle>a,b\<rangle> \<in> Vfrom(X,succ(i));  Transset(X)\<rbrakk>
     \<Longrightarrow> a \<in> Vfrom(X,i)  \<and>  b \<in> Vfrom(X,i)"
  unfolding Pair_def
apply (blast dest!: doubleton_in_Vfrom_D Vfrom_doubleton_D)
done

lemma product_Int_Vfrom_subset:
     "Transset(X) \<Longrightarrow>
      (a*b) \<inter> Vfrom(X, succ(i)) \<subseteq> (a \<inter> Vfrom(X,i)) * (b \<inter> Vfrom(X,i))"
by (blast dest!: Pair_in_Vfrom_D)

ML
\<open>
val rank_ss =
  simpset_of (\<^context> addsimps [@{thm VsetI}]
    addsimps @{thms rank_rls} @ (@{thms rank_rls} RLN (2, [@{thm lt_trans}])));
\<close>

end


theory sort_StoogeSortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun zsplitAt :: "int => 'a list =>
                 (('a list), ('a list)) Pair2" where
"zsplitAt x y = Pair (ztake x y) (zdrop x y)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun reverse :: "'t list => 't list" where
"reverse (Nil2) = Nil2"
| "reverse (Cons2 y xs) = append (reverse xs) (Cons2 y (Nil2))"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 x =
   case zsplitAt (div (zlength x) 3) (reverse x) of
     | Pair ys zs =>
         case zsplitAt (div (zlength x) 3) (reverse x) of
           | Pair xs zs2 => append (stoogesort zs) (reverse xs)
         end
   end"
| "stoogesort (Nil2) = Nil2"
| "stoogesort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "stoogesort (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "stoogesort (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "stooge1sort1 x =
     case zsplitAt (div (zlength x) 3) x of
       | Pair ys zs =>
           case zsplitAt (div (zlength x) 3) x of
             | Pair xs zs2 => append ys (stoogesort zs2)
           end
     end"
by pat_completeness auto

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster ztake
          zlength
          zdrop
          zsplitAt
          sort2
          append
          reverse
          stooge1sort2
          stoogesort
          stooge1sort1
          and2
          ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (stoogesort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory CogentMonad
imports Main
begin

text {*

  A non-deterministic monad. The result is a set of values "results" and a
  failure flag "mayFail". (Note: this is not the same as the non-determistic
  state monad in l4.verified. It does not model state.)

  Each element in the set is a potential result of the
  computation. The "mayFail" flag is @{const True} if there is an execution path
  in the computation that may have failed. Conversely, if "mayFail" is
  @{const False}, none of the computations resulting in the returned
  set can have failed.

*}

type_synonym 'a cogent_monad = "'a set"

text {*
  The definition of fundamental monad functions @{text return} and
  @{text bind}. The monad function @{text "return x"} does not change
  the  state, does not fail, and returns @{text "x"}.
*}

definition
  return :: "'a \<Rightarrow> 'a cogent_monad" where
  "return a \<equiv>  {a}"

text {*
  The monad function @{text "bind f g"}, also written @{text "f >>= g"},
  is the execution of @{term f} followed by the execution of @{text g}.
  The function @{text g} takes the result value \emph{and} the result
  state of @{text f} as parameter. The definition says that the result of
  the combined operation is the union of the set of sets that is created
  by @{text g} applied to the result sets of @{text f}. The combined
  operation may have failed, if @{text f} may have failed or @{text g} may
  have failed on any of the results of @{text f}.
*}

definition
  bind :: "'a cogent_monad \<Rightarrow> ('a \<Rightarrow> 'b cogent_monad) \<Rightarrow> 'b cogent_monad" (infixl ">>=" 60) where
  "m >>= f \<equiv> \<Union> (f ` m)"

subsection "Monad laws"

lemma "return a >>= f = f a"
  by (auto simp: return_def bind_def)

lemma "m >>= return = m"
  by (auto simp: return_def bind_def)

lemma "(m >>= f) >>= g = m >>= (\<lambda>x. f x >>= g)"
  by (auto simp: bind_def)

subsection "Nondeterminism"

text {*
  Basic nondeterministic functions. @{text "select A"} chooses an element
  of the set @{text A}, does not change the state, and does not fail
  (even if the set is empty). *}

definition
  select :: "'a set \<Rightarrow> 'a cogent_monad" where
  "select A \<equiv> A"

text {*  @{text "f OR g"} executes @{text f} or
  executes @{text g}. It retuns the union of results of @{text f} and
  @{text g}, and may have failed if either may have failed.
*}
definition
  alternative :: "'a cogent_monad \<Rightarrow> 'a cogent_monad \<Rightarrow> 'a cogent_monad"
where
  "alternative m n \<equiv>  m \<union> n"

lemmas monadic_simps = return_def alternative_def select_def bind_def

notation (xsymbols)  alternative (infixl "\<sqinter>" 20)

text {* We use @{text K_bind} to syntactically indicate the
  case where the return argument of the left side of a @{term bind}
  is ignored *}
definition
  K_bind [iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do (_);//   (_)//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "b >>= (CONST K_bind e)"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

value "do x \<leftarrow> do x \<leftarrow> { (1::nat),2,3 };
                 return (x+1)
       od ;
         return (66 :: nat)
       od"

end


theory NonFreeViaQuotient
imports Main
begin

(* interpretation for
    nonfreedatatype 'a set := Empty | Insert 'a ('a set)
    where  Insert i (Insert j s) = Insert j (Insert i s)
*)

(* quotienting von einem Free datatype um den non-free datatype
   zu erhalten geht gerade noch so *)
datatype 'a pset = pEmpty | pInsert 'a "'a pset"

inductive
  pset_equi :: "'a pset => 'a pset => bool"
where
  equi_refl: "pset_equi x x"
| equi_base: "pset_equi (pInsert i (pInsert j s)) (pInsert j (pInsert i s))"
| equi_cong: "pset_equi x y ==> pset_equi (pInsert i x) (pInsert i y)"
| equi_trans: "pset_equi x y ==> pset_equi y z ==> pset_equi x z"
| equi_symm: "pset_equi x y ==> pset_equi y x"

quotient_type 'a set = "'a pset" / pset_equi
  unfolding equivp_def sorry (* pset_equi is an equivalence relation *)

primrec
  psetrec :: "'b => ('a => 'b => 'b) => 'a pset => 'b"
where
  psetrec_base:  "psetrec b f pEmpty = b"
| psetrec_step: "psetrec b f (pInsert a s) = f a (psetrec b f s)"

(* die invarianzbedingung an f ist hier wesentlich schwaecher (aber extensional gleichstark)
   wie die Definition von pset_equi und entspricht nur dem equi_base Fall *)
lemma psetrec_inv: assumes H: "pset_equi s s2" and finv: "(ALL i j. f i (f j s) = f j (f i s))"
  shows "psetrec b f s = psetrec b f s2"
apply (rule pset_equi.induct[OF H])
apply (auto intro: finv)
sorry

quotient_definition
  "Empty :: 'a set"
is "pEmpty :: 'a pset"
quotient_definition
  "Insert :: 'a => 'a set => 'a set"
is "pInsert :: 'a => 'a pset => 'a pset"

thm pset.induct
lemma set_induct: "[| P Empty; !!a s. P s ==> P (Insert a s) |] ==> P s"
apply (lifting pset.induct)
unfolding fun_rel_def
by (auto intro: equi_cong)

quotient_definition
  "setrec :: 'b => ('a => 'b => 'b) => 'a set => 'b"
is "psetrec :: 'b => ('a => 'b => 'b) => 'a pset => 'b"

(* type annotation on f needed to get exactly the corresponding types of psetrec_base *)
lemma setrec_base: "setrec b (f :: 'a => 'b => 'b) Empty = b"
apply (lifting psetrec_base)
unfolding fun_rel_def
apply (auto intro: equi_cong equi_refl)
sorry (* apply (rule psetrec_inv) *)

lemma setrec_step: "setrec b (f :: 'a => 'b => 'b) (Insert x s) = f x (setrec b f s)"
apply (lifting psetrec_step)
unfolding fun_rel_def
apply (auto intro: equi_cong equi_refl)
sorry (* apply (rule psetrec_inv) *)

(* more involved example *)
(* etwas kuenstlich weil man 'a swap_pair einfach inlinen koennte *)
datatype 'a pswap_set = psEmpty | psNode 'a | psInsert "'a pswap_pair" "'a pswap_set"
 and 'a pswap_pair = pSwapPair "'a pswap_set" "'a pswap_set"

inductive
  psset_equi :: "'a pswap_set => 'a pswap_set => bool" and
  pspair_equi :: "'a pswap_pair => 'a pswap_pair => bool"
where
    sequi_refl: "psset_equi x x"
  | sequi_subst: "psset_equi (psInsert i (psInsert j s)) (psInsert j (psInsert i s))"
  | sequi_cong: "psset_equi x y ==> psset_equi (psInsert i x) (psInsert i y)" (* in sequi_subst inlinen? *)
  | sequi_trans: "psset_equi x y ==> psset_equi y z ==> psset_equi x z"
  | sequi_symm: "psset_equi x y ==> psset_equi y x"

  | pequi_refl: "pspair_equi x x"
  | pequi_base: "pspair_equi (pSwapPair x x2) (pSwapPair x2 x)"
  | pequi_cong: "psset_equi x y ==> psset_equi x2 y2 ==> pspair_equi (pSwapPair x x2) (pSwapPair y y2)"
  | pequi_trans: "pspair_equi x y ==> pspair_equi y z ==> pspair_equi x z"
  | pequi_symm: "pspair_equi x y ==> pspair_equi y x"

quotient_type 'a swap_set = "'a pswap_set" / psset_equi
and 'a swap_pair = "'a pswap_pair" / pspair_equi
  unfolding equivp_def sorry (* they are equivalence relations *)

quotient_definition
  "sEmpty :: 'a swap_set"
is "psEmpty :: 'a pswap_set"
quotient_definition
  "sNode :: 'a => 'a swap_set"
is "psNode :: 'a => 'a pswap_set"
quotient_definition
  "sInsert :: 'a swap_pair => 'a swap_set => 'a swap_set"
is "psInsert :: 'a pswap_pair => 'a pswap_set => 'a pswap_set"
quotient_definition
  "SwapPair :: 'a swap_set => 'a swap_set => 'a swap_pair"
is "pSwapPair :: 'a pswap_set => 'a pswap_set => 'a pswap_pair"

end


section \<open>Connection between the continued fraction expansion of square roots and Pell's equation\<close>
theory Pell_Continued_Fraction
imports
  Sqrt_Nat_Cfrac
  Pell.Pell_Algorithm
  Polynomial_Factorization.Prime_Factorization
  Pell_Lifting
begin

lemma irrational_times_int_eq_intD:
  assumes "p * real_of_int a = real_of_int b"
  assumes "p \<notin> \<rat>"
  shows   "a = 0 \<and> b = 0"
proof -
  have "a = 0"
  proof (rule ccontr)
    assume "a \<noteq> 0"
    with assms(1) have "p = b / a" by (auto simp: field_simps)
    also have "\<dots> \<in> \<rat>" by auto
    finally show False using assms(2) by contradiction
  qed
  with assms show ?thesis by simp
qed

text \<open>
  The solutions to Pell's equation for some non-square \<open>D\<close> are linked to the continued
  fraction expansion of $\sqrt{D}$, which we shall show here.
\<close>

context
  fixes D :: nat and c h k P Q l
  assumes nonsquare: "\<not>is_square D"
  defines "c \<equiv> cfrac_of_real (sqrt D)"
  defines "h \<equiv> conv_num c" and "k \<equiv> conv_denom c"
  defines "P \<equiv> fst \<circ> sqrt_remainder_surd D" and "Q \<equiv> snd \<circ> sqrt_remainder_surd D"
  defines "l \<equiv> sqrt_nat_period_length D"
begin

interpretation pell D
  by unfold_locales fact+

lemma cfrac_length_infinite [simp]: "cfrac_length c = \<infinity>"
proof -
  have "sqrt D \<notin> \<rat>"
    using nonsquare by (simp add: irrat_sqrt_nonsquare)
  thus ?thesis
    by (simp add: c_def)
qed

lemma conv_num_denom_pell:
  "h 0 ^ 2 - D * k 0 ^ 2 < 0"
  "m > 0 \<Longrightarrow> h m ^ 2 - D * k m ^ 2 = (-1) ^ Suc m * Q m"
proof -
  define D' where "D' = Discrete.sqrt D"
  have "h 0 ^ 2 - D * k 0 ^ 2 = int (D' ^ 2) - int D"
    by (simp_all add: h_def k_def c_def Discrete_sqrt_altdef D'_def)
  also {
    have "int (D' ^ 2) - int D \<le> 0"
      using Discrete.sqrt_power2_le[of D] by (simp add: D'_def)
    moreover have "D \<noteq> D' ^ 2" using nonsquare by auto
    ultimately have "int (D' ^ 2) - int D < 0" by linarith
  }
  finally show "h 0 ^ 2 - D * k 0 ^ 2 < 0" .
next
  assume "m > 0"
  define n where "n = m - 1"
  define \<alpha> where "\<alpha> = cfrac_remainder c"
  define \<alpha>' where "\<alpha>' = sqrt_remainder_surd D"
  have m: "m = Suc n" using \<open>m > 0\<close> by (simp add: n_def)
  from nonsquare have "D > 1"
    by (cases D) (auto intro!: Nat.gr0I)
  from nonsquare have irrat: "sqrt D \<notin> \<rat>"
    using irrat_sqrt_nonsquare by blast
  have [simp]: "cfrac_lim c = sqrt D"
    using irrat \<open>D > 1\<close> by (simp add: c_def)
  have \<alpha>_pos: "\<alpha> n > 0" for n
    unfolding \<alpha>_def using wf \<open>D > 1\<close> cfrac_remainder_pos[of c n]
    by (cases "n = 0") auto
  have \<alpha>': "\<alpha>' n = (P n, Q n)" for n by (simp add: \<alpha>'_def P_def Q_def)
  have Q_pos: "Q n > 0" for n
    using snd_sqrt_remainder_surd_pos[OF nonsquare] by (simp add: Q_def)
  have k_pos: "k n > 0" for n
    by (auto simp: k_def intro!: conv_denom_pos)
  have k_nonneg: "k n \<ge> 0" for n
    by (auto simp: k_def intro!: conv_denom_nonneg)

  let ?A = "(sqrt D + P (n + 1)) * h (n + 1) + Q (n + 1) * h n"
  let ?B = "(sqrt D + P (n + 1)) * k (n + 1) + Q (n + 1) * k n"
  have "?B > 0" using k_pos Q_pos k_nonneg
    by (intro add_nonneg_pos mult_nonneg_nonneg add_nonneg_nonneg) auto

  have "sqrt D = conv' c (Suc (Suc n)) (\<alpha> (Suc (Suc n)))"
    unfolding \<alpha>_def by (subst conv'_cfrac_remainder) auto
  also have "\<dots> = (\<alpha> (n + 2) * h (n + 1) + h n) / (\<alpha> (n + 2) * k (n + 1) + k n)"
    using wf \<alpha>_pos by (subst conv'_num_denom) (simp_all add: h_def k_def)
  also have "\<alpha> (n + 2) = surd_to_real D (\<alpha>' (Suc n))"
    using surd_to_real_sqrt_remainder_surd[OF nonsquare, of "Suc n"]
    by (simp add: \<alpha>'_def \<alpha>_def c_def)
  also have "\<dots> = (sqrt D + P (Suc n)) / Q (Suc n)" (is "_ = ?\<alpha>")
    by (simp add: \<alpha>' surd_to_real_def)
  also have "?\<alpha> * h (n + 1) + h n =
               1 / Q (n + 1) * ((sqrt D + P (n + 1)) * h (n + 1) + Q (n + 1) * h n)"
    using Q_pos by (simp add: field_simps)
  also have "?\<alpha> * k (n + 1) + k n =
               1 / Q (n + 1) * ((sqrt D + P (n + 1)) * k (n + 1) + Q (n + 1) * k n)"
    (is "_ = ?f k") using Q_pos by (simp add: field_simps)
  also have "?f h / ?f k = ((sqrt D + P (n + 1)) * h (n + 1) + Q (n + 1) * h n) /
                             ((sqrt D + P (n + 1)) * k (n + 1) + Q (n + 1) * k n)"
    (is "_ = ?A / ?B") using Q_pos by (intro mult_divide_mult_cancel_left) auto
  finally have "sqrt D * ?B = ?A"
    using \<open>?B > 0\<close> by (simp add: divide_simps)
  moreover have "sqrt D * sqrt D = D" by simp
  ultimately have "sqrt D * (P (n + 1) * k (n + 1) + Q (n + 1) * k n - h (n + 1)) =
         P (n + 1) * h (n + 1) + Q (n + 1) * h n - k (n + 1) * D"
    unfolding of_int_add of_int_mult of_int_diff of_int_of_nat_eq of_nat_mult of_nat_add
    by Groebner_Basis.algebra
  from irrational_times_int_eq_intD[OF this] irrat
    have 1: "h (Suc n) = P (Suc n) * k (Suc n) + Q (Suc n) * k n"
     and 2: "D * k (Suc n) = P (Suc n) * h (Suc n) + Q (Suc n) * h n"
      by (simp_all del: of_nat_add of_nat_mult)

  have "h (Suc n) * h (Suc n) - D * k (Suc n) * k (Suc n) =
          Q (Suc n) * (k n * h (Suc n) - k (Suc n) * h n)"
    by (subst 1, subst 2) (simp add: algebra_simps)
  also have "k n * h (Suc n) - k (Suc n) * h n = (-1) ^ n"
    unfolding h_def k_def by (rule conv_num_denom_prod_diff)
  finally have "h (Suc n) ^ 2 - D * k (Suc n) ^ 2 = (-1) ^ n * Q (Suc n)"
    by (simp add: power2_eq_square algebra_simps)
  thus "h m ^ 2 - D * k m ^ 2 = (-1) ^ Suc m * Q m"
    by (simp add: m)
qed

text \<open>
  Every non-trivial solution to Pell's equation is a convergent in the expansion of $\sqrt{D}$:
\<close>
theorem pell_solution_is_conv:
  assumes "x\<^sup>2 = Suc (D * y\<^sup>2)" and "y > 0"
  shows   "(int x, int y) \<in> range (\<lambda>n. (conv_num c n, conv_denom c n))"
proof -
  have "\<exists>n. enat n \<le> cfrac_length c \<and> (int x, int y) = (conv_num c n, conv_denom c n)"
  proof (rule frac_is_convergentI)
    have "gcd (x\<^sup>2) (y\<^sup>2) = 1" unfolding assms(1)
      using gcd_add_mult[of "y\<^sup>2" D 1] by (simp add: gcd.commute)
    thus "coprime (int x) (int y)"
      by (simp add: coprime_iff_gcd_eq_1)
  next
    from assms have "D > 1"
      using nonsquare by (cases D) (auto intro!: Nat.gr0I)
    hence pos: "x + y * sqrt D > 0" using assms
      by (intro add_nonneg_pos) auto

    from assms have "real (x\<^sup>2) = real (Suc (D * y\<^sup>2))"
      by (simp only: of_nat_eq_iff)
    hence "1 = real x ^ 2 - D * real y ^ 2"
      unfolding of_nat_power by simp
    also have "\<dots> = (x - y * sqrt D) * (x + y * sqrt D)"
      by (simp add: field_simps power2_eq_square)
    finally have *: "x - y * sqrt D = 1 / (x + y * sqrt D)"
      using pos by (simp add: field_simps)

    from pos have "0 < 1 / (x + y * sqrt D)"
      by (intro divide_pos_pos) auto
    also have "\<dots> = x - y * sqrt D" by (rule * [symmetric])
    finally have less: "y * sqrt D < x" by simp

    have "sqrt D - x / y = -((x - y * sqrt D) / y)"
      using \<open>y > 0\<close> by (simp add: field_simps)
    also have "\<bar>\<dots>\<bar> = (x - y * sqrt D) / y"
      using less by simp
    also have "(x - y * sqrt D) / y = 1 / (y * (x + y * sqrt D))"
      using \<open>y > 0\<close> by (subst *) auto
    also have "\<dots> \<le> 1 / (y * (y * sqrt D + y * sqrt D))"
      using \<open>y > 0\<close> \<open>D > 1\<close> pos less
      by (intro divide_left_mono mult_left_mono add_right_mono mult_pos_pos) auto
    also have "\<dots> = 1 / (2 * y\<^sup>2 * sqrt D)"
      by (simp add: power2_eq_square)
    also have "\<dots> < 1 / (real (2 * y\<^sup>2) * 1)" using \<open>y > 0\<close> \<open>D > 1\<close>
      by (intro divide_strict_left_mono mult_strict_left_mono mult_pos_pos) auto
    finally show "\<bar>cfrac_lim c - int x / int y\<bar> < 1 / (2 * int y ^ 2)"
      unfolding c_def using irrat_sqrt_nonsquare[of D] \<open>\<not>is_square D\<close> by simp
  qed (insert assms irrat_sqrt_nonsquare[of D], auto simp: c_def)
  thus ?thesis by auto
qed

text \<open>
  Let \<open>l\<close> be the length of the period in the continued fraction expansion of $\sqrt{D}$ and let
  $h_i$ and $k_i$ be the numerator and denominator of the \<open>i\<close>-th convergent.

  Then the non-trivial solutions of Pell's equation are exactly the pairs of the form
  $(h_{lm -1}, k_{lm-1})$ for any \<open>m\<close> such that $lm$ is even.
\<close>
lemma nontriv_solution_iff_conv_num_denom:
  "nontriv_solution (x, y) \<longleftrightarrow>
     (\<exists>m>0. int x = h (l * m - 1) \<and> int y = k (l * m - 1) \<and> even (l * m))"
proof safe
  fix m assume xy: "x = h (l * m - 1)" "y = k (l * m - 1)"
           and lm: "even (l * m)" and m: "m > 0"
  have l: "l > 0" using period_nonempty[OF nonsquare] by (auto simp: l_def)
  from lm have "l * m \<noteq> 1" by (intro notI) auto
  with l m have lm': "l * m > 1" by (cases "l * m") auto

  have "(h (l * m - 1))\<^sup>2 - D * (k (l * m - 1))\<^sup>2 =
          (- 1) ^ Suc (l * m - 1) * int (Q (l * m - 1))"
    using lm' by (intro conv_num_denom_pell) auto
  also have "(- 1) ^ Suc (l * m - 1) = (1 :: int)"
    using lm l m by (subst neg_one_even_power) auto
  also have "Q (l * m - 1) = Q ((l * m - 1) mod l)"
    unfolding Q_def l_def o_def by (subst sqrt_remainder_surd_periodic[OF nonsquare]) simp
  also {
    have "l * m - 1 = (m - 1) * l + (l - 1)"
      using m l lm' by (cases m) (auto simp: mult_ac)
    also have "\<dots> mod l = (l - 1) mod l"
      by simp
    also have "\<dots> = l - 1"
      using l by (intro mod_less) auto
    also have "Q \<dots> = 1"
      using sqrt_remainder_surd_last[OF nonsquare] by (simp add: Q_def l_def)
    finally have "Q ((l * m - 1) mod l) = 1" .
  }
  finally have "h (l * m - 1) ^ 2 =  D * k (l * m - 1) ^ 2 + 1"
    unfolding of_nat_Suc by (simp add: algebra_simps)
  hence "h (l * m - 1) ^ 2 = D * k (l * m - 1) ^ 2 + 1"
    by (simp only: of_nat_eq_iff)
  moreover have "k (l * m - 1) > 0"
    unfolding k_def by (intro conv_denom_pos)
  ultimately have "nontriv_solution (int x, int y)"
    using xy by (simp add: nontriv_solution_def)
  thus "nontriv_solution (x, y)"
    by simp
next
  assume "nontriv_solution (x, y)"
  hence asm: "x ^ 2 = Suc (D * y ^ 2)" "y > 0"
    by (auto simp: nontriv_solution_def abs_square_eq_1 intro!: Nat.gr0I)
  from asm have asm': "int x ^ 2 = int D * int y ^ 2 + 1"
    by (metis add.commute of_nat_Suc of_nat_mult of_nat_power_eq_of_nat_cancel_iff)
  have l: "l > 0" using period_nonempty[OF nonsquare] by (auto simp: l_def)
  from pell_solution_is_conv[OF asm] obtain m where
    xy: "h m = x" "k m = y" by (auto simp: c_def h_def k_def)

  have m: "m > 0"
    using asm' conv_num_denom_pell(1) xy by (intro Nat.gr0I) auto
  have "1 = h m ^ 2 - D * k m ^ 2"
    using asm' xy by simp
  also have "\<dots> = (- 1) ^ Suc m * int (Q m)"
    using conv_num_denom_pell(2)[OF m] .
  finally have *: "(- 1) ^ Suc m * int (Q m) = 1" ..
  from * have m': "odd m \<and> Q m = 1"
    by (cases "even m") auto

  define n where "n = Suc m div l"
  have "l dvd Suc m"
  proof (rule ccontr)
    assume *: "\<not>(l dvd Suc m)"
    have "Q m = Q (m mod l)"
      unfolding Q_def l_def o_def by (subst sqrt_remainder_surd_periodic[OF nonsquare]) simp
    also {
      have "m mod l < l" using \<open>l > 0\<close> by simp
      moreover have "Suc (m mod l) \<noteq> l" using * l \<open>m > 0\<close>
        using mod_Suc[of m l] by auto
      ultimately have "m mod l < l - 1" by simp
      hence "Q (m mod l) > 1" unfolding Q_def o_def l_def
        by (rule snd_sqrt_remainder_surd_gt_1[OF nonsquare])
    }
    finally show False using m' by simp
  qed
  hence m_eq: "Suc m = n * l" "m = n * l - 1"
    by (simp_all add: n_def)
  hence "n > 0" by (auto intro!: Nat.gr0I)
  thus "\<exists>n>0. int x = h (l * n - 1) \<and> int y = k (l * n - 1) \<and> even (l * n)"
    using xy m_eq m' by (intro exI[of _ n]) (auto simp: mult_ac)
qed

text \<open>
  Consequently, the fundamental solution is $(h_n, k_n)$ where $n = l - 1$
  if \<open>l\<close> is even and $n = 2l-1$ otherwise:
\<close>
lemma fund_sol_conv_num_denom:
  defines "n \<equiv> if even l then l - 1 else 2 * l - 1"
  shows   "fund_sol = (nat (h n), nat (k n))"
proof (rule fund_sol_eq_sndI)
  have [simp]: "h n \<ge> 0" "k n \<ge> 0" for n
    by (auto simp: h_def k_def c_def intro!: conv_num_nonneg)
  show "nontriv_solution (nat (h n), nat (k n))"
    by (subst nontriv_solution_iff_conv_num_denom, rule exI[of _ "if even l then 1 else 2"])
       (simp_all add: n_def mult_ac)
next
  fix x y :: nat assume "nontriv_solution (x, y)"
  then obtain m where m: "m > 0" "x = h (l * m - 1)" "y = k (l * m - 1)" "even (l * m)"
    by (subst (asm) nontriv_solution_iff_conv_num_denom) auto
  have l: "l > 0" using period_nonempty[OF nonsquare] by (auto simp: l_def)
  from m l have "Suc n \<le> l * m" by (auto simp: n_def)
  hence "n \<le> l * m - 1" by simp
  hence "k n \<le> k (l * m - 1)"
    unfolding k_def c_def using irrat_sqrt_nonsquare[OF nonsquare]
    by (intro conv_denom_leI) auto
  with m show "nat (k n) \<le> y" by simp
qed

end

text \<open>
  The following algorithm computes the fundamental solution (or the dummy result \<open>(0, 0)\<close> if
  \<open>D\<close> is a square) fairly quickly by computing the continued fraction expansion of $\sqrt{D}$
  and then computing the fundamental solution as the appropriate convergent.
\<close>
lemma find_fund_sol_code [code]:
  "find_fund_sol D =
     (let info = sqrt_cfrac_info_array D;
          l = fst info
      in  if l = 0 then (0, 0) else
            let
              c = cfrac_sqrt_nth info;
              n = if even l then l - 1 else 2 * l - 1
          in
            (nat (conv_num_fun c n), nat (conv_denom_fun c n)))"
proof -
  have *: "is_cfrac (cfrac_sqrt_nth (sqrt_cfrac_info_array D))" if "\<not>is_square D"
    using that cfrac_sqrt_nth[of D] unfolding is_cfrac_def
    by (metis cfrac_nth_nonzero neq0_conv of_nat_0 of_nat_0_less_iff)
  have **: "cfrac (\<lambda>x. int (cfrac_sqrt_nth (sqrt_cfrac_info_array D) x)) = cfrac_of_real (sqrt D)"
    if "\<not>is_square D"
    using that cfrac_sqrt_nth[of D] * by (intro cfrac_eqI) auto
  show ?thesis using * **
    by (auto simp: square_test_correct find_fund_sol_correct conv_num_fun_eq conv_denom_fun_eq
                   Let_def cfrac_sqrt_nth fund_sol_conv_num_denom conv_num_nonneg)
qed

lemma find_nth_solution_square [simp]: "is_square D \<Longrightarrow> find_nth_solution D n = (0, 0)"
  by (simp add: find_nth_solution_def)

lemma fst_find_fund_sol_eq_0_iff [simp]: "fst (find_fund_sol D) = 0 \<longleftrightarrow> is_square D"
proof (cases "is_square D")
  case False
  then interpret pell D by unfold_locales
  from False have "find_fund_sol D = fund_sol" by (simp add: find_fund_sol_correct)
  moreover from fund_sol_is_nontriv_solution have "fst fund_sol > 0"
    by (auto simp: nontriv_solution_def intro!: Nat.gr0I)
  ultimately show ?thesis using False
    by (simp add: find_fund_sol_def square_test_correct split: if_splits)
qed (auto simp: find_fund_sol_def square_test_correct)

text \<open>
  Arbitrary solutions can now be computed as powers of the fundamental solution.
\<close>
lemma find_nth_solution_code [code]:
  "find_nth_solution D n =
     (let xy = find_fund_sol D
      in  if fst xy = 0 then (0, 0) else efficient_pell_power D xy n)"
proof (cases "is_square D")
  case False
  then interpret pell D by unfold_locales
  from fund_sol_is_nontriv_solution have "fst fund_sol > 0"
    by (auto simp: nontriv_solution_def intro!: Nat.gr0I)
  thus ?thesis using False
    by (simp add: find_nth_solution_correct Let_def nth_solution_def pell_power_def
                  pell_mul_commutes[of _ "fund_sol"] find_fund_sol_correct)
qed auto

lemma nth_solution_code [code]:
  "pell.nth_solution D n =
     (let info = sqrt_cfrac_info_array D;
          l = fst info
      in  if l = 0 then
             Code.abort (STR ''nth_solution is undefined for perfect square parameter.'')
               (\<lambda>_. pell.nth_solution D n)
          else
            let
              c = cfrac_sqrt_nth info;
              m = if even l then l - 1 else 2 * l - 1;
              fund_sol = (nat (conv_num_fun c m), nat (conv_denom_fun c m))
            in
              efficient_pell_power D fund_sol n)"
proof (cases "is_square D")
  case False
  then interpret pell by unfold_locales
  have *: "is_cfrac (cfrac_sqrt_nth (sqrt_cfrac_info_array D))"
    using False cfrac_sqrt_nth[of D] unfolding is_cfrac_def
    by (metis cfrac_nth_nonzero neq0_conv of_nat_0 of_nat_0_less_iff)
  have **: "cfrac (\<lambda>x. int (cfrac_sqrt_nth (sqrt_cfrac_info_array D) x)) = cfrac_of_real (sqrt D)"
    using False cfrac_sqrt_nth[of D] * by (intro cfrac_eqI) auto

  from False * ** show ?thesis
    by (auto simp: Let_def cfrac_sqrt_nth fund_sol_conv_num_denom nth_solution_def
                   pell_power_def pell_mul_commutes[of _ "(_, _)"]
                   conv_num_fun_eq conv_denom_fun_eq conv_num_nonneg)
qed auto

lemma fund_sol_code [code]:
  "pell.fund_sol D = (let info = sqrt_cfrac_info_array D;
          l = fst info
      in  if l = 0 then
             Code.abort (STR ''fund_sol is undefined for perfect square parameter.'')
               (\<lambda>_. pell.fund_sol D)
          else
            let
              c = cfrac_sqrt_nth info;
              n = if even l then l - 1 else 2 * l - 1
            in
              (nat (conv_num_fun c n), nat (conv_denom_fun c n)))"
proof (cases "is_square D")
  case False
  then interpret pell by unfold_locales
  have *: "is_cfrac (cfrac_sqrt_nth (sqrt_cfrac_info_array D))"
    using False cfrac_sqrt_nth[of D] unfolding is_cfrac_def
    by (metis cfrac_nth_nonzero neq0_conv of_nat_0 of_nat_0_less_iff)
  have **: "cfrac (\<lambda>x. int (cfrac_sqrt_nth (sqrt_cfrac_info_array D) x)) = cfrac_of_real (sqrt D)"
    using False cfrac_sqrt_nth[of D] * by (intro cfrac_eqI) auto

  from False * ** show ?thesis
    by (auto simp: Let_def cfrac_sqrt_nth fund_sol_conv_num_denom nth_solution_def
                   pell_power_def pell_mul_commutes[of _ "(_, _)"]
                   conv_num_fun_eq conv_denom_fun_eq conv_num_nonneg)
qed auto

end