(*  Title:  HOL/Rat.thy
    Author: Markus Wenzel, TU Muenchen
*)

section {* Rational numbers *}

theory Rat
imports GCD Archimedean_Field
begin

subsection {* Rational numbers as quotient *}

subsubsection {* Construction of the type of rational numbers *}

definition
  ratrel :: "(int \<times> int) \<Rightarrow> (int \<times> int) \<Rightarrow> bool" where
  "ratrel = (\<lambda>x y. snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x)"

lemma ratrel_iff [simp]:
  "ratrel x y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"
  by (simp add: ratrel_def)

lemma exists_ratrel_refl: "\<exists>x. ratrel x x"
  by (auto intro!: one_neq_zero)

lemma symp_ratrel: "symp ratrel"
  by (simp add: ratrel_def symp_def)

lemma transp_ratrel: "transp ratrel"
proof (rule transpI, unfold split_paired_all)
  fix a b a' b' a'' b'' :: int
  assume A: "ratrel (a, b) (a', b')"
  assume B: "ratrel (a', b') (a'', b'')"
  have "b' * (a * b'') = b'' * (a * b')" by simp
  also from A have "a * b' = a' * b" by auto
  also have "b'' * (a' * b) = b * (a' * b'')" by simp
  also from B have "a' * b'' = a'' * b'" by auto
  also have "b * (a'' * b') = b' * (a'' * b)" by simp
  finally have "b' * (a * b'') = b' * (a'' * b)" .
  moreover from B have "b' \<noteq> 0" by auto
  ultimately have "a * b'' = a'' * b" by simp
  with A B show "ratrel (a, b) (a'', b'')" by auto
qed

lemma part_equivp_ratrel: "part_equivp ratrel"
  by (rule part_equivpI [OF exists_ratrel_refl symp_ratrel transp_ratrel])

quotient_type rat = "int \<times> int" / partial: "ratrel"
  morphisms Rep_Rat Abs_Rat
  by (rule part_equivp_ratrel)

lemma Domainp_cr_rat [transfer_domain_rule]: "Domainp pcr_rat = (\<lambda>x. snd x \<noteq> 0)"
by (simp add: rat.domain_eq)

subsubsection {* Representation and basic operations *}

lift_definition Fract :: "int \<Rightarrow> int \<Rightarrow> rat"
  is "\<lambda>a b. if b = 0 then (0, 1) else (a, b)"
  by simp

lemma eq_rat:
  shows "\<And>a b c d. b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b = Fract c d \<longleftrightarrow> a * d = c * b"
  and "\<And>a. Fract a 0 = Fract 0 1"
  and "\<And>a c. Fract 0 a = Fract 0 c"
  by (transfer, simp)+

lemma Rat_cases [case_names Fract, cases type: rat]:
  assumes "\<And>a b. q = Fract a b \<Longrightarrow> b > 0 \<Longrightarrow> coprime a b \<Longrightarrow> C"
  shows C
proof -
  obtain a b :: int where "q = Fract a b" and "b \<noteq> 0"
    by transfer simp
  let ?a = "a div gcd a b"
  let ?b = "b div gcd a b"
  from `b \<noteq> 0` have "?b * gcd a b = b"
    by simp
  with `b \<noteq> 0` have "?b \<noteq> 0" by fastforce
  from `q = Fract a b` `b \<noteq> 0` `?b \<noteq> 0` have q: "q = Fract ?a ?b"
    by (simp add: eq_rat dvd_div_mult mult.commute [of a])
  from `b \<noteq> 0` have coprime: "coprime ?a ?b"
    by (auto intro: div_gcd_coprime_int)
  show C proof (cases "b > 0")
    case True
    note assms
    moreover note q
    moreover from True have "?b > 0" by (simp add: nonneg1_imp_zdiv_pos_iff)
    moreover note coprime
    ultimately show C .
  next
    case False
    note assms
    moreover have "q = Fract (- ?a) (- ?b)" unfolding q by transfer simp
    moreover from False `b \<noteq> 0` have "- ?b > 0" by (simp add: pos_imp_zdiv_neg_iff)
    moreover from coprime have "coprime (- ?a) (- ?b)" by simp
    ultimately show C .
  qed
qed

lemma Rat_induct [case_names Fract, induct type: rat]:
  assumes "\<And>a b. b > 0 \<Longrightarrow> coprime a b \<Longrightarrow> P (Fract a b)"
  shows "P q"
  using assms by (cases q) simp

instantiation rat :: field_inverse_zero
begin

lift_definition zero_rat :: "rat" is "(0, 1)"
  by simp

lift_definition one_rat :: "rat" is "(1, 1)"
  by simp

lemma Zero_rat_def: "0 = Fract 0 1"
  by transfer simp

lemma One_rat_def: "1 = Fract 1 1"
  by transfer simp

lift_definition plus_rat :: "rat \<Rightarrow> rat \<Rightarrow> rat"
  is "\<lambda>x y. (fst x * snd y + fst y * snd x, snd x * snd y)"
  by (clarsimp, simp add: distrib_right, simp add: ac_simps)

lemma add_rat [simp]:
  assumes "b \<noteq> 0" and "d \<noteq> 0"
  shows "Fract a b + Fract c d = Fract (a * d + c * b) (b * d)"
  using assms by transfer simp

lift_definition uminus_rat :: "rat \<Rightarrow> rat" is "\<lambda>x. (- fst x, snd x)"
  by simp

lemma minus_rat [simp]: "- Fract a b = Fract (- a) b"
  by transfer simp

lemma minus_rat_cancel [simp]: "Fract (- a) (- b) = Fract a b"
  by (cases "b = 0") (simp_all add: eq_rat)

definition
  diff_rat_def: "q - r = q + - (r::rat)"

lemma diff_rat [simp]:
  assumes "b \<noteq> 0" and "d \<noteq> 0"
  shows "Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
  using assms by (simp add: diff_rat_def)

lift_definition times_rat :: "rat \<Rightarrow> rat \<Rightarrow> rat"
  is "\<lambda>x y. (fst x * fst y, snd x * snd y)"
  by (simp add: ac_simps)

lemma mult_rat [simp]: "Fract a b * Fract c d = Fract (a * c) (b * d)"
  by transfer simp

lemma mult_rat_cancel:
  assumes "c \<noteq> 0"
  shows "Fract (c * a) (c * b) = Fract a b"
  using assms by transfer simp

lift_definition inverse_rat :: "rat \<Rightarrow> rat"
  is "\<lambda>x. if fst x = 0 then (0, 1) else (snd x, fst x)"
  by (auto simp add: mult.commute)

lemma inverse_rat [simp]: "inverse (Fract a b) = Fract b a"
  by transfer simp

definition
  divide_rat_def: "q / r = q * inverse (r::rat)"

lemma divide_rat [simp]: "Fract a b / Fract c d = Fract (a * d) (b * c)"
  by (simp add: divide_rat_def)

instance proof
  fix q r s :: rat
  show "(q * r) * s = q * (r * s)"
    by transfer simp
  show "q * r = r * q"
    by transfer simp
  show "1 * q = q"
    by transfer simp
  show "(q + r) + s = q + (r + s)"
    by transfer (simp add: algebra_simps)
  show "q + r = r + q"
    by transfer simp
  show "0 + q = q"
    by transfer simp
  show "- q + q = 0"
    by transfer simp
  show "q - r = q + - r"
    by (fact diff_rat_def)
  show "(q + r) * s = q * s + r * s"
    by transfer (simp add: algebra_simps)
  show "(0::rat) \<noteq> 1"
    by transfer simp
  { assume "q \<noteq> 0" thus "inverse q * q = 1"
    by transfer simp }
  show "q / r = q * inverse r"
    by (fact divide_rat_def)
  show "inverse 0 = (0::rat)"
    by transfer simp
qed

end

lemma of_nat_rat: "of_nat k = Fract (of_nat k) 1"
  by (induct k) (simp_all add: Zero_rat_def One_rat_def)

lemma of_int_rat: "of_int k = Fract k 1"
  by (cases k rule: int_diff_cases) (simp add: of_nat_rat)

lemma Fract_of_nat_eq: "Fract (of_nat k) 1 = of_nat k"
  by (rule of_nat_rat [symmetric])

lemma Fract_of_int_eq: "Fract k 1 = of_int k"
  by (rule of_int_rat [symmetric])

lemma rat_number_collapse:
  "Fract 0 k = 0"
  "Fract 1 1 = 1"
  "Fract (numeral w) 1 = numeral w"
  "Fract (- numeral w) 1 = - numeral w"
  "Fract (- 1) 1 = - 1"
  "Fract k 0 = 0"
  using Fract_of_int_eq [of "numeral w"]
  using Fract_of_int_eq [of "- numeral w"]
  by (simp_all add: Zero_rat_def One_rat_def eq_rat)

lemma rat_number_expand:
  "0 = Fract 0 1"
  "1 = Fract 1 1"
  "numeral k = Fract (numeral k) 1"
  "- 1 = Fract (- 1) 1"
  "- numeral k = Fract (- numeral k) 1"
  by (simp_all add: rat_number_collapse)

lemma Rat_cases_nonzero [case_names Fract 0]:
  assumes Fract: "\<And>a b. q = Fract a b \<Longrightarrow> b > 0 \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> C"
  assumes 0: "q = 0 \<Longrightarrow> C"
  shows C
proof (cases "q = 0")
  case True then show C using 0 by auto
next
  case False
  then obtain a b where "q = Fract a b" and "b > 0" and "coprime a b" by (cases q) auto
  with False have "0 \<noteq> Fract a b" by simp
  with `b > 0` have "a \<noteq> 0" by (simp add: Zero_rat_def eq_rat)
  with Fract `q = Fract a b` `b > 0` `coprime a b` show C by blast
qed

subsubsection {* Function @{text normalize} *}

lemma Fract_coprime: "Fract (a div gcd a b) (b div gcd a b) = Fract a b"
proof (cases "b = 0")
  case True then show ?thesis by (simp add: eq_rat)
next
  case False
  moreover have "b div gcd a b * gcd a b = b"
    by (rule dvd_div_mult_self) simp
  ultimately have "b div gcd a b * gcd a b \<noteq> 0" by simp
  then have "b div gcd a b \<noteq> 0" by fastforce
  with False show ?thesis by (simp add: eq_rat dvd_div_mult mult.commute [of a])
qed

definition normalize :: "int \<times> int \<Rightarrow> int \<times> int" where
  "normalize p = (if snd p > 0 then (let a = gcd (fst p) (snd p) in (fst p div a, snd p div a))
    else if snd p = 0 then (0, 1)
    else (let a = - gcd (fst p) (snd p) in (fst p div a, snd p div a)))"

lemma normalize_crossproduct:
  assumes "q \<noteq> 0" "s \<noteq> 0"
  assumes "normalize (p, q) = normalize (r, s)"
  shows "p * s = r * q"
proof -
  have aux: "p * gcd r s = sgn (q * s) * r * gcd p q \<Longrightarrow> q * gcd r s = sgn (q * s) * s * gcd p q \<Longrightarrow> p * s = q * r"
  proof -
    assume "p * gcd r s = sgn (q * s) * r * gcd p q" and "q * gcd r s = sgn (q * s) * s * gcd p q"
    then have "(p * gcd r s) * (sgn (q * s) * s * gcd p q) = (q * gcd r s) * (sgn (q * s) * r * gcd p q)" by simp
    with assms show "p * s = q * r" by (auto simp add: ac_simps sgn_times sgn_0_0)
  qed
  from assms show ?thesis
    by (auto simp add: normalize_def Let_def dvd_div_div_eq_mult mult.commute sgn_times split: if_splits intro: aux)
qed

lemma normalize_eq: "normalize (a, b) = (p, q) \<Longrightarrow> Fract p q = Fract a b"
  by (auto simp add: normalize_def Let_def Fract_coprime dvd_div_neg rat_number_collapse
    split:split_if_asm)

lemma normalize_denom_pos: "normalize r = (p, q) \<Longrightarrow> q > 0"
  by (auto simp add: normalize_def Let_def dvd_div_neg pos_imp_zdiv_neg_iff nonneg1_imp_zdiv_pos_iff
    split:split_if_asm)

lemma normalize_coprime: "normalize r = (p, q) \<Longrightarrow> coprime p q"
  by (auto simp add: normalize_def Let_def dvd_div_neg div_gcd_coprime_int
    split:split_if_asm)

lemma normalize_stable [simp]:
  "q > 0 \<Longrightarrow> coprime p q \<Longrightarrow> normalize (p, q) = (p, q)"
  by (simp add: normalize_def)

lemma normalize_denom_zero [simp]:
  "normalize (p, 0) = (0, 1)"
  by (simp add: normalize_def)

lemma normalize_negative [simp]:
  "q < 0 \<Longrightarrow> normalize (p, q) = normalize (- p, - q)"
  by (simp add: normalize_def Let_def dvd_div_neg dvd_neg_div)

text{*
  Decompose a fraction into normalized, i.e. coprime numerator and denominator:
*}

definition quotient_of :: "rat \<Rightarrow> int \<times> int" where
  "quotient_of x = (THE pair. x = Fract (fst pair) (snd pair) &
                   snd pair > 0 & coprime (fst pair) (snd pair))"

lemma quotient_of_unique:
  "\<exists>!p. r = Fract (fst p) (snd p) \<and> snd p > 0 \<and> coprime (fst p) (snd p)"
proof (cases r)
  case (Fract a b)
  then have "r = Fract (fst (a, b)) (snd (a, b)) \<and> snd (a, b) > 0 \<and> coprime (fst (a, b)) (snd (a, b))" by auto
  then show ?thesis proof (rule ex1I)
    fix p
    obtain c d :: int where p: "p = (c, d)" by (cases p)
    assume "r = Fract (fst p) (snd p) \<and> snd p > 0 \<and> coprime (fst p) (snd p)"
    with p have Fract': "r = Fract c d" "d > 0" "coprime c d" by simp_all
    have "c = a \<and> d = b"
    proof (cases "a = 0")
      case True with Fract Fract' show ?thesis by (simp add: eq_rat)
    next
      case False
      with Fract Fract' have *: "c * b = a * d" and "c \<noteq> 0" by (auto simp add: eq_rat)
      then have "c * b > 0 \<longleftrightarrow> a * d > 0" by auto
      with `b > 0` `d > 0` have "a > 0 \<longleftrightarrow> c > 0" by (simp add: zero_less_mult_iff)
      with `a \<noteq> 0` `c \<noteq> 0` have sgn: "sgn a = sgn c" by (auto simp add: not_less)
      from `coprime a b` `coprime c d` have "\<bar>a\<bar> * \<bar>d\<bar> = \<bar>c\<bar> * \<bar>b\<bar> \<longleftrightarrow> \<bar>a\<bar> = \<bar>c\<bar> \<and> \<bar>d\<bar> = \<bar>b\<bar>"
        by (simp add: coprime_crossproduct_int)
      with `b > 0` `d > 0` have "\<bar>a\<bar> * d = \<bar>c\<bar> * b \<longleftrightarrow> \<bar>a\<bar> = \<bar>c\<bar> \<and> d = b" by simp
      then have "a * sgn a * d = c * sgn c * b \<longleftrightarrow> a * sgn a = c * sgn c \<and> d = b" by (simp add: abs_sgn)
      with sgn * show ?thesis by (auto simp add: sgn_0_0)
    qed
    with p show "p = (a, b)" by simp
  qed
qed

lemma quotient_of_Fract [code]:
  "quotient_of (Fract a b) = normalize (a, b)"
proof -
  have "Fract a b = Fract (fst (normalize (a, b))) (snd (normalize (a, b)))" (is ?Fract)
    by (rule sym) (auto intro: normalize_eq)
  moreover have "0 < snd (normalize (a, b))" (is ?denom_pos)
    by (cases "normalize (a, b)") (rule normalize_denom_pos, simp)
  moreover have "coprime (fst (normalize (a, b))) (snd (normalize (a, b)))" (is ?coprime)
    by (rule normalize_coprime) simp
  ultimately have "?Fract \<and> ?denom_pos \<and> ?coprime" by blast
  with quotient_of_unique have
    "(THE p. Fract a b = Fract (fst p) (snd p) \<and> 0 < snd p \<and> coprime (fst p) (snd p)) = normalize (a, b)"
    by (rule the1_equality)
  then show ?thesis by (simp add: quotient_of_def)
qed

lemma quotient_of_number [simp]:
  "quotient_of 0 = (0, 1)"
  "quotient_of 1 = (1, 1)"
  "quotient_of (numeral k) = (numeral k, 1)"
  "quotient_of (- 1) = (- 1, 1)"
  "quotient_of (- numeral k) = (- numeral k, 1)"
  by (simp_all add: rat_number_expand quotient_of_Fract)

lemma quotient_of_eq: "quotient_of (Fract a b) = (p, q) \<Longrightarrow> Fract p q = Fract a b"
  by (simp add: quotient_of_Fract normalize_eq)

lemma quotient_of_denom_pos: "quotient_of r = (p, q) \<Longrightarrow> q > 0"
  by (cases r) (simp add: quotient_of_Fract normalize_denom_pos)

lemma quotient_of_coprime: "quotient_of r = (p, q) \<Longrightarrow> coprime p q"
  by (cases r) (simp add: quotient_of_Fract normalize_coprime)

lemma quotient_of_inject:
  assumes "quotient_of a = quotient_of b"
  shows "a = b"
proof -
  obtain p q r s where a: "a = Fract p q"
    and b: "b = Fract r s"
    and "q > 0" and "s > 0" by (cases a, cases b)
  with assms show ?thesis by (simp add: eq_rat quotient_of_Fract normalize_crossproduct)
qed

lemma quotient_of_inject_eq:
  "quotient_of a = quotient_of b \<longleftrightarrow> a = b"
  by (auto simp add: quotient_of_inject)

subsubsection {* Various *}

lemma Fract_of_int_quotient: "Fract k l = of_int k / of_int l"
  by (simp add: Fract_of_int_eq [symmetric])

lemma Fract_add_one: "n \<noteq> 0 ==> Fract (m + n) n = Fract m n + 1"
  by (simp add: rat_number_expand)

lemma quotient_of_div:
  assumes r: "quotient_of r = (n,d)"
  shows "r = of_int n / of_int d"
proof -
  from theI'[OF quotient_of_unique[of r], unfolded r[unfolded quotient_of_def]]
  have "r = Fract n d" by simp
  thus ?thesis using Fract_of_int_quotient by simp
qed

subsubsection {* The ordered field of rational numbers *}

lift_definition positive :: "rat \<Rightarrow> bool"
  is "\<lambda>x. 0 < fst x * snd x"
proof (clarsimp)
  fix a b c d :: int
  assume "b \<noteq> 0" and "d \<noteq> 0" and "a * d = c * b"
  hence "a * d * b * d = c * b * b * d"
    by simp
  hence "a * b * d\<^sup>2 = c * d * b\<^sup>2"
    unfolding power2_eq_square by (simp add: ac_simps)
  hence "0 < a * b * d\<^sup>2 \<longleftrightarrow> 0 < c * d * b\<^sup>2"
    by simp
  thus "0 < a * b \<longleftrightarrow> 0 < c * d"
    using `b \<noteq> 0` and `d \<noteq> 0`
    by (simp add: zero_less_mult_iff)
qed

lemma positive_zero: "\<not> positive 0"
  by transfer simp

lemma positive_add:
  "positive x \<Longrightarrow> positive y \<Longrightarrow> positive (x + y)"
apply transfer
apply (simp add: zero_less_mult_iff)
apply (elim disjE, simp_all add: add_pos_pos add_neg_neg
  mult_pos_neg mult_neg_pos mult_neg_neg)
done

lemma positive_mult:
  "positive x \<Longrightarrow> positive y \<Longrightarrow> positive (x * y)"
by transfer (drule (1) mult_pos_pos, simp add: ac_simps)

lemma positive_minus:
  "\<not> positive x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> positive (- x)"
by transfer (force simp: neq_iff zero_less_mult_iff mult_less_0_iff)

instantiation rat :: linordered_field_inverse_zero
begin

definition
  "x < y \<longleftrightarrow> positive (y - x)"

definition
  "x \<le> (y::rat) \<longleftrightarrow> x < y \<or> x = y"

definition
  "abs (a::rat) = (if a < 0 then - a else a)"

definition
  "sgn (a::rat) = (if a = 0 then 0 else if 0 < a then 1 else - 1)"

instance proof
  fix a b c :: rat
  show "\<bar>a\<bar> = (if a < 0 then - a else a)"
    by (rule abs_rat_def)
  show "a < b \<longleftrightarrow> a \<le> b \<and> \<not> b \<le> a"
    unfolding less_eq_rat_def less_rat_def
    by (auto, drule (1) positive_add, simp_all add: positive_zero)
  show "a \<le> a"
    unfolding less_eq_rat_def by simp
  show "a \<le> b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
    unfolding less_eq_rat_def less_rat_def
    by (auto, drule (1) positive_add, simp add: algebra_simps)
  show "a \<le> b \<Longrightarrow> b \<le> a \<Longrightarrow> a = b"
    unfolding less_eq_rat_def less_rat_def
    by (auto, drule (1) positive_add, simp add: positive_zero)
  show "a \<le> b \<Longrightarrow> c + a \<le> c + b"
    unfolding less_eq_rat_def less_rat_def by auto
  show "sgn a = (if a = 0 then 0 else if 0 < a then 1 else - 1)"
    by (rule sgn_rat_def)
  show "a \<le> b \<or> b \<le> a"
    unfolding less_eq_rat_def less_rat_def
    by (auto dest!: positive_minus)
  show "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
    unfolding less_rat_def
    by (drule (1) positive_mult, simp add: algebra_simps)
qed

end

instantiation rat :: distrib_lattice
begin

definition
  "(inf :: rat \<Rightarrow> rat \<Rightarrow> rat) = min"

definition
  "(sup :: rat \<Rightarrow> rat \<Rightarrow> rat) = max"

instance proof
qed (auto simp add: inf_rat_def sup_rat_def max_min_distrib2)

end

lemma positive_rat: "positive (Fract a b) \<longleftrightarrow> 0 < a * b"
  by transfer simp

lemma less_rat [simp]:
  assumes "b \<noteq> 0" and "d \<noteq> 0"
  shows "Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
  using assms unfolding less_rat_def
  by (simp add: positive_rat algebra_simps)

lemma le_rat [simp]:
  assumes "b \<noteq> 0" and "d \<noteq> 0"
  shows "Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
  using assms unfolding le_less by (simp add: eq_rat)

lemma abs_rat [simp, code]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
  by (auto simp add: abs_rat_def zabs_def Zero_rat_def not_less le_less eq_rat zero_less_mult_iff)

lemma sgn_rat [simp, code]: "sgn (Fract a b) = of_int (sgn a * sgn b)"
  unfolding Fract_of_int_eq
  by (auto simp: zsgn_def sgn_rat_def Zero_rat_def eq_rat)
    (auto simp: rat_number_collapse not_less le_less zero_less_mult_iff)

lemma Rat_induct_pos [case_names Fract, induct type: rat]:
  assumes step: "\<And>a b. 0 < b \<Longrightarrow> P (Fract a b)"
  shows "P q"
proof (cases q)
  have step': "\<And>a b. b < 0 \<Longrightarrow> P (Fract a b)"
  proof -
    fix a::int and b::int
    assume b: "b < 0"
    hence "0 < -b" by simp
    hence "P (Fract (-a) (-b))" by (rule step)
    thus "P (Fract a b)" by (simp add: order_less_imp_not_eq [OF b])
  qed
  case (Fract a b)
  thus "P q" by (force simp add: linorder_neq_iff step step')
qed

lemma zero_less_Fract_iff:
  "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
  by (simp add: Zero_rat_def zero_less_mult_iff)

lemma Fract_less_zero_iff:
  "0 < b \<Longrightarrow> Fract a b < 0 \<longleftrightarrow> a < 0"
  by (simp add: Zero_rat_def mult_less_0_iff)

lemma zero_le_Fract_iff:
  "0 < b \<Longrightarrow> 0 \<le> Fract a b \<longleftrightarrow> 0 \<le> a"
  by (simp add: Zero_rat_def zero_le_mult_iff)

lemma Fract_le_zero_iff:
  "0 < b \<Longrightarrow> Fract a b \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (simp add: Zero_rat_def mult_le_0_iff)

lemma one_less_Fract_iff:
  "0 < b \<Longrightarrow> 1 < Fract a b \<longleftrightarrow> b < a"
  by (simp add: One_rat_def mult_less_cancel_right_disj)

lemma Fract_less_one_iff:
  "0 < b \<Longrightarrow> Fract a b < 1 \<longleftrightarrow> a < b"
  by (simp add: One_rat_def mult_less_cancel_right_disj)

lemma one_le_Fract_iff:
  "0 < b \<Longrightarrow> 1 \<le> Fract a b \<longleftrightarrow> b \<le> a"
  by (simp add: One_rat_def mult_le_cancel_right)

lemma Fract_le_one_iff:
  "0 < b \<Longrightarrow> Fract a b \<le> 1 \<longleftrightarrow> a \<le> b"
  by (simp add: One_rat_def mult_le_cancel_right)

subsubsection {* Rationals are an Archimedean field *}

lemma rat_floor_lemma:
  shows "of_int (a div b) \<le> Fract a b \<and> Fract a b < of_int (a div b + 1)"
proof -
  have "Fract a b = of_int (a div b) + Fract (a mod b) b"
    by (cases "b = 0", simp, simp add: of_int_rat)
  moreover have "0 \<le> Fract (a mod b) b \<and> Fract (a mod b) b < 1"
    unfolding Fract_of_int_quotient
    by (rule linorder_cases [of b 0]) (simp_all add: divide_nonpos_neg)
  ultimately show ?thesis by simp
qed

instance rat :: archimedean_field
proof
  fix r :: rat
  show "\<exists>z. r \<le> of_int z"
  proof (induct r)
    case (Fract a b)
    have "Fract a b \<le> of_int (a div b + 1)"
      using rat_floor_lemma [of a b] by simp
    then show "\<exists>z. Fract a b \<le> of_int z" ..
  qed
qed

instantiation rat :: floor_ceiling
begin

definition [code del]:
  "floor (x::rat) = (THE z. of_int z \<le> x \<and> x < of_int (z + 1))"

instance proof
  fix x :: rat
  show "of_int (floor x) \<le> x \<and> x < of_int (floor x + 1)"
    unfolding floor_rat_def using floor_exists1 by (rule theI')
qed

end

lemma floor_Fract: "floor (Fract a b) = a div b"
  using rat_floor_lemma [of a b]
  by (simp add: floor_unique)

subsection {* Linear arithmetic setup *}

declaration {*
  K (Lin_Arith.add_inj_thms [@{thm of_nat_le_iff} RS iffD2, @{thm of_nat_eq_iff} RS iffD2]
    (* not needed because x < (y::nat) can be rewritten as Suc x <= y: of_nat_less_iff RS iffD2 *)
  #> Lin_Arith.add_inj_thms [@{thm of_int_le_iff} RS iffD2, @{thm of_int_eq_iff} RS iffD2]
    (* not needed because x < (y::int) can be rewritten as x + 1 <= y: of_int_less_iff RS iffD2 *)
  #> Lin_Arith.add_simps [@{thm neg_less_iff_less},
      @{thm True_implies_equals},
      @{thm distrib_left [where a = "numeral v" for v]},
      @{thm distrib_left [where a = "- numeral v" for v]},
      @{thm divide_1}, @{thm divide_zero_left},
      @{thm times_divide_eq_right}, @{thm times_divide_eq_left},
      @{thm minus_divide_left} RS sym, @{thm minus_divide_right} RS sym,
      @{thm of_int_minus}, @{thm of_int_diff},
      @{thm of_int_of_nat_eq}]
  #> Lin_Arith.add_simprocs Numeral_Simprocs.field_divide_cancel_numeral_factor
  #> Lin_Arith.add_inj_const (@{const_name of_nat}, @{typ "nat => rat"})
  #> Lin_Arith.add_inj_const (@{const_name of_int}, @{typ "int => rat"}))
*}

subsection {* Embedding from Rationals to other Fields *}

class field_char_0 = field + ring_char_0

subclass (in linordered_field) field_char_0 ..

context field_char_0
begin

lift_definition of_rat :: "rat \<Rightarrow> 'a"
  is "\<lambda>x. of_int (fst x) / of_int (snd x)"
apply (clarsimp simp add: nonzero_divide_eq_eq nonzero_eq_divide_eq)
apply (simp only: of_int_mult [symmetric])
done

end

lemma of_rat_rat: "b \<noteq> 0 \<Longrightarrow> of_rat (Fract a b) = of_int a / of_int b"
  by transfer simp

lemma of_rat_0 [simp]: "of_rat 0 = 0"
  by transfer simp

lemma of_rat_1 [simp]: "of_rat 1 = 1"
  by transfer simp

lemma of_rat_add: "of_rat (a + b) = of_rat a + of_rat b"
  by transfer (simp add: add_frac_eq)

lemma of_rat_minus: "of_rat (- a) = - of_rat a"
  by transfer simp

lemma of_rat_neg_one [simp]:
  "of_rat (- 1) = - 1"
  by (simp add: of_rat_minus)

lemma of_rat_diff: "of_rat (a - b) = of_rat a - of_rat b"
  using of_rat_add [of a "- b"] by (simp add: of_rat_minus)

lemma of_rat_mult: "of_rat (a * b) = of_rat a * of_rat b"
apply transfer
apply (simp add: divide_inverse nonzero_inverse_mult_distrib ac_simps)
done

lemma of_rat_setsum: "of_rat (\<Sum>a\<in>A. f a) = (\<Sum>a\<in>A. of_rat (f a))"
  by (induct rule: infinite_finite_induct) (auto simp: of_rat_add)

lemma of_rat_setprod: "of_rat (\<Prod>a\<in>A. f a) = (\<Prod>a\<in>A. of_rat (f a))"
  by (induct rule: infinite_finite_induct) (auto simp: of_rat_mult)

lemma nonzero_of_rat_inverse:
  "a \<noteq> 0 \<Longrightarrow> of_rat (inverse a) = inverse (of_rat a)"
apply (rule inverse_unique [symmetric])
apply (simp add: of_rat_mult [symmetric])
done

lemma of_rat_inverse:
  "(of_rat (inverse a)::'a::{field_char_0, field_inverse_zero}) =
   inverse (of_rat a)"
by (cases "a = 0", simp_all add: nonzero_of_rat_inverse)

lemma nonzero_of_rat_divide:
  "b \<noteq> 0 \<Longrightarrow> of_rat (a / b) = of_rat a / of_rat b"
by (simp add: divide_inverse of_rat_mult nonzero_of_rat_inverse)

lemma of_rat_divide:
  "(of_rat (a / b)::'a::{field_char_0, field_inverse_zero})
   = of_rat a / of_rat b"
by (cases "b = 0") (simp_all add: nonzero_of_rat_divide)

lemma of_rat_power:
  "(of_rat (a ^ n)::'a::field_char_0) = of_rat a ^ n"
by (induct n) (simp_all add: of_rat_mult)

lemma of_rat_eq_iff [simp]: "(of_rat a = of_rat b) = (a = b)"
apply transfer
apply (simp add: nonzero_divide_eq_eq nonzero_eq_divide_eq)
apply (simp only: of_int_mult [symmetric] of_int_eq_iff)
done

lemma of_rat_eq_0_iff [simp]: "(of_rat a = 0) = (a = 0)"
  using of_rat_eq_iff [of _ 0] by simp

lemma zero_eq_of_rat_iff [simp]: "(0 = of_rat a) = (0 = a)"
  by simp

lemma of_rat_eq_1_iff [simp]: "(of_rat a = 1) = (a = 1)"
  using of_rat_eq_iff [of _ 1] by simp

lemma one_eq_of_rat_iff [simp]: "(1 = of_rat a) = (1 = a)"
  by simp

lemma of_rat_less:
  "(of_rat r :: 'a::linordered_field) < of_rat s \<longleftrightarrow> r < s"
proof (induct r, induct s)
  fix a b c d :: int
  assume not_zero: "b > 0" "d > 0"
  then have "b * d > 0" by simp
  have of_int_divide_less_eq:
    "(of_int a :: 'a) / of_int b < of_int c / of_int d
      \<longleftrightarrow> (of_int a :: 'a) * of_int d < of_int c * of_int b"
    using not_zero by (simp add: pos_less_divide_eq pos_divide_less_eq)
  show "(of_rat (Fract a b) :: 'a::linordered_field) < of_rat (Fract c d)
    \<longleftrightarrow> Fract a b < Fract c d"
    using not_zero `b * d > 0`
    by (simp add: of_rat_rat of_int_divide_less_eq of_int_mult [symmetric] del: of_int_mult)
qed

lemma of_rat_less_eq:
  "(of_rat r :: 'a::linordered_field) \<le> of_rat s \<longleftrightarrow> r \<le> s"
  unfolding le_less by (auto simp add: of_rat_less)

lemma of_rat_le_0_iff [simp]: "((of_rat r :: 'a::linordered_field) \<le> 0) = (r \<le> 0)"
  using of_rat_less_eq [of r 0, where 'a='a] by simp

lemma zero_le_of_rat_iff [simp]: "(0 \<le> (of_rat r :: 'a::linordered_field)) = (0 \<le> r)"
  using of_rat_less_eq [of 0 r, where 'a='a] by simp

lemma of_rat_le_1_iff [simp]: "((of_rat r :: 'a::linordered_field) \<le> 1) = (r \<le> 1)"
  using of_rat_less_eq [of r 1] by simp

lemma one_le_of_rat_iff [simp]: "(1 \<le> (of_rat r :: 'a::linordered_field)) = (1 \<le> r)"
  using of_rat_less_eq [of 1 r] by simp

lemma of_rat_less_0_iff [simp]: "((of_rat r :: 'a::linordered_field) < 0) = (r < 0)"
  using of_rat_less [of r 0, where 'a='a] by simp

lemma zero_less_of_rat_iff [simp]: "(0 < (of_rat r :: 'a::linordered_field)) = (0 < r)"
  using of_rat_less [of 0 r, where 'a='a] by simp

lemma of_rat_less_1_iff [simp]: "((of_rat r :: 'a::linordered_field) < 1) = (r < 1)"
  using of_rat_less [of r 1] by simp

lemma one_less_of_rat_iff [simp]: "(1 < (of_rat r :: 'a::linordered_field)) = (1 < r)"
  using of_rat_less [of 1 r] by simp

lemma of_rat_eq_id [simp]: "of_rat = id"
proof
  fix a
  show "of_rat a = id a"
  by (induct a)
     (simp add: of_rat_rat Fract_of_int_eq [symmetric])
qed

text{*Collapse nested embeddings*}
lemma of_rat_of_nat_eq [simp]: "of_rat (of_nat n) = of_nat n"
by (induct n) (simp_all add: of_rat_add)

lemma of_rat_of_int_eq [simp]: "of_rat (of_int z) = of_int z"
by (cases z rule: int_diff_cases) (simp add: of_rat_diff)

lemma of_rat_numeral_eq [simp]:
  "of_rat (numeral w) = numeral w"
using of_rat_of_int_eq [of "numeral w"] by simp

lemma of_rat_neg_numeral_eq [simp]:
  "of_rat (- numeral w) = - numeral w"
using of_rat_of_int_eq [of "- numeral w"] by simp

lemmas zero_rat = Zero_rat_def
lemmas one_rat = One_rat_def

abbreviation
  rat_of_nat :: "nat \<Rightarrow> rat"
where
  "rat_of_nat \<equiv> of_nat"

abbreviation
  rat_of_int :: "int \<Rightarrow> rat"
where
  "rat_of_int \<equiv> of_int"

subsection {* The Set of Rational Numbers *}

context field_char_0
begin

definition
  Rats  :: "'a set" where
  "Rats = range of_rat"

notation (xsymbols)
  Rats  ("\<rat>")

end

lemma Rats_of_rat [simp]: "of_rat r \<in> Rats"
by (simp add: Rats_def)

lemma Rats_of_int [simp]: "of_int z \<in> Rats"
by (subst of_rat_of_int_eq [symmetric], rule Rats_of_rat)

lemma Rats_of_nat [simp]: "of_nat n \<in> Rats"
by (subst of_rat_of_nat_eq [symmetric], rule Rats_of_rat)

lemma Rats_number_of [simp]: "numeral w \<in> Rats"
by (subst of_rat_numeral_eq [symmetric], rule Rats_of_rat)

lemma Rats_0 [simp]: "0 \<in> Rats"
apply (unfold Rats_def)
apply (rule range_eqI)
apply (rule of_rat_0 [symmetric])
done

lemma Rats_1 [simp]: "1 \<in> Rats"
apply (unfold Rats_def)
apply (rule range_eqI)
apply (rule of_rat_1 [symmetric])
done

lemma Rats_add [simp]: "\<lbrakk>a \<in> Rats; b \<in> Rats\<rbrakk> \<Longrightarrow> a + b \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_add [symmetric])
done

lemma Rats_minus [simp]: "a \<in> Rats \<Longrightarrow> - a \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_minus [symmetric])
done

lemma Rats_diff [simp]: "\<lbrakk>a \<in> Rats; b \<in> Rats\<rbrakk> \<Longrightarrow> a - b \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_diff [symmetric])
done

lemma Rats_mult [simp]: "\<lbrakk>a \<in> Rats; b \<in> Rats\<rbrakk> \<Longrightarrow> a * b \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_mult [symmetric])
done

lemma nonzero_Rats_inverse:
  fixes a :: "'a::field_char_0"
  shows "\<lbrakk>a \<in> Rats; a \<noteq> 0\<rbrakk> \<Longrightarrow> inverse a \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (erule nonzero_of_rat_inverse [symmetric])
done

lemma Rats_inverse [simp]:
  fixes a :: "'a::{field_char_0, field_inverse_zero}"
  shows "a \<in> Rats \<Longrightarrow> inverse a \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_inverse [symmetric])
done

lemma nonzero_Rats_divide:
  fixes a b :: "'a::field_char_0"
  shows "\<lbrakk>a \<in> Rats; b \<in> Rats; b \<noteq> 0\<rbrakk> \<Longrightarrow> a / b \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (erule nonzero_of_rat_divide [symmetric])
done

lemma Rats_divide [simp]:
  fixes a b :: "'a::{field_char_0, field_inverse_zero}"
  shows "\<lbrakk>a \<in> Rats; b \<in> Rats\<rbrakk> \<Longrightarrow> a / b \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_divide [symmetric])
done

lemma Rats_power [simp]:
  fixes a :: "'a::field_char_0"
  shows "a \<in> Rats \<Longrightarrow> a ^ n \<in> Rats"
apply (auto simp add: Rats_def)
apply (rule range_eqI)
apply (rule of_rat_power [symmetric])
done

lemma Rats_cases [cases set: Rats]:
  assumes "q \<in> \<rat>"
  obtains (of_rat) r where "q = of_rat r"
proof -
  from `q \<in> \<rat>` have "q \<in> range of_rat" unfolding Rats_def .
  then obtain r where "q = of_rat r" ..
  then show thesis ..
qed

lemma Rats_induct [case_names of_rat, induct set: Rats]:
  "q \<in> \<rat> \<Longrightarrow> (\<And>r. P (of_rat r)) \<Longrightarrow> P q"
  by (rule Rats_cases) auto

lemma Rats_infinite: "\<not> finite \<rat>"
  by (auto dest!: finite_imageD simp: inj_on_def infinite_UNIV_char_0 Rats_def)

subsection {* Implementation of rational numbers as pairs of integers *}

text {* Formal constructor *}

definition Frct :: "int \<times> int \<Rightarrow> rat" where
  [simp]: "Frct p = Fract (fst p) (snd p)"

lemma [code abstype]:
  "Frct (quotient_of q) = q"
  by (cases q) (auto intro: quotient_of_eq)

text {* Numerals *}

declare quotient_of_Fract [code abstract]

definition of_int :: "int \<Rightarrow> rat"
where
  [code_abbrev]: "of_int = Int.of_int"
hide_const (open) of_int

lemma quotient_of_int [code abstract]:
  "quotient_of (Rat.of_int a) = (a, 1)"
  by (simp add: of_int_def of_int_rat quotient_of_Fract)

lemma [code_unfold]:
  "numeral k = Rat.of_int (numeral k)"
  by (simp add: Rat.of_int_def)

lemma [code_unfold]:
  "- numeral k = Rat.of_int (- numeral k)"
  by (simp add: Rat.of_int_def)

lemma Frct_code_post [code_post]:
  "Frct (0, a) = 0"
  "Frct (a, 0) = 0"
  "Frct (1, 1) = 1"
  "Frct (numeral k, 1) = numeral k"
  "Frct (1, numeral k) = 1 / numeral k"
  "Frct (numeral k, numeral l) = numeral k / numeral l"
  "Frct (- a, b) = - Frct (a, b)"
  "Frct (a, - b) = - Frct (a, b)"
  "- (- Frct q) = Frct q"
  by (simp_all add: Fract_of_int_quotient)

text {* Operations *}

lemma rat_zero_code [code abstract]:
  "quotient_of 0 = (0, 1)"
  by (simp add: Zero_rat_def quotient_of_Fract normalize_def)

lemma rat_one_code [code abstract]:
  "quotient_of 1 = (1, 1)"
  by (simp add: One_rat_def quotient_of_Fract normalize_def)

lemma rat_plus_code [code abstract]:
  "quotient_of (p + q) = (let (a, c) = quotient_of p; (b, d) = quotient_of q
     in normalize (a * d + b * c, c * d))"
  by (cases p, cases q) (simp add: quotient_of_Fract)

lemma rat_uminus_code [code abstract]:
  "quotient_of (- p) = (let (a, b) = quotient_of p in (- a, b))"
  by (cases p) (simp add: quotient_of_Fract)

lemma rat_minus_code [code abstract]:
  "quotient_of (p - q) = (let (a, c) = quotient_of p; (b, d) = quotient_of q
     in normalize (a * d - b * c, c * d))"
  by (cases p, cases q) (simp add: quotient_of_Fract)

lemma rat_times_code [code abstract]:
  "quotient_of (p * q) = (let (a, c) = quotient_of p; (b, d) = quotient_of q
     in normalize (a * b, c * d))"
  by (cases p, cases q) (simp add: quotient_of_Fract)

lemma rat_inverse_code [code abstract]:
  "quotient_of (inverse p) = (let (a, b) = quotient_of p
    in if a = 0 then (0, 1) else (sgn a * b, \<bar>a\<bar>))"
proof (cases p)
  case (Fract a b) then show ?thesis
    by (cases "0::int" a rule: linorder_cases) (simp_all add: quotient_of_Fract gcd_int.commute)
qed

lemma rat_divide_code [code abstract]:
  "quotient_of (p / q) = (let (a, c) = quotient_of p; (b, d) = quotient_of q
     in normalize (a * d, c * b))"
  by (cases p, cases q) (simp add: quotient_of_Fract)

lemma rat_abs_code [code abstract]:
  "quotient_of \<bar>p\<bar> = (let (a, b) = quotient_of p in (\<bar>a\<bar>, b))"
  by (cases p) (simp add: quotient_of_Fract)

lemma rat_sgn_code [code abstract]:
  "quotient_of (sgn p) = (sgn (fst (quotient_of p)), 1)"
proof (cases p)
  case (Fract a b) then show ?thesis
  by (cases "0::int" a rule: linorder_cases) (simp_all add: quotient_of_Fract)
qed

lemma rat_floor_code [code]:
  "floor p = (let (a, b) = quotient_of p in a div b)"
by (cases p) (simp add: quotient_of_Fract floor_Fract)

instantiation rat :: equal
begin

definition [code]:
  "HOL.equal a b \<longleftrightarrow> quotient_of a = quotient_of b"

instance proof
qed (simp add: equal_rat_def quotient_of_inject_eq)

lemma rat_eq_refl [code nbe]:
  "HOL.equal (r::rat) r \<longleftrightarrow> True"
  by (rule equal_refl)

end

lemma rat_less_eq_code [code]:
  "p \<le> q \<longleftrightarrow> (let (a, c) = quotient_of p; (b, d) = quotient_of q in a * d \<le> c * b)"
  by (cases p, cases q) (simp add: quotient_of_Fract mult.commute)

lemma rat_less_code [code]:
  "p < q \<longleftrightarrow> (let (a, c) = quotient_of p; (b, d) = quotient_of q in a * d < c * b)"
  by (cases p, cases q) (simp add: quotient_of_Fract mult.commute)

text {* Quickcheck *}

definition (in term_syntax)
  valterm_fract :: "int \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> int \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> rat \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
  [code_unfold]: "valterm_fract k l = Code_Evaluation.valtermify Fract {\<cdot>} k {\<cdot>} l"

notation fcomp (infixl "\<circ>>" 60)
notation scomp (infixl "\<circ>\<rightarrow>" 60)

instantiation rat :: random
begin

definition
  "Quickcheck_Random.random i = Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>num. Random.range i \<circ>\<rightarrow> (\<lambda>denom. Pair (
     let j = int_of_integer (integer_of_natural (denom + 1))
     in valterm_fract num (j, \<lambda>u. Code_Evaluation.term_of j))))"

instance ..

end

no_notation fcomp (infixl "\<circ>>" 60)
no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

instantiation rat :: exhaustive
begin

definition
  "exhaustive_rat f d = Quickcheck_Exhaustive.exhaustive
    (\<lambda>l. Quickcheck_Exhaustive.exhaustive (\<lambda>k. f (Fract k (int_of_integer (integer_of_natural l) + 1))) d) d"

instance ..

end

instantiation rat :: full_exhaustive
begin

definition
  "full_exhaustive_rat f d = Quickcheck_Exhaustive.full_exhaustive (%(l, _). Quickcheck_Exhaustive.full_exhaustive (%k.
     f (let j = int_of_integer (integer_of_natural l) + 1
        in valterm_fract k (j, %_. Code_Evaluation.term_of j))) d) d"

instance ..

end

instantiation rat :: partial_term_of
begin

instance ..

end

lemma [code]:
  "partial_term_of (ty :: rat itself) (Quickcheck_Narrowing.Narrowing_variable p tt) == Code_Evaluation.Free (STR ''_'') (Typerep.Typerep (STR ''Rat.rat'') [])"
  "partial_term_of (ty :: rat itself) (Quickcheck_Narrowing.Narrowing_constructor 0 [l, k]) ==
     Code_Evaluation.App (Code_Evaluation.Const (STR ''Rat.Frct'')
     (Typerep.Typerep (STR ''fun'') [Typerep.Typerep (STR ''Product_Type.prod'') [Typerep.Typerep (STR ''Int.int'') [], Typerep.Typerep (STR ''Int.int'') []],
        Typerep.Typerep (STR ''Rat.rat'') []])) (Code_Evaluation.App (Code_Evaluation.App (Code_Evaluation.Const (STR ''Product_Type.Pair'') (Typerep.Typerep (STR ''fun'') [Typerep.Typerep (STR ''Int.int'') [], Typerep.Typerep (STR ''fun'') [Typerep.Typerep (STR ''Int.int'') [], Typerep.Typerep (STR ''Product_Type.prod'') [Typerep.Typerep (STR ''Int.int'') [], Typerep.Typerep (STR ''Int.int'') []]]])) (partial_term_of (TYPE(int)) l)) (partial_term_of (TYPE(int)) k))"
by (rule partial_term_of_anything)+

instantiation rat :: narrowing
begin

definition
  "narrowing = Quickcheck_Narrowing.apply (Quickcheck_Narrowing.apply
    (Quickcheck_Narrowing.cons (%nom denom. Fract nom denom)) narrowing) narrowing"

instance ..

end

subsection {* Setup for Nitpick *}

declaration {*
  Nitpick_HOL.register_frac_type @{type_name rat}
   [(@{const_name zero_rat_inst.zero_rat}, @{const_name Nitpick.zero_frac}),
    (@{const_name one_rat_inst.one_rat}, @{const_name Nitpick.one_frac}),
    (@{const_name plus_rat_inst.plus_rat}, @{const_name Nitpick.plus_frac}),
    (@{const_name times_rat_inst.times_rat}, @{const_name Nitpick.times_frac}),
    (@{const_name uminus_rat_inst.uminus_rat}, @{const_name Nitpick.uminus_frac}),
    (@{const_name inverse_rat_inst.inverse_rat}, @{const_name Nitpick.inverse_frac}),
    (@{const_name ord_rat_inst.less_rat}, @{const_name Nitpick.less_frac}),
    (@{const_name ord_rat_inst.less_eq_rat}, @{const_name Nitpick.less_eq_frac}),
    (@{const_name field_char_0_class.of_rat}, @{const_name Nitpick.of_frac})]
*}

lemmas [nitpick_unfold] = inverse_rat_inst.inverse_rat
  one_rat_inst.one_rat ord_rat_inst.less_rat
  ord_rat_inst.less_eq_rat plus_rat_inst.plus_rat times_rat_inst.times_rat
  uminus_rat_inst.uminus_rat zero_rat_inst.zero_rat

subsection {* Float syntax *}

syntax "_Float" :: "float_const \<Rightarrow> 'a"    ("_")

parse_translation {*
  let
    fun mk_frac str =
      let
        val {mant = i, exp = n} = Lexicon.read_float str;
        val exp = Syntax.const @{const_syntax Power.power};
        val ten = Numeral.mk_number_syntax 10;
        val exp10 = if n = 1 then ten else exp $ ten $ Numeral.mk_number_syntax n;;
      in Syntax.const @{const_syntax divide} $ Numeral.mk_number_syntax i $ exp10 end;

    fun float_tr [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] = c $ float_tr [t] $ u
      | float_tr [t as Const (str, _)] = mk_frac str
      | float_tr ts = raise TERM ("float_tr", ts);
  in [(@{syntax_const "_Float"}, K float_tr)] end
*}

text{* Test: *}
lemma "123.456 = -111.111 + 200 + 30 + 4 + 5/10 + 6/100 + (7/1000::rat)"
  by simp

subsection {* Hiding implementation details *}

hide_const (open) normalize positive

lifting_update rat.lifting
lifting_forget rat.lifting

end


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

subsection\<open>Case Study: Boolean Expressions\<close>

text\<open>\label{sec:boolex}\index{boolean expressions example|(}
The aim of this case study is twofold: it shows how to model boolean
expressions and some algorithms for manipulating them, and it demonstrates
the constructs introduced above.
\<close>

subsubsection\<open>Modelling Boolean Expressions\<close>

text\<open>
We want to represent boolean expressions built up from variables and
constants by negation and conjunction. The following datatype serves exactly
that purpose:
\<close>

datatype boolex = Const bool | Var nat | Neg boolex
                | And boolex boolex

text\<open>\noindent
The two constants are represented by \<^term>\<open>Const True\<close> and
\<^term>\<open>Const False\<close>. Variables are represented by terms of the form
\<^term>\<open>Var n\<close>, where \<^term>\<open>n\<close> is a natural number (type \<^typ>\<open>nat\<close>).
For example, the formula $P@0 \land \neg P@1$ is represented by the term
\<^term>\<open>And (Var 0) (Neg(Var 1))\<close>.

\subsubsection{The Value of a Boolean Expression}

The value of a boolean expression depends on the value of its variables.
Hence the function \<open>value\<close> takes an additional parameter, an
\emph{environment} of type \<^typ>\<open>nat => bool\<close>, which maps variables to their
values:
\<close>

primrec "value" :: "boolex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"value (Const b) env = b" |
"value (Var x)   env = env x" |
"value (Neg b)   env = (\<not> value b env)" |
"value (And b c) env = (value b env \<and> value c env)"

text\<open>\noindent
\subsubsection{If-Expressions}

An alternative and often more efficient (because in a certain sense
canonical) representation are so-called \emph{If-expressions} built up
from constants (\<^term>\<open>CIF\<close>), variables (\<^term>\<open>VIF\<close>) and conditionals
(\<^term>\<open>IF\<close>):
\<close>

datatype ifex = CIF bool | VIF nat | IF ifex ifex ifex

text\<open>\noindent
The evaluation of If-expressions proceeds as for \<^typ>\<open>boolex\<close>:
\<close>

primrec valif :: "ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"valif (CIF b)    env = b" |
"valif (VIF x)    env = env x" |
"valif (IF b t e) env = (if valif b env then valif t env
                                        else valif e env)"

text\<open>
\subsubsection{Converting Boolean and If-Expressions}

The type \<^typ>\<open>boolex\<close> is close to the customary representation of logical
formulae, whereas \<^typ>\<open>ifex\<close> is designed for efficiency. It is easy to
translate from \<^typ>\<open>boolex\<close> into \<^typ>\<open>ifex\<close>:
\<close>

primrec bool2if :: "boolex \<Rightarrow> ifex" where
"bool2if (Const b) = CIF b" |
"bool2if (Var x)   = VIF x" |
"bool2if (Neg b)   = IF (bool2if b) (CIF False) (CIF True)" |
"bool2if (And b c) = IF (bool2if b) (bool2if c) (CIF False)"

text\<open>\noindent
At last, we have something we can verify: that \<^term>\<open>bool2if\<close> preserves the
value of its argument:
\<close>

lemma "valif (bool2if b) env = value b env"

txt\<open>\noindent
The proof is canonical:
\<close>

apply(induct_tac b)
apply(auto)
done

text\<open>\noindent
In fact, all proofs in this case study look exactly like this. Hence we do
not show them below.

More interesting is the transformation of If-expressions into a normal form
where the first argument of \<^term>\<open>IF\<close> cannot be another \<^term>\<open>IF\<close> but
must be a constant or variable. Such a normal form can be computed by
repeatedly replacing a subterm of the form \<^term>\<open>IF (IF b x y) z u\<close> by
\<^term>\<open>IF b (IF x z u) (IF y z u)\<close>, which has the same value. The following
primitive recursive functions perform this task:
\<close>

primrec normif :: "ifex \<Rightarrow> ifex \<Rightarrow> ifex \<Rightarrow> ifex" where
"normif (CIF b)    t e = IF (CIF b) t e" |
"normif (VIF x)    t e = IF (VIF x) t e" |
"normif (IF b t e) u f = normif b (normif t u f) (normif e u f)"

primrec norm :: "ifex \<Rightarrow> ifex" where
"norm (CIF b)    = CIF b" |
"norm (VIF x)    = VIF x" |
"norm (IF b t e) = normif b (norm t) (norm e)"

text\<open>\noindent
Their interplay is tricky; we leave it to you to develop an
intuitive understanding. Fortunately, Isabelle can help us to verify that the
transformation preserves the value of the expression:
\<close>

theorem "valif (norm b) env = valif b env"(*<*)oops(*>*)

text\<open>\noindent
The proof is canonical, provided we first show the following simplification
lemma, which also helps to understand what \<^term>\<open>normif\<close> does:
\<close>

theorem "valif (norm b) env = valif b env"
apply(induct_tac b)
by(auto)
(*>*)
text\<open>\noindent
Note that the lemma does not have a name, but is implicitly used in the proof
of the theorem shown above because of the \<open>[simp]\<close> attribute.

But how can we be sure that \<^term>\<open>norm\<close> really produces a normal form in
the above sense? We define a function that tests If-expressions for normality:
\<close>

primrec normal :: "ifex \<Rightarrow> bool" where
"normal(CIF b) = True" |
"normal(VIF x) = True" |
"normal(IF b t e) = (normal t \<and> normal e \<and>
     (case b of CIF b \<Rightarrow> True | VIF x \<Rightarrow> True | IF x y z \<Rightarrow> False))"

text\<open>\noindent
Now we prove \<^term>\<open>normal(norm b)\<close>. Of course, this requires a lemma about
normality of \<^term>\<open>normif\<close>:
\<close>

lemma [simp]: "\<forall>t e. normal(normif b t e) = (normal t \<and> normal e)"
(*<*)
apply(induct_tac b)
by(auto)

theorem "normal(norm b)"
apply(induct_tac b)
by(auto)
(*>*)

text\<open>\medskip
How do we come up with the required lemmas? Try to prove the main theorems
without them and study carefully what \<open>auto\<close> leaves unproved. This
can provide the clue.  The necessity of universal quantification
(\<open>\<forall>t e\<close>) in the two lemmas is explained in
\S\ref{sec:InductionHeuristics}

\begin{exercise}
  We strengthen the definition of a \<^const>\<open>normal\<close> If-expression as follows:
  the first argument of all \<^term>\<open>IF\<close>s must be a variable. Adapt the above
  development to this changed requirement. (Hint: you may need to formulate
  some of the goals as implications (\<open>\<longrightarrow>\<close>) rather than
  equalities (\<open>=\<close>).)
\end{exercise}
\index{boolean expressions example|)}
\<close>
(*<*)

primrec normif2 :: "ifex => ifex => ifex => ifex" where
"normif2 (CIF b)    t e = (if b then t else e)" |
"normif2 (VIF x)    t e = IF (VIF x) t e" |
"normif2 (IF b t e) u f = normif2 b (normif2 t u f) (normif2 e u f)"

primrec norm2 :: "ifex => ifex" where
"norm2 (CIF b)    = CIF b" |
"norm2 (VIF x)    = VIF x" |
"norm2 (IF b t e) = normif2 b (norm2 t) (norm2 e)"

primrec normal2 :: "ifex => bool" where
"normal2(CIF b) = True" |
"normal2(VIF x) = True" |
"normal2(IF b t e) = (normal2 t & normal2 e &
     (case b of CIF b => False | VIF x => True | IF x y z => False))"

lemma [simp]:
  "\<forall>t e. valif (normif2 b t e) env = valif (IF b t e) env"
apply(induct b)
by(auto)

theorem "valif (norm2 b) env = valif b env"
apply(induct b)
by(auto)

lemma [simp]: "\<forall>t e. normal2 t & normal2 e --> normal2(normif2 b t e)"
apply(induct b)
by(auto)

theorem "normal2(norm2 b)"
apply(induct b)
by(auto)

end
(*>*)


theory Chapter2Sols
imports Main Chapter2Defs
begin

(*  Exercise 2.1  *)
value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

(*  Exercise 2.2  *)
(*
lemma add_assoc[simp]: "add x (add y z) = add (add x y) z"
  apply(induction x)
   apply(auto)
  done

lemma suc_add[simp]: "Suc (add m n) = add m (Suc n)"
  apply(induction m)
   apply(auto)
  done

lemma add_commu[simp]: "add x y = add y x"
  apply(induction x)
   apply(auto)
  done

fun double:: "nat \<Rightarrow> nat" where
"double 0 = 0" |
"double (Suc n) = 2 + double n"

lemma "double m = add m m"
  apply(induction m)
   apply(auto)
  done
*)

(*  Exercise 2.3  *)
fun count:: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count n [] = 0" |
"count n (x#xs) = (if x=n then (1 + count n xs) else count n xs)"

theorem count_len [simp]: "count x xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

(*  Exercise 2.4  *)
fun snoc:: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] elem = (Cons elem Nil)" |
"snoc (Cons x xs) elem = (Cons x (snoc xs elem))"

fun reverse:: "'a list \<Rightarrow> 'a list" where
"reverse Nil = Nil" |
"reverse (Cons x xs) = snoc (reverse xs) x"

lemma snoc_rev[simp]: "reverse (snoc xs a) = a # reverse xs"
  apply(induction xs)
   apply(auto)
  done

lemma rev_rev[simp]: "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  done

(*  Exercise 2.5  *)
fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto n = n + sum_upto (n - 1)"

lemma "sum_upto n = (n * (n+1)) div 2"
  apply(induction n)
   apply(auto)
  done

(*  Exercise 2.6  *)
fun contents:: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l a r) = (Cons a (contents l))@(contents r)"

fun sum_tree:: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r) = a + sum_tree l + sum_tree r"

lemma "sum_tree t = sum_list(contents t)"
  apply(induction t)
   apply(auto)
  done

(*  Exercise 2.7  *)
fun pre_order:: "'a tree \<Rightarrow> 'a list" where
"pre_order Tip = []" |
"pre_order (Node l a r) = [a]@(pre_order l)@(pre_order r)"

fun post_order:: "'a tree \<Rightarrow> 'a list" where
"post_order Tip = []" |
"post_order (Node l a r) = (post_order l)@(post_order r)@[a]"

lemma "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
  apply(auto)
  done

(*  Exercise 2.8  *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse elem [] = [elem]" |
"intersperse elem (x#xs) = [x] @ [elem] @ (intersperse elem xs)"

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs)
   apply(auto)
  done

(*  Exercise 2.9  *)
fun itadd:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 n = n" |
"itadd (Suc m) n = itadd m (Suc n)"

lemma "itadd m n = add m n"
  apply(induction m arbitrary: n)
   apply(auto)
  done

(*  Exercise 2.10  *)
datatype tree0 = Tip | Node tree0 tree0

fun nodes:: "tree0 \<Rightarrow> nat" where
"nodes Tip = 0" |
"nodes (Node l r) = 1 + nodes l + nodes r"

fun explode:: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

lemma "nodes(explode n t) = 2^n * (nodes t + 1) - 1"
  apply(induction n arbitrary: t)
   apply(auto)
  apply(simp add: algebra_simps)
  done

(*  Exercise 2.11  *)
datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval:: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var v = v" |
"eval (Const i) v = i" |
"eval (Add e1 e2) v = (eval e1 v) + (eval e2 v)" |
"eval (Mult e1 e2) v = (eval e1 v) * (eval e2 v)"

fun evalp:: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp [] n = 0" |
"evalp (x#xs) n = x + n * (evalp xs n)"

(* not complete *)
end

github-repos/isabelle/mrtkp9993-Isabelle-HOL-Examples/Isabelle-HOL-Examples-37a31d2aefce20eb5c49d358c1ea236f5e693458/Programming and Proving in Isabelle-Hol Exercise Solutions/Chapter2Sols.thy


theory ex02
  imports Main
begin

datatype 'a ltree = Leaf 'a | Node "'a ltree" "'a ltree"

fun inorder:: "'a ltree \<Rightarrow> 'a list" where
  "inorder (Leaf x) = [x]"
| "inorder (Node l r) = inorder l @ inorder r"

lemma
  "fold f [] s = s"
  "fold f (x # xs) s = fold f xs (f x s)"
  by auto

fun fold_tree:: "('b \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'b ltree \<Rightarrow> 'a \<Rightarrow> 'a" where
  "fold_tree f (Leaf b) a = f b a"
| "fold_tree f (Node l r) a = fold_tree f r (fold_tree f l a)"

value "fold_tree
(\<lambda>x y. x + y)
(Node (Leaf (1::nat)) (Node (Leaf 2) (Leaf 4)))
0
"

lemma "fold_tree f t s = fold f (inorder t) s"
  apply(induction t arbitrary: s)
   apply(auto)
  done

fun mirror:: "'a ltree \<Rightarrow> 'a ltree" where
  "mirror (Leaf a) = Leaf a"
| "mirror (Node l r) = Node (mirror r) (mirror l)"

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

fun shuffles:: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "shuffles [] ys = [ys]"
| "shuffles xs [] = [xs]"
| "shuffles (x#xs) (y#ys) =
    map(op # x) (shuffles xs (y#ys))
    @ map(op # y) (shuffles (x#xs) ys)"

lemma "l\<in>set (shuffles xs ys) \<Longrightarrow> length l = length xs + length ys"
  apply(induction xs ys arbitrary: l rule: shuffles.induct)
    apply(auto)
  done

fun list_sum :: "nat list \<Rightarrow> nat" where
  "list_sum [] = 0"
| "list_sum (x#xs) = x + list_sum xs"

definition "list_sum' xs = fold (op +) xs 0"

lemma auxi: "fold (op +) xs a = list_sum xs + a"
  apply(induction xs arbitrary: a)
   apply(auto)
  done

lemma "list_sum xs = list_sum' xs"
  unfolding list_sum'_def
  using auxi[where a=0]
  apply auto
  done

end


(*  File:       Evaluation_Function.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Evaluation Function\<close>

theory Evaluation_Function
  imports "Social_Choice_Types/Profile"
begin

text \<open>
  This is the evaluation function. From a set of currently eligible
  alternatives, the evaluation function computes a numerical value that is then
  to be used for further (s)election, e.g., by the elimination module.
\<close>

subsection \<open>Definition\<close>

type_synonym 'a Evaluation_Function = "'a  \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> nat"

subsection \<open>Property\<close>

text \<open>
  An Evaluation function is Condorcet-rating iff the following holds:
  If a Condorcet Winner w exists, w and only w has the highest value.
\<close>

definition condorcet_rating :: "'a Evaluation_Function \<Rightarrow> bool" where
  "condorcet_rating f \<equiv>
    \<forall> A p w . condorcet_winner A p w \<longrightarrow>
      (\<forall> l \<in> A . l \<noteq> w \<longrightarrow> f l A p < f w A p)"

subsection \<open>Theorems\<close>

text \<open>
  If e is Condorcet-rating, the following holds:
  If a Condorcet Winner w exists, w has the maximum evaluation value.
\<close>

theorem cond_winner_imp_max_eval_val:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w"
  shows "e w A p = Max {e a A p | a. a \<in> A}"
proof -
  let ?set = "{e a A p | a. a \<in> A}" and
      ?eMax = "Max {e a A p | a. a \<in> A}" and
      ?eW = "e w A p"
  from f_prof
  have 0: "finite ?set"
    by simp
  have 1: "?set \<noteq> {}"
    using condorcet_winner.simps winner
    by fastforce
  have 2: "?eW \<in> ?set"
    using CollectI condorcet_winner.simps winner
    by (metis (mono_tags, lifting))
  have 3: "\<forall> e \<in> ?set . e \<le> ?eW"
  proof (safe)
    fix a :: "'a"
    assume aInA: "a \<in> A"
    have "\<forall>n na. (n::nat) \<noteq> na \<or> n \<le> na"
      by simp
    with aInA show "e a A p \<le> e w A p"
      using less_imp_le rating winner
      unfolding condorcet_rating_def
      by (metis (no_types))
  qed
  from 2 3 have 4:
    "?eW \<in> ?set \<and> (\<forall>a \<in> ?set. a \<le> ?eW)"
    by blast
  from 0 1 4 Max_eq_iff
  show ?thesis
    by (metis (no_types, lifting))
qed

text \<open>
  If e is Condorcet-rating, the following holds:
  If a Condorcet Winner w exists, a non-Condorcet
  winner has a value lower than the maximum
  evaluation value.
\<close>

theorem non_cond_winner_not_max_eval:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w" and
    linA: "l \<in> A" and
    loser: "w \<noteq> l"
  shows "e l A p < Max {e a A p | a. a \<in> A}"
proof -
  have "e l A p < e w A p"
    using linA loser rating winner
    unfolding condorcet_rating_def
    by metis
  also have "e w A p = Max {e a A p |a. a \<in> A}"
    using cond_winner_imp_max_eval_val f_prof rating winner
    by fastforce
  finally show ?thesis
    by simp
qed

end


(*  Title:      AVL Trees
    Author:     Tobias Nipkow and Cornelia Pusch,
                converted to Isar by Gerwin Klein
                contributions by Achim Brucker, Burkhart Wolff and Jan Smaus
                delete formalization and a transformation to Isar by Ondrej Kuncar
    Maintainer: Gerwin Klein <gerwin.klein at nicta.com.au>

    see the file Changelog for a list of changes
*)

header "AVL Trees"

theory AVL
imports Main
begin

text {*
  This is a monolithic formalization of AVL trees.
*}

subsection {* AVL tree type definition *}

datatype (set_of: 'a) tree = ET |  MKT 'a "'a tree" "'a tree" nat

subsection {* Invariants and auxiliary functions *}

primrec height :: "'a tree \<Rightarrow> nat" where
"height ET = 0" |
"height (MKT x l r h) = max (height l) (height r) + 1"

primrec avl :: "'a tree \<Rightarrow> bool" where
"avl ET = True" |
"avl (MKT x l r h) =
 ((height l = height r \<or> height l = height r + 1 \<or> height r = height l + 1) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

primrec is_ord :: "('a::order) tree \<Rightarrow> bool" where
"is_ord ET = True" |
"is_ord (MKT n l r h) =
 ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

subsection {* AVL interface and implementation *}

primrec is_in :: "('a::order) \<Rightarrow> 'a tree \<Rightarrow> bool" where
 "is_in k ET = False" |
 "is_in k (MKT n l r h) = (if k = n then True else
                           if k < n then (is_in k l)
                           else (is_in k r))"

primrec ht :: "'a tree \<Rightarrow> nat" where
"ht ET = 0" |
"ht (MKT x l r h) = h"

definition
 mkt :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"mkt x l r = MKT x l r (max (ht l) (ht r) + 1)"

fun mkt_bal_l where
"mkt_bal_l n l r = (
  if ht l = ht r + 2 then (case l of
    MKT ln ll lr _ \<Rightarrow> (if ht ll < ht lr
    then case lr of
      MKT lrn lrl lrr _ \<Rightarrow> mkt lrn (mkt ln ll lrl) (mkt n lrr r)
    else mkt ln ll (mkt n lr r)))
  else mkt n l r
)"

fun mkt_bal_r where
"mkt_bal_r n l r = (
  if ht r = ht l + 2 then (case r of
    MKT rn rl rr _ \<Rightarrow> (if ht rl > ht rr
    then case rl of
      MKT rln rll rlr _ \<Rightarrow> mkt rln (mkt n l rll) (mkt rn rlr rr)
    else mkt rn (mkt n l rl) rr))
  else mkt n l r
)"

primrec insert :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x ET = MKT x ET ET 1" |
"insert x (MKT n l r h) =
   (if x=n
    then MKT n l r h
    else if x<n
      then mkt_bal_l n (insert x l) r
      else mkt_bal_r n l (insert x r))"

fun delete_max where
"delete_max (MKT n l ET h) = (n,l)" |
"delete_max (MKT n l r h) = (
  let (n',r') = delete_max r in
  (n',mkt_bal_l n l r'))"

lemmas delete_max_induct = delete_max.induct[case_names ET MKT]

fun delete_root where
"delete_root (MKT n ET r h) = r" |
"delete_root (MKT n l ET h) = l" |
"delete_root (MKT n l r h) =
  (let (new_n, l') = delete_max l in
      mkt_bal_r new_n l' r
  )"

lemmas delete_root_cases = delete_root.cases[case_names ET_t MKT_ET MKT_MKT]

primrec delete :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete _ ET = ET" |
"delete x (MKT n l r h) = (
   if x = n then delete_root (MKT n l r h)
   else if x < n then
        let l' = delete x l in
        mkt_bal_r n l' r
   else
        let r' = delete x r in
        mkt_bal_l n l r'
   )"

subsection {* Correctness proof *}

subsubsection {* Insertion maintains AVL balance *}

declare Let_def [simp]

lemma height_mkt_bal_l:
  "\<lbrakk> height l = height r + 2; avl l; avl r \<rbrakk> \<Longrightarrow>
   height (mkt_bal_l n l r) = height r + 2 \<or>
   height (mkt_bal_l n l r) = height r + 3"
by (cases l) (auto simp:mkt_def split:tree.split)

lemma height_mkt_bal_r:
  "\<lbrakk> height r = height l + 2; avl l; avl r \<rbrakk> \<Longrightarrow>
   height (mkt_bal_r n l r) = height l + 2 \<or>
   height (mkt_bal_r n l r) = height l + 3"
by (cases r) (auto simp add:mkt_def split:tree.split)

lemma [simp]: "height(mkt x l r) = max (height l) (height r) + 1"
by (simp add: mkt_def)

lemma avl_mkt:
  "\<lbrakk> avl l; avl r;
     height l = height r \<or> height l = height r + 1 \<or> height r = height l + 1
   \<rbrakk> \<Longrightarrow> avl(mkt x l r)"
by (auto simp add:max_def mkt_def)

lemma height_mkt_bal_l2:
  "\<lbrakk> avl l; avl r; height l \<noteq> height r + 2 \<rbrakk> \<Longrightarrow>
   height (mkt_bal_l n l r) = (1 + max (height l) (height r))"
by (cases l, cases r) simp_all

lemma height_mkt_bal_r2:
  "\<lbrakk> avl l;  avl r;  height r \<noteq> height l + 2 \<rbrakk> \<Longrightarrow>
   height (mkt_bal_r n l r) = (1 + max (height l) (height r))"
by (cases l, cases r) simp_all

lemma avl_mkt_bal_l:
  assumes "avl l" "avl r" and "height l = height r \<or> height l = height r + 1
    \<or> height r = height l + 1 \<or> height l = height r + 2"
  shows "avl(mkt_bal_l n l r)"
proof(cases l)
  case ET
  with assms show ?thesis by (simp add: mkt_def)
next
  case (MKT ln ll lr lh)
  with assms show ?thesis
  proof(cases "height l = height r + 2")
    case True
      from True MKT assms show ?thesis by (auto intro!: avl_mkt split: tree.split) arith+
  next
    case False
      with assms show ?thesis by (simp add: avl_mkt)
  qed
qed

lemma avl_mkt_bal_r:
  assumes "avl l" and "avl r" and "height l = height r \<or> height l = height r + 1
    \<or> height r = height l + 1 \<or> height r = height l + 2"
  shows "avl(mkt_bal_r n l r)"
proof(cases r)
  case ET
  with assms show ?thesis by (simp add: mkt_def)
next
  case (MKT rn rl rr rh)
  with assms show ?thesis
  proof(cases "height r = height l + 2")
    case True
      from True MKT assms show ?thesis by (auto intro!: avl_mkt split: tree.split) arith+
  next
    case False
      with assms show ?thesis by (simp add: avl_mkt)
  qed
qed

(* It apppears that these two properties need to be proved simultaneously: *)

text{* Insertion maintains the AVL property: *}

theorem avl_insert_aux:
  assumes "avl t"
  shows "avl(insert x t)"
        "(height (insert x t) = height t \<or> height (insert x t) = height t + 1)"
using assms
proof (induction t)
  case (MKT n l r h)
  case 1
  with MKT show ?case
  proof(cases "x = n")
    case True
    with MKT 1 show ?thesis by simp
  next
    case False
    with MKT 1 show ?thesis
    proof(cases "x<n")
      case True
      with MKT 1 show ?thesis by (auto simp add:avl_mkt_bal_l simp del:mkt_bal_l.simps)
    next
      case False
      with MKT 1 `x\<noteq>n` show ?thesis by (auto simp add:avl_mkt_bal_r simp del:mkt_bal_r.simps)
    qed
  qed
  case 2
  from 2 MKT show ?case
  proof(cases "x = n")
    case True
    with MKT 1 show ?thesis by simp
  next
    case False
    with MKT 1 show ?thesis
     proof(cases "x<n")
      case True
      with MKT 2 show ?thesis
      proof(cases "height (AVL.insert x l) = height r + 2")
        case False with MKT 2 `x < n` show ?thesis by (auto simp del: mkt_bal_l.simps simp: height_mkt_bal_l2)
      next
        case True
        then have "height (mkt_bal_l n (AVL.insert x l) r) = height r + 2 \<or>
              height (mkt_bal_l n (AVL.insert x l) r) = height r + 3"
          using MKT 2 by (intro height_mkt_bal_l) simp_all
        then show ?thesis
        proof (rule disjE)
          case goal1 with 2 `x < n` show ?thesis by (auto simp del: mkt_bal_l.simps)
        next
          case goal2 with True 1 MKT(2) `x < n` show ?thesis  by (simp del: mkt_bal_l.simps) arith
        qed
      qed
    next
      case False
      with MKT 2 show ?thesis
      proof(cases "height (AVL.insert x r) = height l + 2")
        case False with MKT 2 `\<not>x < n` show ?thesis by (auto simp del: mkt_bal_r.simps simp: height_mkt_bal_r2)
      next
        case True
        then have "height (mkt_bal_r n l (AVL.insert x r)) = height l + 2 \<or>
              height (mkt_bal_r n l (AVL.insert x r)) = height l + 3"
          using MKT 2 by (intro height_mkt_bal_r) simp_all
        then show ?thesis
        proof (rule disjE)
          case goal1 with 2 `\<not>x < n` show ?thesis by (auto simp del: mkt_bal_r.simps)
        next
          case goal2 with True 1 MKT(4) `\<not>x < n` show ?thesis by (simp del: mkt_bal_r.simps) arith
        qed
      qed
    qed
  qed
qed simp_all

lemmas avl_insert = avl_insert_aux(1)

subsubsection {* Deletion maintains AVL balance *}

lemma avl_delete_max:
  assumes "avl x" and "x \<noteq> ET"
  shows "avl (snd (delete_max x))" "height x = height(snd (delete_max x)) \<or>
         height x = height(snd (delete_max x)) + 1"
using assms
proof (induct x rule: delete_max_induct)
  case (MKT n l rn rl rr rh h)
  case 1
  with MKT have "avl l" "avl (snd (delete_max (MKT rn rl rr rh)))" by auto
  with 1 MKT have "avl (mkt_bal_l n l (snd (delete_max (MKT rn rl rr rh))))"
    by (intro avl_mkt_bal_l) fastforce+
  then show ?case
    by (auto simp: height_mkt_bal_l height_mkt_bal_l2
      linorder_class.max.absorb1 linorder_class.max.absorb2
      split:prod.split simp del:mkt_bal_l.simps)
next
  case (MKT n l rn rl rr rh h)
  case 2
  let ?r = "MKT rn rl rr rh"
  let ?r' = "snd (delete_max ?r)"
  from `avl x` MKT 2 have "avl l" and "avl ?r" by simp_all
  then show ?case using MKT 2 height_mkt_bal_l[of l ?r' n] height_mkt_bal_l2[of l ?r' n]
    apply (auto split:prod.splits simp del:avl.simps mkt_bal_l.simps) by arith+
qed auto

lemma avl_delete_root:
  assumes "avl t" and "t \<noteq> ET"
  shows "avl(delete_root t)"
using assms
proof (cases t rule:delete_root_cases)
  case (MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?l = "MKT ln ll lr lh"
  let ?r = "MKT rn rl rr rh"
  let ?l' = "snd (delete_max ?l)"
  from `avl t` and MKT_MKT have "avl ?r" by simp
  from `avl t` and MKT_MKT have "avl ?l" by simp
  then have "avl(?l')" "height ?l = height(?l') \<or>
         height ?l = height(?l') + 1" by (rule avl_delete_max,simp)+
  with `avl t` MKT_MKT have "height ?l' = height ?r \<or> height ?l' = height ?r + 1
            \<or> height ?r = height ?l' + 1 \<or> height ?r = height ?l' + 2" by fastforce
  with `avl ?l'` `avl ?r` have "avl(mkt_bal_r (fst(delete_max ?l)) ?l' ?r)"
    by (rule avl_mkt_bal_r)
  with MKT_MKT show ?thesis by (auto split:prod.splits simp del:mkt_bal_r.simps)
qed simp_all

lemma height_delete_root:
  assumes "avl t" and "t \<noteq> ET"
  shows "height t = height(delete_root t) \<or> height t = height(delete_root t) + 1"
using assms
proof (cases t rule: delete_root_cases)
  case (MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?l = "MKT ln ll lr lh"
  let ?r = "MKT rn rl rr rh"
  let ?l' = "snd (delete_max ?l)"
  let ?t' = "mkt_bal_r (fst(delete_max ?l)) ?l' ?r"
  from `avl t` and MKT_MKT have "avl ?r" by simp
  from `avl t` and MKT_MKT have "avl ?l" by simp
  then have "avl(?l')"  by (rule avl_delete_max,simp)
  have l'_height: "height ?l = height ?l' \<or> height ?l = height ?l' + 1" using `avl ?l` by (intro avl_delete_max) auto
  have t_height: "height t = 1 + max (height ?l) (height ?r)" using `avl t` MKT_MKT by simp
  have "height t = height ?t' \<or> height t = height ?t' + 1" using  `avl t` MKT_MKT
  proof(cases "height ?r = height ?l' + 2")
    case False
    show ?thesis using l'_height t_height False by (subst  height_mkt_bal_r2[OF `avl ?l'` `avl ?r` False])+ arith
  next
    case True
    show ?thesis
    proof(cases rule: disjE[OF height_mkt_bal_r[OF True `avl ?l'` `avl ?r`, of "fst (delete_max ?l)"]])
      case 1
      then show ?thesis using l'_height t_height True by arith
    next
      case 2
      then show ?thesis using l'_height t_height True by arith
    qed
  qed
  thus ?thesis using MKT_MKT by (auto split:prod.splits simp del:mkt_bal_r.simps)
qed simp_all

text{* Deletion maintains the AVL property: *}

theorem avl_delete_aux:
  assumes "avl t"
  shows "avl(delete x t)" and "height t = (height (delete x t)) \<or> height t = height (delete x t) + 1"
using assms
proof (induct t)
  case (MKT n l r h)
  case 1
  with MKT show ?case
  proof(cases "x = n")
    case True
    with MKT 1 show ?thesis by (auto simp:avl_delete_root)
  next
    case False
    with MKT 1 show ?thesis
    proof(cases "x<n")
      case True
      with MKT 1 show ?thesis by (auto simp add:avl_mkt_bal_r simp del:mkt_bal_r.simps)
    next
      case False
      with MKT 1 `x\<noteq>n` show ?thesis by (auto simp add:avl_mkt_bal_l simp del:mkt_bal_l.simps)
    qed
  qed
  case 2
  with MKT show ?case
  proof(cases "x = n")
    case True
    with 1 have "height (MKT n l r h) = height(delete_root (MKT n l r h))
      \<or> height (MKT n l r h) = height(delete_root (MKT n l r h)) + 1"
      by (subst height_delete_root,simp_all)
    with True show ?thesis by simp
  next
    case False
    with MKT 1 show ?thesis
     proof(cases "x<n")
      case True
      show ?thesis
      proof(cases "height r = height (delete x l) + 2")
        case False with MKT 1 `x < n` show ?thesis by auto
      next
        case True
        then have "height (mkt_bal_r n (delete x l) r) = height (delete x l) + 2 \<or>
              height (mkt_bal_r n (delete x l) r) = height (delete x l) + 3"
              using MKT 2 by (intro height_mkt_bal_r) auto
        then show ?thesis
        proof(rule disjE)
          case goal1 with `x < n` MKT 2 show ?thesis by auto
        next
          case goal2 with `x < n` MKT 2 show ?thesis by auto
        qed
      qed
    next
      case False
      show ?thesis
      proof(cases "height l = height (delete x r) + 2")
        case False with MKT 1 `\<not>x < n` `x \<noteq> n` show ?thesis by auto
      next
        case True
        then have "height (mkt_bal_l n l (delete x r)) = height (delete x r) + 2 \<or>
              height (mkt_bal_l n l (delete x r)) = height (delete x r) + 3"
              using MKT 2 by (intro height_mkt_bal_l) auto
        then show ?thesis
        proof(rule disjE)
          case goal1 with `\<not>x < n` `x \<noteq> n` MKT 2 show ?thesis by auto
        next
          case goal2 with `\<not>x < n` `x \<noteq> n` MKT 2 show ?thesis by auto
        qed
      qed
    qed
  qed
qed simp_all

lemmas avl_delete = avl_delete_aux(1)

subsubsection {* Correctness of insertion *}

lemma set_of_mkt_bal_l:
  "\<lbrakk> avl l; avl r \<rbrakk> \<Longrightarrow>
  set_of (mkt_bal_l n l r) = Set.insert n (set_of l \<union> set_of r)"
by (auto simp: mkt_def split:tree.splits)

lemma set_of_mkt_bal_r:
  "\<lbrakk> avl l; avl r \<rbrakk> \<Longrightarrow>
  set_of (mkt_bal_r n l r) = Set.insert n (set_of l \<union> set_of r)"
by (auto simp: mkt_def split:tree.splits)

text{* Correctness of @{const insert}: *}

theorem set_of_insert:
  "avl t \<Longrightarrow> set_of(insert x t) = Set.insert x (set_of t)"
by (induct t)
   (auto simp: avl_insert set_of_mkt_bal_l set_of_mkt_bal_r simp del:mkt_bal_l.simps mkt_bal_r.simps)

subsubsection {* Correctness of deletion *}

fun rightmost_item :: "'a tree \<Rightarrow> 'a" where
"rightmost_item (MKT n l ET h) = n" |
"rightmost_item (MKT n l r h) = rightmost_item r"

lemma avl_dist:
  "\<lbrakk> avl(MKT n l r h); is_ord(MKT n l r h); x \<in> set_of l \<rbrakk> \<Longrightarrow>
  x \<notin> set_of r"
by fastforce

lemma avl_dist2:
  "\<lbrakk> avl(MKT n l r h); is_ord(MKT n l r h); x \<in> set_of l \<or> x \<in> set_of r \<rbrakk> \<Longrightarrow>
  x \<noteq> n"
by auto

lemma ritem_in_rset: "r \<noteq> ET \<Longrightarrow> rightmost_item r \<in> set_of r"
by(induct r rule:rightmost_item.induct) auto

lemma ritem_greatest_in_rset:
  "\<lbrakk> r \<noteq> ET; is_ord r \<rbrakk> \<Longrightarrow>
  \<forall>x.  x \<in> set_of r \<longrightarrow> x \<noteq> rightmost_item r \<longrightarrow> x < rightmost_item r"
proof(induct r rule:rightmost_item.induct)
  case (2 n l rn rl rr rh h)
  show ?case (is "\<forall>x. ?P x")
  proof
    fix x
    from assms 2 have "is_ord (MKT rn rl rr rh)" by auto
    moreover from 2 have "n < rightmost_item (MKT rn rl rr rh)"
      by (metis is_ord.simps(2) ritem_in_rset tree.simps(2))
    moreover from 2 have "x \<in> set_of l \<longrightarrow> x < rightmost_item (MKT rn rl rr rh)"
      by (metis calculation(2) is_ord.simps(2) xt1(10))
    ultimately show "?P x" using 2 by simp
  qed
qed auto

lemma ritem_not_in_ltree:
  "\<lbrakk> avl(MKT n l r h); is_ord(MKT n l r h); r \<noteq> ET \<rbrakk> \<Longrightarrow>
  rightmost_item r \<notin> set_of l"
by (metis avl_dist ritem_in_rset)

lemma set_of_delete_max:
  "\<lbrakk> avl t; is_ord t; t\<noteq>ET \<rbrakk> \<Longrightarrow>
   set_of (snd(delete_max t)) = (set_of t) - {rightmost_item t}"
proof (induct t rule: delete_max_induct)
  case (MKT n l rn rl rr rh h)
  let ?r = "MKT rn rl rr rh"
  from MKT have "avl l" and "avl ?r" by simp_all
  let ?t' = "mkt_bal_l n l (snd (delete_max ?r))"
  from MKT have "avl (snd(delete_max ?r))" by (auto simp add: avl_delete_max)
  with assms MKT  ritem_not_in_ltree[of n l ?r h]
  have "set_of ?t' = (set_of l) \<union> (set_of ?r) - {rightmost_item ?r} \<union> {n}"
    by (auto simp add:set_of_mkt_bal_l simp del: mkt_bal_l.simps)
  moreover have "n \<notin> {rightmost_item ?r}"
    by (metis MKT(2) MKT(3) avl_dist2 ritem_in_rset singletonE tree.simps(3))
  ultimately show ?case
    by (auto simp add:insert_Diff_if split:prod.splits simp del: mkt_bal_l.simps)
qed auto

lemma fst_delete_max_eq_ritem:
  "t\<noteq>ET \<Longrightarrow> fst(delete_max t) = rightmost_item t"
by (induct t rule:rightmost_item.induct) (auto split:prod.splits)

lemma set_of_delete_root:
  assumes "t = MKT n l r h" and "avl t" and "is_ord t"
  shows "set_of (delete_root t) = (set_of t) - {n}"
using assms
proof(cases t rule:delete_root_cases)
  case(MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?t' = "mkt_bal_r (fst (delete_max l)) (snd (delete_max l)) r"
  from assms MKT_MKT have "avl l" and "avl r" and "is_ord l" and "l\<noteq>ET" by auto
  moreover from MKT_MKT assms have "avl (snd(delete_max l))"
    by (auto simp add: avl_delete_max)
  ultimately have "set_of ?t' = (set_of l) \<union> (set_of r)"
    by (fastforce simp add: Set.insert_Diff ritem_in_rset fst_delete_max_eq_ritem
       set_of_delete_max set_of_mkt_bal_r  simp del: mkt_bal_r.simps)
  moreover from MKT_MKT assms(1) have "set_of (delete_root t) = set_of ?t'"
    by (simp split:prod.split del:mkt_bal_r.simps)
  moreover from MKT_MKT assms have "(set_of t) - {n} = set_of l \<union> set_of r"
    by (metis Diff_insert_absorb UnE avl_dist2 tree.set(2) tree.inject)
  ultimately show ?thesis using MKT_MKT assms(1)
    by (simp del: delete_root.simps)
qed auto

text{* Correctness of @{const delete}: *}

subsubsection {* Correctness of lookup *}

theorem is_in_correct: "is_ord t \<Longrightarrow> is_in k t = (k : set_of t)"
by (induct t) auto

subsubsection {* Insertion maintains order *}

lemma is_ord_mkt_bal_l:
  "is_ord(MKT n l r h) \<Longrightarrow> is_ord (mkt_bal_l n l r)"
by (cases l) (auto simp: mkt_def split:tree.splits intro: order_less_trans)

lemma is_ord_mkt_bal_r: "is_ord(MKT n l r h) \<Longrightarrow> is_ord (mkt_bal_r n l r)"
by (cases r) (auto simp: mkt_def split:tree.splits intro: order_less_trans)

text{* If the order is linear, @{const insert} maintains the order: *}

theorem is_ord_insert:
  "\<lbrakk> avl t; is_ord t \<rbrakk> \<Longrightarrow> is_ord(insert (x::'a::linorder) t)"
by (induct t) (simp_all add:is_ord_mkt_bal_l is_ord_mkt_bal_r avl_insert set_of_insert
                linorder_not_less order_neq_le_trans del:mkt_bal_l.simps mkt_bal_r.simps)

subsubsection {* Deletion maintains order *}

lemma is_ord_delete_max:
  "\<lbrakk> avl t; is_ord t; t\<noteq>ET \<rbrakk> \<Longrightarrow> is_ord(snd(delete_max t))"
proof(induct t rule:delete_max_induct)
  case(MKT n l rn rl rr rh h)
  let ?r = "MKT rn rl rr rh"
  let ?r' = "snd(delete_max ?r)"
  from MKT assms have "\<forall>h. is_ord(MKT n l ?r' h)" by (auto simp: set_of_delete_max)
  moreover from MKT assms have "avl(?r')" by (auto simp: avl_delete_max)
  moreover note MKT is_ord_mkt_bal_l[of n l ?r']
  ultimately show ?case by (auto split:prod.splits simp del:is_ord.simps mkt_bal_l.simps)
qed auto

lemma is_ord_delete_root:
  assumes "avl t" and "is_ord t" and "t \<noteq> ET"
  shows "is_ord (delete_root t)"
using assms
proof(cases t rule:delete_root_cases)
  case(MKT_MKT n ln ll lr lh rn rl rr rh h)
  let ?l = "MKT ln ll lr lh"
  let ?r = "MKT rn rl rr rh"
  let ?l' = "snd (delete_max ?l)"
  let ?n' = "fst (delete_max ?l)"
  from assms MKT_MKT have "\<forall>h. is_ord(MKT ?n' ?l' ?r h)"
  proof -
    from assms MKT_MKT have "is_ord ?l'" by (auto simp add: is_ord_delete_max)
    moreover from assms MKT_MKT have "is_ord ?r" by auto
    moreover from assms MKT_MKT have "\<forall>x. x \<in> set_of ?r \<longrightarrow> ?n' < x"
      by (metis fst_delete_max_eq_ritem is_ord.simps(2) order_less_trans ritem_in_rset
          tree.simps(3))
    moreover from assms MKT_MKT ritem_greatest_in_rset have "\<forall>x. x \<in> set_of ?l' \<longrightarrow> x < ?n'"
      by (metis Diff_iff avl.simps(2) fst_delete_max_eq_ritem is_ord.simps(2)
          set_of_delete_max singleton_iff tree.simps(3))
    ultimately show ?thesis by auto
  qed
  moreover from assms MKT_MKT have "avl ?r" by simp
  moreover from assms MKT_MKT have "avl ?l'"  by (simp add: avl_delete_max)
  moreover note MKT_MKT is_ord_mkt_bal_r[of  ?n' ?l' ?r]
  ultimately show ?thesis by (auto simp del:mkt_bal_r.simps is_ord.simps split:prod.splits)
qed simp_all

text{* If the order is linear, @{const delete} maintains the order: *}

theorem is_ord_delete:
  "\<lbrakk> avl t; is_ord t \<rbrakk> \<Longrightarrow> is_ord (delete x t)"
proof (induct t)
  case (MKT n l r h)
  then show ?case
  proof(cases "x = n")
    case True
    with MKT is_ord_delete_root[of "MKT n l r h"] show ?thesis by simp
  next
    case False
    with MKT show ?thesis
    proof(cases "x<n")
      case True
      with True MKT have "\<forall>h. is_ord (MKT n (delete x l) r h)" by (auto simp:set_of_delete)
      with True MKT is_ord_mkt_bal_r[of n "(delete x l)" r]  show ?thesis
        by (auto simp add: avl_delete)
    next
      case False
      with False MKT have "\<forall>h. is_ord (MKT n l (delete x r) h)" by (auto simp:set_of_delete)
      with False MKT is_ord_mkt_bal_l[of n l "(delete x r)"] `x\<noteq>n` show ?thesis by (simp add: avl_delete)
    qed
  qed
qed simp

end


theory FiniteGraph
imports Main
begin

(*Lots of this theory is based on a work by Benedikt Nordhoff and Peter Lammich*)

section {*Specification of a finite directed graph*}

text{* A graph G=(V,E) consits of a set of vertices V, also called nodes,
       and a set of edges E. The edges are tuples of vertices. Both,
       the set of vertices and edges is finite. *}

(* Inspired by
Title: Dijkstra's Shortest Path Algorithm
Author: Benedikt Nordhoff and Peter Lammich
http://afp.sourceforge.net/entries/Dijkstra_Shortest_Path.shtml
*)

section {* Definitions *}
  text {* A graph is represented by a record. *}
  record 'v graph =
    nodes :: "'v set"
    edges :: "('v \<times>'v) set"

  text {* In a valid graph, edges only go from nodes to nodes. *}
  locale valid_graph =
    fixes G :: "'v graph"
    -- "Edges only refernce to existing nodes"
    assumes E_valid: "fst ` (edges G) \<subseteq> (nodes G)"
                     "snd ` (edges G) \<subseteq> (nodes G)"
    and finiteE: "finite (edges G)" (*implied by finiteV*)
    and finiteV: "finite (nodes G)"
  begin
    abbreviation "V \<equiv> (nodes G)"
    abbreviation "E \<equiv> (edges G)"

    lemma E_validD: assumes "(v,v') \<in> E"
      shows "v \<in> V" "v' \<in> V"
      apply -
       apply (rule set_mp[OF E_valid(1)])
       using assms apply force
      apply (rule set_mp[OF E_valid(2)])
      using assms apply force
      done

    lemma E_validD2: "\<forall>e \<in> E. fst e \<in> V \<and> snd e \<in> V"
    by (auto simp add: E_validD)
  end

subsection {* Basic operations on Graphs *}

  text {* The empty graph. *}
  definition empty where
    "empty \<equiv> \<lparr> nodes = {}, edges = {} \<rparr>"

  text {* Adds a node to a graph. *}
  definition add_node :: "'v \<Rightarrow> 'v graph \<Rightarrow> 'v graph" where
    "add_node v G \<equiv> \<lparr> nodes = ({v} \<union> (nodes G)), edges=edges G \<rparr>"

  text {* Deletes a node from a graph. Also deletes all adjacent edges. *}
  definition delete_node where "delete_node v G \<equiv> \<lparr>
    nodes = (nodes G) - {v},
    edges = {(e1, e2). (e1, e2) \<in> edges G \<and> e1 \<noteq> v \<and> e2 \<noteq> v}
    \<rparr>"

  text {* Adds an edge to a graph. *}
  definition add_edge where
  "add_edge v v' G = \<lparr>nodes = nodes G \<union> {v,v'}, edges = {(v, v')} \<union> edges G \<rparr>"

  text {* Deletes an edge from a graph. *}
  definition delete_edge where "delete_edge v v' G \<equiv> \<lparr>nodes = nodes G,
    edges = {(e1,e2). (e1, e2) \<in> edges G \<and> (e1,e2) \<noteq> (v,v')} \<rparr>"

  definition delete_edges::"'v graph \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> 'v graph" where
    "delete_edges G es = \<lparr>nodes = nodes G,
    edges = {(e1,e2). (e1, e2) \<in> edges G \<and> (e1,e2) \<notin> es} \<rparr>"

  fun delete_edges_list::"'v graph \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> 'v graph" where
    "delete_edges_list G [] = G"|
    "delete_edges_list G ((v,v')#es) = delete_edges_list (delete_edge v v' G) es"

  definition fully_connected :: "'v graph \<Rightarrow> 'v graph" where
    "fully_connected G \<equiv> \<lparr>nodes = nodes G, edges = nodes G \<times> nodes G \<rparr>"

text {* extended graph operations *}
  text {* Reflexive transitive successors of a node. Or: All reachable nodes for v including v. *}
  definition succ_rtran :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set" where
    "succ_rtran G v = {e2. (v,e2) \<in> (edges G)\<^sup>*}"

  text {* Transitive successors of a node. Or: All reachable nodes for v. *}
  definition succ_tran :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set" where
    "succ_tran G v = {e2. (v,e2) \<in> (edges G)\<^sup>+}"

  --"succ_tran is always finite"
  lemma succ_tran_finite: "valid_graph G \<Longrightarrow> finite (succ_tran G v)"
  proof -
    assume "valid_graph G"
    from valid_graph.finiteE[OF this] have "finite ((edges G)\<^sup>+)" using finite_trancl[symmetric, of "edges G"] by metis
    from this have "finite {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by simp
    from this have finite: "finite (snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+})" by (metis finite_imageI)
    have "{(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} \<subseteq> {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    have 1: "snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} \<subseteq> snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    have 2: "snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} = {e2. (v,e2) \<in> (edges G)\<^sup>+}" by force
    from 1 2 have "{e2. (v,e2) \<in> (edges G)\<^sup>+} \<subseteq> snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    from this finite have "finite {e2. (v, e2) \<in> (edges G)\<^sup>+}" by (metis finite_subset)
    thus "finite (succ_tran G v)" using succ_tran_def by metis
  qed

  text{* If there is no edge leaving from v, then v has no successors *}
  lemma succ_tran_empty: "\<lbrakk> valid_graph G; v \<notin> (fst ` edges G) \<rbrakk> \<Longrightarrow> succ_tran G v = {}"
  by (metis (lifting) Collect_empty_eq Domain.DomainI converse_tranclE fst_eq_Domain succ_tran_def)

  text{* succ_tran is subset of nodes *}
  lemma succ_tran_subseteq_nodes: "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> succ_tran G v \<subseteq> nodes G"
    apply(simp add: succ_tran_def)
    by (metis (lifting) mem_Collect_eq subsetI trancl.cases valid_graph.E_validD(2))

  text {* The number of reachable nodes from v *}
  definition num_reachable :: "'v graph \<Rightarrow> 'v \<Rightarrow> nat" where
    "num_reachable G v = card (succ_tran G v)"

  definition num_reachable_norefl :: "'v graph \<Rightarrow> 'v \<Rightarrow> nat" where
    "num_reachable_norefl G v = card (succ_tran G v - {v})"

  text{*card returns 0 for infinite sets. Here, for a valid graph, if num_reachable is zero,
        there are actually no nodes reachable.*}
  lemma num_reachable_zero: "\<lbrakk>valid_graph G; num_reachable G v = 0\<rbrakk> \<Longrightarrow> succ_tran G v = {}"
  apply(unfold num_reachable_def)
  apply(case_tac "finite (succ_tran G v)")
   apply(simp)
  apply(blast intro: succ_tran_finite)
  done
  lemma num_succtran_zero: "\<lbrakk>succ_tran G v = {}\<rbrakk> \<Longrightarrow> num_reachable G v = 0"
  by(unfold num_reachable_def, simp)
  lemma num_reachable_zero_iff: "\<lbrakk>valid_graph G\<rbrakk> \<Longrightarrow> (num_reachable G v = 0) <-> (succ_tran G v = {})"
  by(metis num_succtran_zero num_reachable_zero)

section{*Undirected Graph*}

subsection{*undirected graph simulation*}
  text {* Create undirected graph from directed graph by adding backward links *}

  definition backflows :: "('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set" where
    "backflows E \<equiv> {(r,s). (s,r) \<in> E}"

  definition undirected :: "'v graph \<Rightarrow> 'v graph"
    where "undirected G = \<lparr> nodes = nodes G, edges = (edges G) \<union> {(b,a). (a,b) \<in> edges G} \<rparr>"

section {*Lemmata*}

  lemma graph_eq_intro: "(nodes (G::'a graph) = nodes G') \<Longrightarrow> (edges G = edges G') \<Longrightarrow> G = G'"
  by simp

  -- "finite"
  lemma valid_graph_finite_filterE: "valid_graph G \<Longrightarrow> finite {(e1, e2). (e1, e2) \<in> edges G \<and> P e1 e2}"
  by(simp add: valid_graph.finiteE split_def)
  lemma valid_graph_finite_filterV: "valid_graph G \<Longrightarrow> finite {n. n \<in> nodes G \<and> P n}"
  by(simp add: valid_graph.finiteV)

  -- "empty"
  lemma empty_valid[simp]: "valid_graph empty"
    unfolding empty_def by unfold_locales auto
  lemma nodes_empty[simp]: "nodes empty = {}" unfolding empty_def by simp
  lemma edges_empty[simp]: "edges empty = {}" unfolding empty_def by simp

  -- "add node"
  lemma add_node_valid[simp]:
    "valid_graph g \<Longrightarrow> valid_graph (add_node v g)"
      unfolding add_node_def
      unfolding valid_graph_def
      by (auto)

  lemma delete_node_valid[simp]:
  "valid_graph G \<Longrightarrow> valid_graph (delete_node v G)"
  by(auto simp add: delete_node_def valid_graph_def valid_graph_finite_filterE)

  -- "add edgde"
  lemma add_edge_valid[simp]: "valid_graph G \<Longrightarrow> valid_graph (add_edge v v' G)"
  by(auto simp add: add_edge_def add_node_def valid_graph_def)

  -- "delete edge"
  lemma delete_edge_valid[simp]: "valid_graph G \<Longrightarrow> valid_graph (delete_edge v v' G)"
  by(auto simp add: delete_edge_def add_node_def valid_graph_def split_def)

  -- "delte edges"
  lemma delete_edges_list_valid[simp]: "valid_graph G \<Longrightarrow> valid_graph (delete_edges_list G E)"
    by(induction E arbitrary: G, simp, force)
  lemma delete_edges_valid[simp]: "valid_graph G \<Longrightarrow> valid_graph (delete_edges G E)"
  by(auto simp add: delete_edges_def add_node_def valid_graph_def split_def)
  lemma delete_edges_list_set: "delete_edges_list G E = delete_edges G (set E)"
    apply(induction E arbitrary: G)
     apply(simp_all add: delete_edges_def)
    apply(clarify)
    by(simp add: delete_edge_def)
  lemma delete_edges_list_union: "delete_edges_list G (ff @ keeps) = delete_edges G (set ff \<union> set keeps)"
   by(simp add: delete_edges_list_set)
  lemma add_edge_delete_edges_list:
    "(add_edge (fst a) (snd a) (delete_edges_list G (a # ff))) = (add_edge (fst a) (snd a) (delete_edges G (set ff)))"
   by(auto simp add: delete_edges_list_set delete_edges_def add_edge_def add_node_def)
  lemma delete_edges_empty[simp]: "delete_edges G {} = G"
   by(simp add: delete_edges_def)
  lemma delete_edges_simp2: "delete_edges G E = \<lparr> nodes = nodes G, edges = edges G - E\<rparr>"
   by(auto simp add: delete_edges_def)
  lemma delete_edges_set_nodes: "nodes (delete_edges G E) = nodes G"
   by(simp add: delete_edges_simp2)
  lemma delete_edges_edges_mono: "E' \<subseteq> E \<Longrightarrow> edges (delete_edges G E) \<subseteq> edges (delete_edges G E')"
    by(simp add: delete_edges_def, fast)
  lemma delete_edges_edges_empty: "(delete_edges G (edges G)) = G\<lparr>edges := {}\<rparr>"
    by(simp add: delete_edges_simp2)

 --"add delete"
  lemma add_delete_edge: "valid_graph (G::'a graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow>
  add_edge a b (delete_edge a b G) = G"
   apply(simp add: delete_edge_def add_edge_def valid_graph_def)
   apply(clarify)
   apply(rule graph_eq_intro)
    by (auto)

  lemma add_delete_edges: "valid_graph (G::'v graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow> (a,b) \<notin> fs \<Longrightarrow>
  add_edge a b (delete_edges G (insert (a, b) fs)) = (delete_edges G fs)"
  apply(simp add: delete_edges_simp2 add_edge_def valid_graph_def)
  apply(clarify)
  apply(auto)
  done

 --"fully_connected"
  lemma fully_connected_simp: "fully_connected \<lparr>nodes = N, edges = ignore \<rparr>\<equiv> \<lparr>nodes = N, edges = N \<times> N \<rparr>"
    by(simp add: fully_connected_def)
  lemma fully_connected_valid: "valid_graph G \<Longrightarrow> valid_graph (fully_connected G)"
    by(simp add: fully_connected_def valid_graph_def)

 --"succ_tran"
 lemma succ_tran_mono:
  "valid_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> succ_tran \<lparr>nodes=N, edges=E'\<rparr> v \<subseteq> succ_tran \<lparr>nodes=N, edges=E\<rparr> v"
   apply(drule valid_graph.finiteE)
   apply(frule_tac A="E'" in rev_finite_subset, simp)
   apply(simp add: num_reachable_def)
   apply(simp add: succ_tran_def)
   apply(metis (lifting, full_types) Collect_mono trancl_mono)
  done

  --"num_reachable"
  lemma num_reachable_mono:
  "valid_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> num_reachable \<lparr>nodes=N, edges=E'\<rparr> v \<le> num_reachable \<lparr>nodes=N, edges=E\<rparr> v"
   apply(simp add: num_reachable_def)
   apply(frule_tac E'="E'" and v="v" in succ_tran_mono, simp)
   apply(frule_tac v="v" in succ_tran_finite)
   apply(simp add: card_mono)
  done

  --"num_reachable_norefl"
  lemma num_reachable_norefl_mono:
  "valid_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> num_reachable_norefl \<lparr>nodes=N, edges=E'\<rparr> v \<le> num_reachable_norefl \<lparr>nodes=N, edges=E\<rparr> v"
   apply(simp add: num_reachable_norefl_def)
   apply(frule_tac E'="E'" and v="v" in succ_tran_mono, simp)
   apply(frule_tac v="v" in succ_tran_finite)
   using card_mono by (metis Diff_mono finite_Diff subset_refl)

  --"backflows"
  lemma backflows_valid:
    "valid_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> valid_graph \<lparr>nodes=N, edges=backflows E\<rparr>"
    using [[simproc add: finite_Collect]] by(auto simp add: valid_graph_def backflows_def)
  lemma undirected_backflows:
    "undirected G = \<lparr> nodes = nodes G, edges = (edges G) \<union> backflows (edges G) \<rparr>"
    by(simp add: backflows_def undirected_def)
  lemma backflows_id:
    "backflows (backflows E) = E"
    by(simp add: backflows_def)

lemmas graph_ops=add_node_def delete_node_def add_edge_def delete_edge_def delete_edges_simp2

  --"valid_graph"
  lemma valid_graph_remove_edges: "valid_graph \<lparr> nodes = V, edges = E \<rparr> \<Longrightarrow> valid_graph \<lparr> nodes = V, edges=E - X\<rparr>"
    by (metis delete_edges_simp2 delete_edges_valid select_convs(1) select_convs(2))

  lemma valid_graph_remove_edges_union:
    "valid_graph \<lparr> nodes = V, edges = E \<union> E' \<rparr> \<Longrightarrow> valid_graph \<lparr> nodes = V, edges=E\<rparr>"
    by(auto simp add: valid_graph_def)

  lemma valid_graph_union_edges: "\<lbrakk> valid_graph \<lparr> nodes = V, edges = E \<rparr>; valid_graph \<lparr> nodes = V, edges=E'\<rparr> \<rbrakk> \<Longrightarrow>
     valid_graph \<lparr> nodes = V, edges=E \<union> E'\<rparr>"
    by(auto simp add: valid_graph_def)

  lemma valid_graph_add_subset_edges: "\<lbrakk> valid_graph \<lparr> nodes = V, edges = E \<rparr>; E' \<subseteq> E \<rbrakk> \<Longrightarrow>
     valid_graph \<lparr> nodes = V, edges= E \<union> E'\<rparr>"
    by(auto simp add: valid_graph_def) (metis rev_finite_subset)

(*Inspired by
Benedikt Nordhoff and Peter Lammich
Dijkstra's Shortest Path Algorithm
http://afp.sourceforge.net/entries/Dijkstra_Shortest_Path.shtml*)
(*more a literal copy of http://afp.sourceforge.net/browser_info/current/AFP/Dijkstra_Shortest_Path/Graph.html*)

  text {* Successors of a node. *}
  definition succ :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set"
    where "succ G v \<equiv> {v'. (v,v')\<in>edges G}"

  lemma succ_finite[simp, intro]: "finite (edges G) \<Longrightarrow> finite (succ G v)"
    unfolding succ_def
    by (rule finite_subset[where B="snd`edges G"]) force+

  lemma succ_empty: "succ empty v = {}" unfolding empty_def succ_def by auto

  lemma (in valid_graph) succ_subset: "succ G v \<subseteq> V"
    unfolding succ_def using E_valid
    by (force)

end