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

section \<open>Rational numbers\<close>

theory Rat
  imports Archimedean_Field
begin

subsection \<open>Rational numbers as quotient\<close>

subsubsection \<open>Construction of the type of rational numbers\<close>

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 *: "ratrel (a, b) (a', b')"
  assume **: "ratrel (a', b') (a'', b'')"
  have "b' * (a * b'') = b'' * (a * b')" by simp
  also from * have "a * b' = a' * b" by auto
  also have "b'' * (a' * b) = b * (a' * b'')" by simp
  also from ** 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 ** have "b' \<noteq> 0" by auto
  ultimately have "a * b'' = a'' * b" by simp
  with * ** 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 \<open>Representation and basic operations\<close>

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:
  "\<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>a. Fract a 0 = Fract 0 1"
  "\<And>a c. Fract 0 a = Fract 0 c"
  by (transfer, simp)+

lemma Rat_cases [case_names Fract, cases type: rat]:
  assumes that: "\<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: "q = Fract a b" and b: "b \<noteq> 0"
    by transfer simp
  let ?a = "a div gcd a b"
  let ?b = "b div gcd a b"
  from b have "?b * gcd a b = b"
    by simp
  with b have "?b \<noteq> 0"
    by fastforce
  with q b have q2: "q = Fract ?a ?b"
    by (simp add: eq_rat dvd_div_mult mult.commute [of a])
  from b have coprime: "coprime ?a ?b"
    by (auto intro: div_gcd_coprime)
  show C
  proof (cases "b > 0")
    case True
    then have "?b > 0"
      by (simp add: nonneg1_imp_zdiv_pos_iff)
    from q2 this coprime show C by (rule that)
  next
    case False
    have "q = Fract (- ?a) (- ?b)"
      unfolding q2 by transfer simp
    moreover from False b have "- ?b > 0"
      by (simp add: pos_imp_zdiv_neg_iff)
    moreover from coprime have "coprime (- ?a) (- ?b)"
      by simp
    ultimately show C
      by (rule that)
  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
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 (auto simp: 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" for q r :: rat

lemma diff_rat [simp]:
  "b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
  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: "c \<noteq> 0 \<Longrightarrow> Fract (c * a) (c * b) = Fract a b"
  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 div r = q * inverse r" for q r :: rat

lemma divide_rat [simp]: "Fract a b div 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
  show "inverse q * q = 1" if "q \<noteq> 0"
    using that by transfer simp
  show "q div r = q * inverse r"
    by (fact divide_rat_def)
  show "inverse 0 = (0::rat)"
    by transfer simp
qed

end

(* We cannot state these two rules earlier because of pending sort hypotheses *)
lemma div_add_self1_no_field [simp]:
  assumes "NO_MATCH (x :: 'b :: field) b" "(b :: 'a :: euclidean_semiring_cancel) \<noteq> 0"
  shows "(b + a) div b = a div b + 1"
  using assms(2) by (fact div_add_self1)

lemma div_add_self2_no_field [simp]:
  assumes "NO_MATCH (x :: 'b :: field) b" "(b :: 'a :: euclidean_semiring_cancel) \<noteq> 0"
  shows "(a + b) div b = a div b + 1"
  using assms(2) by (fact div_add_self2)

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"]
    and 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"
    and 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" "b > 0" "coprime a b"
    by (cases q) auto
  with False have "0 \<noteq> Fract a b"
    by simp
  with \<open>b > 0\<close> have "a \<noteq> 0"
    by (simp add: Zero_rat_def eq_rat)
  with Fract * show C by blast
qed

subsubsection \<open>Function \<open>normalize\<close>\<close>

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 *: "p * s = q * r"
    if "p * gcd r s = sgn (q * s) * r * gcd p q" and "q * gcd r s = sgn (q * s) * s * gcd p q"
  proof -
    from that 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 ?thesis
      by (auto simp add: ac_simps sgn_mult sgn_0_0)
  qed
  from assms show ?thesis
    by (auto simp: normalize_def Let_def dvd_div_div_eq_mult mult.commute sgn_mult
        split: if_splits intro: *)
qed

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

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

lemma normalize_coprime: "normalize r = (p, q) \<Longrightarrow> coprime p q"
  by (auto simp: normalize_def Let_def dvd_div_neg div_gcd_coprime split: if_split_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\<open>
  Decompose a fraction into normalized, i.e. coprime numerator and denominator:
\<close>

definition quotient_of :: "rat \<Rightarrow> int \<times> int"
  where "quotient_of x =
    (THE pair. x = Fract (fst pair) (snd pair) \<and> snd pair > 0 \<and> 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
    assume r: "r = Fract (fst p) (snd p) \<and> snd p > 0 \<and> coprime (fst p) (snd p)"
    obtain c d where p: "p = (c, d)" by (cases p)
    with r have Fract': "r = Fract c d" "d > 0" "coprime c d"
      by simp_all
    have "(c, d) = (a, 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 \<open>b > 0\<close> \<open>d > 0\<close> have "a > 0 \<longleftrightarrow> c > 0"
        by (simp add: zero_less_mult_iff)
      with \<open>a \<noteq> 0\<close> \<open>c \<noteq> 0\<close> have sgn: "sgn a = sgn c"
        by (auto simp add: not_less)
      from \<open>coprime a b\<close> \<open>coprime c d\<close> 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 \<open>b > 0\<close> \<open>d > 0\<close> 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
  then 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 [OF quotient_of_unique])
  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_denom_pos': "snd (quotient_of r) > 0"
  using quotient_of_denom_pos [of r] by (simp add: prod_eq_iff)

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 \<open>Various\<close>

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 \<Longrightarrow> 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
  then show ?thesis using Fract_of_int_quotient
    by simp
qed

subsubsection \<open>The ordered field of rational numbers\<close>

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"
  then have "a * d * b * d = c * b * b * d"
    by simp
  then have "a * b * d\<^sup>2 = c * d * b\<^sup>2"
    unfolding power2_eq_square by (simp add: ac_simps)
  then have "0 < a * b * d\<^sup>2 \<longleftrightarrow> 0 < c * d * b\<^sup>2"
    by simp
  then show "0 < a * b \<longleftrightarrow> 0 < c * d"
    using \<open>b \<noteq> 0\<close> and \<open>d \<noteq> 0\<close>
    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 (auto simp add: zero_less_mult_iff 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)"
  apply transfer
  by (metis fst_conv mult.commute mult_pos_neg2 snd_conv zero_less_mult_iff)

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

instantiation rat :: linordered_field
begin

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

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

definition "\<bar>a\<bar> = (if a < 0 then - a else a)" for a :: rat

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

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
    using positive_add positive_zero by force
  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
    using positive_add by fastforce
  show "a \<le> b \<Longrightarrow> b \<le> a \<Longrightarrow> a = b"
    unfolding less_eq_rat_def less_rat_def
    using positive_add positive_zero by fastforce
  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 (metis diff_zero positive_mult right_diff_distrib')
qed

end

instantiation rat :: distrib_lattice
begin

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

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

instance
  by standard (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]:
  "b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
  by (simp add: less_rat_def positive_rat algebra_simps)

lemma le_rat [simp]:
  "b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
  by (simp add: le_less 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)
  case (Fract a b)
  have step': "P (Fract a b)" if b: "b < 0" for a b :: int
  proof -
    from b have "0 < - b"
      by simp
    then have "P (Fract (- a) (- b))"
      by (rule step)
    then show "P (Fract a b)"
      by (simp add: order_less_imp_not_eq [OF b])
  qed
  from Fract show "P q"
    by (auto 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 \<open>Rationals are an Archimedean field\<close>

lemma rat_floor_lemma: "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
  show "\<exists>z. r \<le> of_int z" for r :: rat
  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 floor_rat :: "rat \<Rightarrow> int"
  where"\<lfloor>x\<rfloor> = (THE z. of_int z \<le> x \<and> x < of_int (z + 1))" for x :: rat

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

end

lemma floor_Fract [simp]: "\<lfloor>Fract a b\<rfloor> = a div b"
  by (simp add: Fract_of_int_quotient floor_divide_of_int_eq)

subsection \<open>Linear arithmetic setup\<close>

declaration \<open>
  K (Lin_Arith.add_inj_thms @{thms of_int_le_iff [THEN iffD2] of_int_eq_iff [THEN iffD2]}
    (* not needed because x < (y::int) can be rewritten as x + 1 <= y: of_int_less_iff RS iffD2 *)
  #> Lin_Arith.add_inj_const (\<^const_name>\<open>of_nat\<close>, \<^typ>\<open>nat \<Rightarrow> rat\<close>)
  #> Lin_Arith.add_inj_const (\<^const_name>\<open>of_int\<close>, \<^typ>\<open>int \<Rightarrow> rat\<close>))
\<close>

subsection \<open>Embedding from Rationals to other Fields\<close>

context field_char_0
begin

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

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"
  by transfer (simp add: divide_inverse nonzero_inverse_mult_distrib ac_simps)

lemma of_rat_sum: "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_prod: "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)"
  by (rule inverse_unique [symmetric]) (simp add: of_rat_mult [symmetric])

lemma of_rat_inverse: "(of_rat (inverse a) :: 'a::field_char_0) = 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) = 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 \<longleftrightarrow> a = b"
  apply transfer
  apply (simp add: nonzero_divide_eq_eq nonzero_eq_divide_eq flip: of_int_mult)
  done

lemma of_rat_eq_0_iff [simp]: "of_rat a = 0 \<longleftrightarrow> a = 0"
  using of_rat_eq_iff [of _ 0] by simp

lemma zero_eq_of_rat_iff [simp]: "0 = of_rat a \<longleftrightarrow> 0 = a"
  by simp

lemma of_rat_eq_1_iff [simp]: "of_rat a = 1 \<longleftrightarrow> a = 1"
  using of_rat_eq_iff [of _ 1] by simp

lemma one_eq_of_rat_iff [simp]: "1 = of_rat a \<longleftrightarrow> 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 \<open>b * d > 0\<close>
    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 \<longleftrightarrow> 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) \<longleftrightarrow> 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 \<longleftrightarrow> 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) \<longleftrightarrow> 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 \<longleftrightarrow> 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) \<longleftrightarrow> 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 \<longleftrightarrow> 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) \<longleftrightarrow> 1 < r"
  using of_rat_less [of 1 r] by simp

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

lemma abs_of_rat [simp]:
  "\<bar>of_rat r\<bar> = (of_rat \<bar>r\<bar> :: 'a :: linordered_field)"
  by (cases "r \<ge> 0") (simp_all add: not_le of_rat_minus)

text \<open>Collapse nested embeddings.\<close>
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

lemma of_rat_floor [simp]:
  "\<lfloor>of_rat r\<rfloor> = \<lfloor>r\<rfloor>"
  by (cases r) (simp add: Fract_of_int_quotient of_rat_divide floor_divide_of_int_eq)

lemma of_rat_ceiling [simp]:
  "\<lceil>of_rat r\<rceil> = \<lceil>r\<rceil>"
  using of_rat_floor [of "- r"] by (simp add: of_rat_minus ceiling_def)

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 \<open>The Set of Rational Numbers\<close>

context field_char_0
begin

definition Rats :: "'a set" ("\<rat>")
  where "\<rat> = range of_rat"

end

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

lemma Rats_cases':
  assumes "(x :: 'a :: field_char_0) \<in> \<rat>"
  obtains a b where "b > 0" "coprime a b" "x = of_int a / of_int b"
proof -
  from assms obtain r where "x = of_rat r"
    by (auto simp: Rats_def)
  obtain a b where quot: "quotient_of r = (a,b)" by force
  have "b > 0" using quotient_of_denom_pos[OF quot] .
  moreover have "coprime a b" using quotient_of_coprime[OF quot] .
  moreover have "x = of_int a / of_int b" unfolding \<open>x = of_rat r\<close>
      quotient_of_div[OF quot] by (simp add: of_rat_divide)
  ultimately show ?thesis using that by blast
qed

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

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

lemma Ints_subset_Rats: "\<int> \<subseteq> \<rat>"
  using Ints_cases Rats_of_int by blast

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

lemma Nats_subset_Rats: "\<nat> \<subseteq> \<rat>"
  using Ints_subset_Rats Nats_subset_Ints by blast

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

lemma Rats_0 [simp]: "0 \<in> \<rat>"
  unfolding Rats_def by (rule range_eqI) (rule of_rat_0 [symmetric])

lemma Rats_1 [simp]: "1 \<in> \<rat>"
  unfolding Rats_def by (rule range_eqI) (rule of_rat_1 [symmetric])

lemma Rats_add [simp]: "a \<in> \<rat> \<Longrightarrow> b \<in> \<rat> \<Longrightarrow> a + b \<in> \<rat>"
  by (metis Rats_cases Rats_of_rat of_rat_add)

lemma Rats_minus_iff [simp]: "- a \<in> \<rat> \<longleftrightarrow> a \<in> \<rat>"
  by (metis Rats_cases Rats_of_rat add.inverse_inverse of_rat_minus)

lemma Rats_diff [simp]: "a \<in> \<rat> \<Longrightarrow> b \<in> \<rat> \<Longrightarrow> a - b \<in> \<rat>"
  by (metis Rats_add Rats_minus_iff diff_conv_add_uminus)

lemma Rats_mult [simp]: "a \<in> \<rat> \<Longrightarrow> b \<in> \<rat> \<Longrightarrow> a * b \<in> \<rat>"
  by (metis Rats_cases Rats_of_rat of_rat_mult)

lemma Rats_inverse [simp]: "a \<in> \<rat> \<Longrightarrow> inverse a \<in> \<rat>"
  for a :: "'a::field_char_0"
  by (metis Rats_cases Rats_of_rat of_rat_inverse)

lemma Rats_divide [simp]: "a \<in> \<rat> \<Longrightarrow> b \<in> \<rat> \<Longrightarrow> a / b \<in> \<rat>"
  for a b :: "'a::field_char_0"
  by (simp add: divide_inverse)

lemma Rats_power [simp]: "a \<in> \<rat> \<Longrightarrow> a ^ n \<in> \<rat>"
  for a :: "'a::field_char_0"
  by (metis Rats_cases Rats_of_rat of_rat_power)

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)

lemma Rats_add_iff: "a \<in> \<rat> \<or> b \<in> \<rat> \<Longrightarrow> a+b \<in> \<rat> \<longleftrightarrow> a \<in> \<rat> \<and> b \<in> \<rat>"
  by (metis Rats_add Rats_diff add_diff_cancel add_diff_cancel_left')

lemma Rats_diff_iff: "a \<in> \<rat> \<or> b \<in> \<rat> \<Longrightarrow> a-b \<in> \<rat> \<longleftrightarrow> a \<in> \<rat> \<and> b \<in> \<rat>"
  by (metis Rats_add_iff diff_add_cancel)

lemma Rats_mult_iff: "a \<in> \<rat>-{0} \<or> b \<in> \<rat>-{0} \<Longrightarrow> a*b \<in> \<rat> \<longleftrightarrow> a \<in> \<rat> \<and> b \<in> \<rat>"
  by (metis Diff_iff Rats_divide Rats_mult insertI1 mult.commute nonzero_divide_eq_eq)

lemma Rats_inverse_iff [simp]: "inverse a \<in> \<rat> \<longleftrightarrow> a \<in> \<rat>"
  using Rats_inverse by force

lemma Rats_divide_iff: "a \<in> \<rat>-{0} \<or> b \<in> \<rat>-{0} \<Longrightarrow> a/b \<in> \<rat> \<longleftrightarrow> a \<in> \<rat> \<and> b \<in> \<rat>"
  by (metis Rats_divide Rats_mult_iff divide_eq_0_iff divide_inverse nonzero_mult_div_cancel_right)

subsection \<open>Implementation of rational numbers as pairs of integers\<close>

text \<open>Formal constructor\<close>

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 \<open>Numerals\<close>

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 \<open>Operations\<close>

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 ac_simps)
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]: "\<lfloor>p\<rfloor> = (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
  by standard (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 \<open>Quickcheck\<close>

context
  includes term_syntax
begin

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

end

instantiation rat :: random
begin

context
  includes state_combinator_syntax
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

end

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
      (\<lambda>(l, _). Quickcheck_Exhaustive.full_exhaustive
        (\<lambda>k. f
          (let j = int_of_integer (integer_of_natural l) + 1
           in valterm_fract k (j, \<lambda>_. Code_Evaluation.term_of j))) d) d"

instance ..

end

instance rat :: partial_term_of ..

lemma [code]:
  "partial_term_of (ty :: rat itself) (Quickcheck_Narrowing.Narrowing_variable p tt) \<equiv>
    Code_Evaluation.Free (STR ''_'') (Typerep.Typerep (STR ''Rat.rat'') [])"
  "partial_term_of (ty :: rat itself) (Quickcheck_Narrowing.Narrowing_constructor 0 [l, k]) \<equiv>
    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 (\<lambda>nom denom. Fract nom denom)) narrowing) narrowing"

instance ..

end

subsection \<open>Setup for Nitpick\<close>

declaration \<open>
  Nitpick_HOL.register_frac_type \<^type_name>\<open>rat\<close>
    [(\<^const_name>\<open>Abs_Rat\<close>, \<^const_name>\<open>Nitpick.Abs_Frac\<close>),
     (\<^const_name>\<open>zero_rat_inst.zero_rat\<close>, \<^const_name>\<open>Nitpick.zero_frac\<close>),
     (\<^const_name>\<open>one_rat_inst.one_rat\<close>, \<^const_name>\<open>Nitpick.one_frac\<close>),
     (\<^const_name>\<open>plus_rat_inst.plus_rat\<close>, \<^const_name>\<open>Nitpick.plus_frac\<close>),
     (\<^const_name>\<open>times_rat_inst.times_rat\<close>, \<^const_name>\<open>Nitpick.times_frac\<close>),
     (\<^const_name>\<open>uminus_rat_inst.uminus_rat\<close>, \<^const_name>\<open>Nitpick.uminus_frac\<close>),
     (\<^const_name>\<open>inverse_rat_inst.inverse_rat\<close>, \<^const_name>\<open>Nitpick.inverse_frac\<close>),
     (\<^const_name>\<open>ord_rat_inst.less_rat\<close>, \<^const_name>\<open>Nitpick.less_frac\<close>),
     (\<^const_name>\<open>ord_rat_inst.less_eq_rat\<close>, \<^const_name>\<open>Nitpick.less_eq_frac\<close>),
     (\<^const_name>\<open>field_char_0_class.of_rat\<close>, \<^const_name>\<open>Nitpick.of_frac\<close>)]
\<close>

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 \<open>Float syntax\<close>

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

parse_translation \<open>
  let
    fun mk_frac str =
      let
        val {mant = i, exp = n} = Lexicon.read_float str;
        val exp = Syntax.const \<^const_syntax>\<open>Power.power\<close>;
        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>\<open>Fields.inverse_divide\<close> $ Numeral.mk_number_syntax i $ exp10 end;

    fun float_tr [(c as Const (\<^syntax_const>\<open>_constrain\<close>, _)) $ 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>\<open>_Float\<close>, K float_tr)] end
\<close>

text\<open>Test:\<close>
lemma "123.456 = -111.111 + 200 + 30 + 4 + 5/10 + 6/100 + (7/1000::rat)"
  by simp

subsection \<open>Hiding implementation details\<close>

hide_const (open) normalize positive

lifting_update rat.lifting
lifting_forget rat.lifting

end


(* Title:      Models of Dioids
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Models of Dioids\<close>

theory Dioid_Models_New
  imports Kleene_Algebra.Dioid
          HOL.Real
begin

text \<open>In this section we consider some well known models of
dioids. These so far include the powerset dioid over a monoid,
languages, binary relations, sets of traces, sets paths (in a graph),
as well as the min-plus and the max-plus semirings. Most of these
models are taken from an article about Kleene algebras with
domain~\<^cite>\<open>"desharnaismoellerstruth06kad"\<close>.

The advantage of formally linking these models with the abstract
axiomatisations of dioids is that all abstract theorems are
automatically available in all models. It therefore makes sense to
establish models for the strongest possible axiomatisations (whereas
theorems should be proved for the weakest ones).\<close>

subsection \<open>The Powerset Dioid over a Monoid\<close>

text \<open>We assume a multiplicative monoid and define the usual complex
product on sets of elements. We formalise the well known result that
this lifting induces a dioid.\<close>

(* change here! *)

instantiation set :: (semigroup_mult) semigroup_mult
begin

definition times_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where \<comment> \<open>the complex product\<close>
  "times_set A B = {u * v | u v. u \<in> A \<and> v \<in> B}"

instance
  apply intro_classes
  unfolding times_set_def
  by (clarsimp, metis (no_types, opaque_lifting) mult.assoc)

end

instantiation set :: (monoid_mult) monoid_mult
begin

  definition one_set :: "'a set" where
    "one_set = {1}"

instance
  apply intro_classes
  unfolding one_set_def times_set_def by auto

end (* instantiation and end of change *)

instantiation set :: (monoid_mult) dioid_one_zero
begin

  definition zero_set_def:
    "0 = {}"

  definition plus_set_def:
    "A + B = A \<union> B"

  instance
  proof
    fix X Y Z :: "'a set"
    show "X + Y + Z = X + (Y + Z)"
      by (simp add: Un_assoc plus_set_def)
    show "X + Y = Y + X"
      by (simp add: Un_commute plus_set_def)
    show "(X + Y) \<cdot> Z = X \<cdot> Z + Y \<cdot> Z"
      by (auto simp add: plus_set_def times_set_def)
    show "1 \<cdot> X = X"
      by (simp add: one_set_def times_set_def)
    show "X \<cdot> 1 = X"
      by (simp add: one_set_def times_set_def)
    show "0 + X = X"
      by (simp add: plus_set_def zero_set_def)
    show "0 \<cdot> X = 0"
      by (simp add: times_set_def zero_set_def)
    show "X \<cdot> 0 = 0"
      by (simp add: times_set_def zero_set_def)
    show "X \<subseteq> Y \<longleftrightarrow> X + Y = Y"
      by (simp add: plus_set_def subset_Un_eq)
    show "X \<subset> Y \<longleftrightarrow> X \<subseteq> Y \<and> X \<noteq> Y"
      by (fact psubset_eq)
    show "X + X = X"
      by (simp add: Un_absorb plus_set_def)
    show "X \<cdot> (Y + Z) = X \<cdot> Y + X \<cdot> Z"
      by (auto simp add: plus_set_def times_set_def)
  qed

end (* instantiation *)

subsection \<open>Language Dioids\<close>

text \<open>Language dioids arise as special cases of the monoidal lifting
because sets of words form free monoids. Moreover, monoids of words
are isomorphic to monoids of lists under append.

To show that languages form dioids it therefore suffices to show that
sets of lists closed under append and multiplication with the empty
word form a (multiplicative) monoid. Isabelle then does the rest of the work
automatically. Infix~\<open>@\<close> denotes word
concatenation.\<close>

instantiation list :: (type) monoid_mult
begin

  definition times_list_def:
    "xs * ys \<equiv> xs @ ys"

  definition one_list_def:
    "1 \<equiv> []"

  instance proof
    fix xs ys zs :: "'a list"
    show "xs * ys * zs = xs * (ys * zs)"
      by (simp add: times_list_def)
    show "1 * xs = xs"
      by (simp add: one_list_def times_list_def)
    show "xs * 1 = xs"
      by (simp add: one_list_def times_list_def)
  qed

end  (* instantiation *)

text \<open>Languages as sets of lists have already been formalised in
Isabelle in various places. We can now obtain much of their algebra
for free.\<close>

type_synonym 'a lan = "'a list set"

interpretation lan_dioid: dioid_one_zero "(+)" "(\<cdot>)" "1::'a lan" "0" "(\<subseteq>)" "(\<subset>)" ..

subsection \<open>Relation Dioids\<close>

text \<open>We now show that binary relations under union, relational
composition, the identity relation, the empty relation and set
inclusion form dioids. Due to the well developed relation library of
Isabelle this is entirely trivial.\<close>

interpretation rel_dioid: dioid_one_zero "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)"
  by (unfold_locales, auto)

interpretation rel_monoid: monoid_mult Id "(O)" ..

subsection \<open>Trace Dioids\<close>

text \<open>Traces have been considered, for instance, by
Kozen~\<^cite>\<open>"kozen00hoare"\<close> in the context of Kleene algebras with
tests. Intuitively, a trace is an execution sequence of a labelled
transition system from some state to some other state, in which state
labels and action labels alternate, and which begin and end with a
state label.

Traces generalise words: words can be obtained from traces by
forgetting state labels. Similarly, sets of traces generalise
languages.

In this section we show that sets of traces under union, an
appropriately defined notion of complex product, the set of all traces
of length zero, the empty set of traces and set inclusion form a
dioid.

We first define the notion of trace and the product of traces, which
has been called \emph{fusion product} by Kozen.\<close>

type_synonym ('p, 'a) trace = "'p \<times> ('a \<times> 'p) list"

definition first :: "('p, 'a) trace \<Rightarrow> 'p" where
  "first = fst"

lemma first_conv [simp]: "first (p, xs) = p"
  by (unfold first_def, simp)

fun last :: "('p, 'a) trace \<Rightarrow> 'p" where
  "last (p, []) = p"
| "last (_, xs) = snd (List.last xs)"

lemma last_append [simp]: "last (p, xs @ ys) = last (last (p, xs), ys)"
proof (cases xs)
  show "xs = [] \<Longrightarrow> last (p, xs @ ys) = last (last (p, xs), ys)"
    by simp
  show "\<And>a list. xs = a # list \<Longrightarrow>
    last (p, xs @ ys) = last (last (p, xs), ys)"
  proof (cases ys)
    show "\<And>a list. \<lbrakk>xs = a # list; ys = []\<rbrakk>
      \<Longrightarrow> last (p, xs @ ys) = last (last (p, xs), ys)"
      by simp
    show "\<And>a list aa lista. \<lbrakk>xs = a # list; ys = aa # lista\<rbrakk>
      \<Longrightarrow> last (p, xs @ ys) = last (last (p, xs), ys)"
      by simp
  qed
qed

text \<open>The fusion product is a partial operation. It is undefined if
the last element of the first trace and the first element of the
second trace are different. If these elements are the same, then the
fusion product removes the first element from the second trace and
appends the resulting object to the first trace.\<close>

definition t_fusion :: "('p, 'a) trace \<Rightarrow> ('p, 'a) trace \<Rightarrow> ('p, 'a) trace" where
  "t_fusion x y \<equiv> if last x = first y then (fst x, snd x @ snd y) else undefined"

text \<open>We now show that the first element and the last element of a
trace are a left and right unit for that trace and prove some other
auxiliary lemmas.\<close>

lemma t_fusion_leftneutral [simp]: "t_fusion (first x, []) x = x"
  by (cases x, simp add: t_fusion_def)

lemma fusion_rightneutral [simp]: "t_fusion x (last x, []) = x"
  by (simp add: t_fusion_def)

lemma first_t_fusion [simp]: "last x = first y \<Longrightarrow> first (t_fusion x y) = first x"
  by (simp add: first_def t_fusion_def)

lemma last_t_fusion [simp]: "last x = first y \<Longrightarrow> last (t_fusion x y) = last y"
  by (simp add: first_def t_fusion_def)

text \<open>Next we show that fusion of traces is associative.\<close>

lemma t_fusion_assoc [simp]:
  "\<lbrakk> last x = first y; last y = first z \<rbrakk> \<Longrightarrow> t_fusion x (t_fusion y z) = t_fusion (t_fusion x y) z"
  by (cases x, cases y, cases z, simp add: t_fusion_def)

subsection \<open>Sets of Traces\<close>

text \<open>We now lift the fusion product to a complex product on sets of
traces. This operation is total.\<close>

no_notation
  times (infixl "\<cdot>" 70)

definition t_prod :: "('p, 'a) trace set \<Rightarrow> ('p, 'a) trace set \<Rightarrow> ('p, 'a) trace set" (infixl "\<cdot>" 70)
where "X \<cdot> Y = {t_fusion u v| u v. u \<in> X \<and> v \<in> Y \<and> last u = first v}"

text \<open>Next we define the empty set of traces and the set of traces
of length zero as the multiplicative unit of the trace dioid.\<close>

definition t_zero :: "('p, 'a) trace set" where
  "t_zero \<equiv> {}"

definition t_one :: "('p, 'a) trace set" where
  "t_one \<equiv> \<Union>p. {(p, [])}"

text \<open>We now provide elimination rules for trace products.\<close>

lemma t_prod_iff:
  "w \<in> X\<cdot>Y \<longleftrightarrow> (\<exists>u v. w = t_fusion u v \<and> u \<in> X \<and> v \<in> Y \<and> last u = first v)"
  by (unfold t_prod_def) auto

lemma t_prod_intro [simp, intro]:
  "\<lbrakk> u \<in> X; v \<in> Y; last u = first v \<rbrakk> \<Longrightarrow> t_fusion u v \<in> X\<cdot>Y"
  by (meson t_prod_iff)

lemma t_prod_elim [elim]:
  "w \<in> X\<cdot>Y \<Longrightarrow> \<exists>u v. w = t_fusion u v \<and> u \<in> X \<and> v \<in> Y \<and> last u = first v"
  by (meson t_prod_iff)

text \<open>Finally we prove the interpretation statement that sets of traces
under union and the complex product based on trace fusion together
with the empty set of traces and the set of traces of length one forms
a dioid.\<close>

interpretation trace_dioid: dioid_one_zero "(\<union>)" t_prod t_one t_zero "(\<subseteq>)" "(\<subset>)"
apply unfold_locales
apply (auto simp add: t_prod_def t_one_def t_zero_def t_fusion_def)
apply (metis last_append)
apply (metis last_append append_assoc)
done

no_notation
  t_prod (infixl "\<cdot>" 70)

subsection \<open>The Path Diod\<close>

text \<open>The next model we consider are sets of paths in a graph. We
consider two variants, one that contains the empty path and one that
doesn't. The former leads to more difficult proofs and a more involved
specification of the complex product. We start with paths that include
the empty path. In this setting, a path is a list of nodes.\<close>

subsection \<open>Path Models with the Empty Path\<close>

type_synonym 'a path = "'a list"

text \<open>Path fusion is defined similarly to trace
fusion. Mathematically it should be a partial operation. The fusion of
two empty paths yields the empty path; the fusion between a non-empty
path and an empty one is undefined; the fusion of two non-empty paths
appends the tail of the second path to the first one.

We need to use a total alternative and make sure that undefined paths
do not contribute to the complex product.\<close>

fun p_fusion :: "'a path \<Rightarrow> 'a path \<Rightarrow> 'a path" where
  "p_fusion [] _ = []"
| "p_fusion _ [] = []"
| "p_fusion ps (q # qs) = ps @ qs"

lemma p_fusion_assoc:
  "p_fusion ps (p_fusion qs rs) = p_fusion (p_fusion ps qs) rs"
proof (induct rs)
  case Nil show ?case
    by (metis p_fusion.elims p_fusion.simps(2))
  case Cons show ?case
  proof (induct qs)
    case Nil show ?case
      by (metis neq_Nil_conv p_fusion.simps(1) p_fusion.simps(2))
    case Cons show ?case
      proof -
        have "\<forall>ps. ([] = ps \<or> hd ps # tl ps = ps) \<and> ((\<forall>q qs. q # qs \<noteq> ps) \<or> [] \<noteq> ps)"
          using list.collapse by fastforce
        moreover hence "\<forall>ps q qs. p_fusion ps (q # qs) = ps @ qs \<or> [] = ps"
          by (metis p_fusion.simps(3))
        ultimately show ?thesis
          by (metis (no_types) Cons_eq_appendI append_eq_appendI p_fusion.simps(1) p_fusion.simps(3))
      qed
  qed
qed

text \<open>This lemma overapproximates the real situation, but it holds
in all cases where path fusion should be defined.\<close>

lemma p_fusion_last:
  assumes "List.last ps = hd qs"
  and "ps \<noteq> []"
  and "qs \<noteq> []"
  shows "List.last (p_fusion ps qs) = List.last qs"
  by (metis (opaque_lifting, no_types) List.last.simps List.last_append append_Nil2 assms list.sel(1) neq_Nil_conv p_fusion.simps(3))

lemma p_fusion_hd: "\<lbrakk>ps \<noteq> []; qs \<noteq> []\<rbrakk> \<Longrightarrow> hd (p_fusion ps qs) = hd ps"
  by (metis list.exhaust p_fusion.simps(3) append_Cons list.sel(1))

lemma nonempty_p_fusion: "\<lbrakk>ps \<noteq> []; qs \<noteq> []\<rbrakk> \<Longrightarrow> p_fusion ps qs \<noteq> []"
  by (metis list.exhaust append_Cons p_fusion.simps(3) list.simps(2))

text \<open>We now define a condition that filters out undefined paths in
the complex product.\<close>

abbreviation p_filter :: "'a path \<Rightarrow> 'a path \<Rightarrow> bool" where
"p_filter ps qs \<equiv> ((ps = [] \<and> qs = []) \<or> (ps \<noteq> [] \<and> qs \<noteq> [] \<and> (List.last ps) = hd qs))"

no_notation
  times (infixl "\<cdot>" 70)

definition p_prod :: "'a path set \<Rightarrow> 'a path set \<Rightarrow> 'a path set" (infixl "\<cdot>" 70)
where "X \<cdot> Y = {rs . \<exists>ps \<in> X. \<exists>qs \<in> Y. rs = p_fusion ps qs \<and> p_filter ps qs}"

lemma p_prod_iff:
  "ps \<in> X \<cdot> Y \<longleftrightarrow> (\<exists>qs rs. ps = p_fusion qs rs \<and> qs \<in> X \<and> rs \<in> Y \<and> p_filter qs rs)"
  by (unfold p_prod_def) auto

text \<open>Due to the complexity of the filter condition, proving
properties of complex products can be tedious.\<close>

lemma p_prod_assoc: "(X \<cdot> Y) \<cdot> Z = X \<cdot> (Y \<cdot> Z)"
proof (rule set_eqI)
  fix ps
  show "ps \<in> (X \<cdot> Y) \<cdot> Z \<longleftrightarrow> ps \<in> X \<cdot> (Y \<cdot> Z)"
  proof (cases ps)
    case Nil thus ?thesis
      by auto (metis nonempty_p_fusion p_prod_iff)+
  next
    case Cons thus ?thesis
      by (auto simp add: p_prod_iff) (metis (opaque_lifting, mono_tags) nonempty_p_fusion p_fusion_assoc p_fusion_hd p_fusion_last)+
  qed
qed

text \<open>We now define the multiplicative unit of the path dioid as the
set of all paths of length one, including the empty path, and show the
unit laws with respect to the path product.\<close>

definition p_one :: "'a path set" where
  "p_one \<equiv> {p . \<exists>q::'a. p = [q]} \<union> {[]}"

lemma p_prod_onel [simp]: "p_one \<cdot> X = X"
proof (rule set_eqI)
    fix ps
    show "ps \<in> p_one \<cdot> X \<longleftrightarrow> ps \<in> X"
    proof (cases ps)
      case Nil thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis nonempty_p_fusion not_Cons_self)
    next
      case Cons thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis append_Cons append_Nil list.sel(1) neq_Nil_conv p_fusion.simps(3), metis Cons_eq_appendI list.sel(1) last_ConsL list.simps(3) p_fusion.simps(3) self_append_conv2)
    qed
qed

lemma p_prod_oner [simp]: "X \<cdot> p_one = X"
proof (rule set_eqI)
    fix ps
    show "ps \<in> X \<cdot> p_one \<longleftrightarrow> ps \<in> X"
    proof (cases ps)
      case Nil thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis nonempty_p_fusion not_Cons_self2, metis p_fusion.simps(1))
    next
      case Cons thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis append_Nil2 neq_Nil_conv p_fusion.simps(3), metis list.sel(1) list.simps(2) p_fusion.simps(3) self_append_conv)
    qed
qed

text \<open>Next we show distributivity laws at the powerset level.\<close>

lemma p_prod_distl: "X \<cdot> (Y \<union> Z) = X \<cdot> Y \<union> X \<cdot> Z"
proof (rule set_eqI)
  fix ps
  show "ps \<in> X \<cdot> (Y \<union> Z) \<longleftrightarrow> ps \<in> X \<cdot> Y \<union> X \<cdot> Z"
  by (cases ps) (auto simp add: p_prod_iff)
qed

lemma p_prod_distr: "(X \<union> Y) \<cdot> Z = X \<cdot> Z \<union> Y \<cdot> Z"
proof (rule set_eqI)
  fix ps
  show "ps \<in> (X \<union> Y) \<cdot> Z \<longleftrightarrow> ps \<in> X \<cdot> Z \<union> Y \<cdot> Z"
    by (cases ps) (auto simp add: p_prod_iff)
qed

text \<open>Finally we show that sets of paths under union, the complex
product, the unit set and the empty set form a dioid.\<close>

interpretation path_dioid: dioid_one_zero "(\<union>)" "(\<cdot>)" p_one "{}" "(\<subseteq>)" "(\<subset>)"
proof
  fix x y z :: "'a path set"
  show  "x \<union> y \<union> z = x \<union> (y \<union> z)"
    by auto
  show "x \<union> y = y \<union> x"
    by auto
  show "(x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    by (fact p_prod_assoc)
  show "(x \<union> y) \<cdot> z = x \<cdot> z \<union> y \<cdot> z"
    by (fact p_prod_distr)
  show "p_one \<cdot> x = x"
    by (fact p_prod_onel)
  show "x \<cdot> p_one = x"
    by (fact p_prod_oner)
  show "{} \<union> x = x"
    by auto
  show "{} \<cdot> x = {}"
    by (metis all_not_in_conv p_prod_iff)
  show "x \<cdot> {} = {}"
    by (metis all_not_in_conv p_prod_iff)
  show "(x \<subseteq> y) = (x \<union> y = y)"
    by auto
  show "(x \<subset> y) = (x \<subseteq> y \<and> x \<noteq> y)"
    by auto
  show "x \<union> x = x"
    by auto
  show "x \<cdot> (y \<union> z) = x \<cdot> y \<union> x \<cdot> z"
    by (fact p_prod_distl)
qed

no_notation
  p_prod (infixl "\<cdot>" 70)

subsection \<open>Path Models without the Empty Path\<close>

text \<open>We now build a model of paths that does not include the empty
path and therefore leads to a simpler complex product.\<close>

datatype 'a ppath = Node 'a | Cons 'a "'a ppath"

primrec pp_first :: "'a ppath \<Rightarrow> 'a" where
  "pp_first (Node x)   = x"
| "pp_first (Cons x _) = x"

primrec pp_last :: "'a ppath \<Rightarrow> 'a" where
  "pp_last (Node x)    = x"
| "pp_last (Cons _ xs) = pp_last xs"

text \<open>The path fusion product (although we define it as a total
funcion) should only be applied when the last element of the first
argument is equal to the first element of the second argument.\<close>

primrec pp_fusion :: "'a ppath \<Rightarrow> 'a ppath \<Rightarrow> 'a ppath" where
  "pp_fusion (Node x) ys = ys"
| "pp_fusion (Cons x xs) ys = Cons x (pp_fusion xs ys)"

text \<open>We now go through the same steps as for traces and paths
before, showing that the first and last element of a trace a left or
right unit for that trace and that the fusion product on traces is
associative.\<close>

lemma pp_fusion_leftneutral [simp]: "pp_fusion (Node (pp_first x)) x = x"
  by simp

lemma pp_fusion_rightneutral [simp]: "pp_fusion x (Node (pp_last x)) = x"
  by (induct x) simp_all

lemma pp_first_pp_fusion [simp]:
  "pp_last x = pp_first y \<Longrightarrow> pp_first (pp_fusion x y) = pp_first x"
  by (induct x) simp_all

lemma pp_last_pp_fusion [simp]:
  "pp_last x = pp_first y \<Longrightarrow> pp_last (pp_fusion x y) = pp_last y"
  by (induct x) simp_all

lemma pp_fusion_assoc [simp]:
  "\<lbrakk> pp_last x = pp_first y; pp_last y = pp_first z \<rbrakk> \<Longrightarrow> pp_fusion x (pp_fusion y z) = pp_fusion (pp_fusion x y) z"
  by (induct x) simp_all

text \<open>We now lift the path fusion product to a complex product on
sets of paths. This operation is total.\<close>

definition pp_prod :: "'a ppath set \<Rightarrow> 'a ppath set \<Rightarrow> 'a ppath set" (infixl "\<cdot>" 70)
  where "X\<cdot>Y = {pp_fusion u v| u v. u \<in> X \<and> v \<in> Y \<and> pp_last u = pp_first v}"

text \<open>Next we define the set of paths of length one as the
multiplicative unit of the path dioid.\<close>

definition pp_one :: "'a ppath set" where
  "pp_one \<equiv> range Node"

text \<open>We again provide an
elimination rule.\<close>

lemma pp_prod_iff:
  "w \<in> X\<cdot>Y \<longleftrightarrow> (\<exists>u v. w = pp_fusion u v \<and> u \<in> X \<and> v \<in> Y \<and> pp_last u = pp_first v)"
  by (unfold pp_prod_def) auto

interpretation ppath_dioid: dioid_one_zero "(\<union>)" "(\<cdot>)" pp_one "{}" "(\<subseteq>)" "(\<subset>)"
proof
  fix x y z :: "'a ppath set"
  show "x \<union> y \<union> z = x \<union> (y \<union> z)"
    by auto
  show "x \<union> y = y \<union> x"
    by auto
  show "x \<cdot> y \<cdot> z = x \<cdot> (y \<cdot> z)"
    by (auto simp add: pp_prod_def, metis pp_first_pp_fusion pp_fusion_assoc, metis pp_last_pp_fusion)
  show "(x \<union> y) \<cdot> z = x \<cdot> z \<union> y \<cdot> z"
    by (auto simp add: pp_prod_def)
  show "pp_one \<cdot> x = x"
    by (auto simp add: pp_one_def pp_prod_def, metis pp_fusion.simps(1) pp_last.simps(1) rangeI)
  show "x \<cdot> pp_one = x"
    by (auto simp add: pp_one_def pp_prod_def, metis pp_first.simps(1) pp_fusion_rightneutral rangeI)
  show "{} \<union> x = x"
    by auto
  show "{} \<cdot> x = {}"
    by (simp add: pp_prod_def)
  show "x \<cdot> {} = {}"
    by (simp add: pp_prod_def)
  show "x \<subseteq> y \<longleftrightarrow> x \<union> y = y"
    by auto
   show "x \<subset> y \<longleftrightarrow> x \<subseteq> y \<and> x \<noteq> y"
     by auto
  show "x \<union> x = x"
    by auto
  show "x \<cdot> (y \<union> z) = x \<cdot> y \<union> x \<cdot> z"
    by (auto simp add: pp_prod_def)
qed

no_notation
  pp_prod (infixl "\<cdot>" 70)

subsection \<open>The Distributive Lattice Dioid\<close>

text \<open>A bounded distributive lattice is a distributive lattice with
a least and a greatest element. Using Isabelle's lattice theory file
we define a bounded distributive lattice as an axiomatic type class
and show, using a sublocale statement, that every bounded distributive
lattice is a dioid with one and zero.\<close>

class bounded_distributive_lattice = bounded_lattice + distrib_lattice

sublocale bounded_distributive_lattice \<subseteq> dioid_one_zero sup inf top bot less_eq
proof
  fix x y z
  show "sup (sup x y) z = sup x (sup y z)"
    by (fact sup_assoc)
  show "sup x y = sup y x"
    by (fact sup.commute)
  show "inf (inf x y) z = inf x (inf y z)"
    by (metis inf.commute inf.left_commute)
  show "inf (sup x y) z = sup (inf x z) (inf y z)"
    by (fact inf_sup_distrib2)
  show "inf top x = x"
    by simp
  show "inf x top = x"
    by simp
  show "sup bot x = x"
    by simp
  show "inf bot x = bot"
    by simp
  show "inf x bot = bot"
    by simp
  show "(x \<le> y) = (sup x y = y)"
    by (fact le_iff_sup)
  show "(x < y) = (x \<le> y \<and> x \<noteq> y)"
    by auto
  show "sup x x = x"
    by simp
  show "inf x (sup y z) = sup (inf x y) (inf x z)"
    by (fact inf_sup_distrib1)
qed

subsection \<open>The Boolean Dioid\<close>

text \<open>In this section we show that the booleans form a dioid,
because the booleans form a bounded distributive lattice.\<close>

instantiation bool :: bounded_distributive_lattice
begin

  instance ..

end (* instantiation *)

interpretation boolean_dioid: dioid_one_zero sup inf True False less_eq less
  by (unfold_locales, simp_all add: inf_bool_def sup_bool_def)

subsection \<open>The Max-Plus Dioid\<close>

text \<open>The following dioids have important applications in
combinatorial optimisations, control theory, algorithm design and
computer networks.\<close>

text \<open>A definition of reals extended with~\<open>+\<infinity>\<close> {\em
and}~\<open>-\<infinity>\<close> may be found in {\em
HOL/Library/Extended\_Real.thy}. Alas, we require separate extensions
with either~\<open>+\<infinity>\<close> or~\<open>-\<infinity>\<close>.\<close>

text \<open>The carrier set of the max-plus semiring is the set of real
numbers extended by minus infinity. The operation of addition is
maximum, the operation of multiplication is addition, the additive
unit is minus infinity and the multiplicative unit is zero.\<close>

datatype mreal = mreal real | MInfty  \<comment> \<open>minus infinity\<close>

fun mreal_max where
  "mreal_max (mreal x) (mreal y) = mreal (max x y)"
| "mreal_max x MInfty = x"
| "mreal_max MInfty y = y"

lemma mreal_max_simp_3 [simp]: "mreal_max MInfty y = y"
  by (cases y, simp_all)

fun mreal_plus where
  "mreal_plus (mreal x) (mreal y) = mreal (x + y)"
| "mreal_plus _ _ = MInfty"

text \<open>We now show that the max plus-semiring satisfies the axioms of
selective semirings, from which it follows that it satisfies the dioid
axioms.\<close>

instantiation mreal :: selective_semiring
begin

  definition zero_mreal_def:
    "0 \<equiv> MInfty"

  definition one_mreal_def:
    "1 \<equiv> mreal 0"

  definition plus_mreal_def:
    "x + y \<equiv> mreal_max x y"

  definition times_mreal_def:
    "x * y \<equiv> mreal_plus x y"

  definition less_eq_mreal_def:
    "(x::mreal) \<le> y \<equiv> x + y = y"

  definition less_mreal_def:
    "(x::mreal) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: mreal
    show "x + y + z = x + (y + z)"
      by (cases x, cases y, cases z, simp_all add: plus_mreal_def)
    show "x + y = y + x"
      by (cases x, cases y, simp_all add: plus_mreal_def)
    show "x * y * z = x * (y * z)"
      by (cases x, cases y, cases z, simp_all add: times_mreal_def)
    show "(x + y) * z = x * z + y * z"
      by (cases x, cases y, cases z, simp_all add: plus_mreal_def times_mreal_def)
    show "1 * x = x"
      by (cases x, simp_all add: one_mreal_def times_mreal_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_mreal_def times_mreal_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_mreal_def zero_mreal_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_mreal_def zero_mreal_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_mreal_def zero_mreal_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_mreal_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_mreal_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, cases y, simp_all add: plus_mreal_def, metis linorder_le_cases max.absorb_iff2 max.absorb1)
    show "x * (y + z) = x * y + x * z"
      by (cases x, cases y, cases z, simp_all add: plus_mreal_def times_mreal_def)     qed

end (* instantiation *)

subsection \<open>The Min-Plus Dioid\<close>

text \<open>The min-plus dioid is also known as {\em tropical
semiring}. Here we need to add a positive infinity to the real
numbers. The procedere follows that of max-plus semirings.\<close>

datatype preal = preal real | PInfty  \<comment> \<open>plus infinity\<close>

fun preal_min where
  "preal_min (preal x) (preal y) = preal (min x y)"
| "preal_min x PInfty = x"
| "preal_min PInfty y = y"

lemma preal_min_simp_3 [simp]: "preal_min PInfty y = y"
  by (cases y, simp_all)

fun preal_plus where
  "preal_plus (preal x) (preal y) = preal (x + y)"
| "preal_plus _ _ = PInfty"

instantiation preal :: selective_semiring
begin

  definition zero_preal_def:
    "0 \<equiv> PInfty"

  definition one_preal_def:
    "1 \<equiv> preal 0"

  definition plus_preal_def:
    "x + y \<equiv> preal_min x y"

  definition times_preal_def:
    "x * y \<equiv> preal_plus x y"

  definition less_eq_preal_def:
    "(x::preal) \<le> y \<equiv> x + y = y"

  definition less_preal_def:
    "(x::preal) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: preal
    show "x + y + z = x + (y + z)"
      by (cases x, cases y, cases z, simp_all add: plus_preal_def)
    show "x + y = y + x"
      by (cases x, cases y, simp_all add: plus_preal_def)
    show "x * y * z = x * (y * z)"
      by (cases x, cases y, cases z, simp_all add: times_preal_def)
    show "(x + y) * z = x * z + y * z"
      by (cases x, cases y, cases z, simp_all add: plus_preal_def times_preal_def)
    show "1 * x = x"
      by (cases x, simp_all add: one_preal_def times_preal_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_preal_def times_preal_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_preal_def zero_preal_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_preal_def zero_preal_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_preal_def zero_preal_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_preal_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_preal_def)
    show "x + y = x \<or> x + y = y"
     by (cases x, cases y, simp_all add: plus_preal_def, metis linorder_le_cases min.absorb2 min.absorb_iff1)
    show "x * (y + z) = x * y + x * z"
      by (cases x, cases y, cases z, simp_all add: plus_preal_def times_preal_def)   qed

end (* instantiation *)

text \<open>Variants of min-plus and max-plus semirings can easily be
obtained. Here we formalise the min-plus semiring over the natural
numbers as an example.\<close>

datatype pnat = pnat nat | PInfty  \<comment> \<open>plus infinity\<close>

fun pnat_min where
  "pnat_min (pnat x) (pnat y) = pnat (min x y)"
| "pnat_min x PInfty = x"
| "pnat_min PInfty x = x"

lemma pnat_min_simp_3 [simp]: "pnat_min PInfty y = y"
  by (cases y, simp_all)

fun pnat_plus where
  "pnat_plus (pnat x) (pnat y) = pnat (x + y)"
| "pnat_plus _ _ = PInfty"

instantiation pnat :: selective_semiring
begin

  definition zero_pnat_def:
    "0 \<equiv> PInfty"

  definition one_pnat_def:
    "1 \<equiv> pnat 0"

  definition plus_pnat_def:
    "x + y \<equiv> pnat_min x y"

  definition times_pnat_def:
    "x * y \<equiv> pnat_plus x y"

  definition less_eq_pnat_def:
    "(x::pnat) \<le> y \<equiv> x + y = y"

  definition less_pnat_def:
    "(x::pnat) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  lemma zero_pnat_top: "(x::pnat) \<le> 1"
  by (cases x, simp_all add: less_eq_pnat_def plus_pnat_def one_pnat_def)

  instance
  proof
    fix x y z :: pnat
    show "x + y + z = x + (y + z)"
      by (cases x, cases y, cases z, simp_all add: plus_pnat_def)
    show "x + y = y + x"
      by (cases x, cases y, simp_all add: plus_pnat_def)
    show "x * y * z = x * (y * z)"
      by (cases x, cases y, cases z, simp_all add: times_pnat_def)
    show "(x + y) * z = x * z + y * z"
      by (cases x, cases y, cases z, simp_all add: plus_pnat_def times_pnat_def)
    show "1 * x = x"
      by (cases x, simp_all add: one_pnat_def times_pnat_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_pnat_def times_pnat_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_pnat_def zero_pnat_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_pnat_def zero_pnat_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_pnat_def zero_pnat_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_pnat_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_pnat_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, cases y, simp_all add: plus_pnat_def, metis linorder_le_cases min.absorb2 min.absorb_iff1)
    show "x * (y + z) = x * y + x * z"
      by (cases x, cases y, cases z, simp_all add: plus_pnat_def times_pnat_def)
  qed

end (* instantiation *)

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Common discrete functions\<close>

theory Discrete
imports Complex_Main
begin

subsection \<open>Discrete logarithm\<close>

context
begin

qualified fun log :: "nat \<Rightarrow> nat"
  where [simp del]: "log n = (if n < 2 then 0 else Suc (log (n div 2)))"

lemma log_induct [consumes 1, case_names one double]:
  fixes n :: nat
  assumes "n > 0"
  assumes one: "P 1"
  assumes double: "\<And>n. n \<ge> 2 \<Longrightarrow> P (n div 2) \<Longrightarrow> P n"
  shows "P n"
using \<open>n > 0\<close> proof (induct n rule: log.induct)
  fix n
  assume "\<not> n < 2 \<Longrightarrow>
          0 < n div 2 \<Longrightarrow> P (n div 2)"
  then have *: "n \<ge> 2 \<Longrightarrow> P (n div 2)" by simp
  assume "n > 0"
  show "P n"
  proof (cases "n = 1")
    case True
    with one show ?thesis by simp
  next
    case False
    with \<open>n > 0\<close> have "n \<ge> 2" by auto
    with * have "P (n div 2)" .
    with \<open>n \<ge> 2\<close> show ?thesis by (rule double)
  qed
qed

lemma log_zero [simp]: "log 0 = 0"
  by (simp add: log.simps)

lemma log_one [simp]: "log 1 = 0"
  by (simp add: log.simps)

lemma log_Suc_zero [simp]: "log (Suc 0) = 0"
  using log_one by simp

lemma log_rec: "n \<ge> 2 \<Longrightarrow> log n = Suc (log (n div 2))"
  by (simp add: log.simps)

lemma log_twice [simp]: "n \<noteq> 0 \<Longrightarrow> log (2 * n) = Suc (log n)"
  by (simp add: log_rec)

lemma log_half [simp]: "log (n div 2) = log n - 1"
proof (cases "n < 2")
  case True
  then have "n = 0 \<or> n = 1" by arith
  then show ?thesis by (auto simp del: One_nat_def)
next
  case False
  then show ?thesis by (simp add: log_rec)
qed

lemma log_exp [simp]: "log (2 ^ n) = n"
  by (induct n) simp_all

lemma log_mono: "mono log"
proof
  fix m n :: nat
  assume "m \<le> n"
  then show "log m \<le> log n"
  proof (induct m arbitrary: n rule: log.induct)
    case (1 m)
    then have mn2: "m div 2 \<le> n div 2" by arith
    show "log m \<le> log n"
    proof (cases "m \<ge> 2")
      case False
      then have "m = 0 \<or> m = 1" by arith
      then show ?thesis by (auto simp del: One_nat_def)
    next
      case True then have "\<not> m < 2" by simp
      with mn2 have "n \<ge> 2" by arith
      from True have m2_0: "m div 2 \<noteq> 0" by arith
      with mn2 have n2_0: "n div 2 \<noteq> 0" by arith
      from \<open>\<not> m < 2\<close> "1.hyps" mn2 have "log (m div 2) \<le> log (n div 2)" by blast
      with m2_0 n2_0 have "log (2 * (m div 2)) \<le> log (2 * (n div 2))" by simp
      with m2_0 n2_0 \<open>m \<ge> 2\<close> \<open>n \<ge> 2\<close> show ?thesis by (simp only: log_rec [of m] log_rec [of n]) simp
    qed
  qed
qed

lemma log_exp2_le:
  assumes "n > 0"
  shows "2 ^ log n \<le> n"
  using assms
proof (induct n rule: log_induct)
  case one
  then show ?case by simp
next
  case (double n)
  with log_mono have "log n \<ge> Suc 0"
    by (simp add: log.simps)
  assume "2 ^ log (n div 2) \<le> n div 2"
  with \<open>n \<ge> 2\<close> have "2 ^ (log n - Suc 0) \<le> n div 2" by simp
  then have "2 ^ (log n - Suc 0) * 2 ^ 1 \<le> n div 2 * 2" by simp
  with \<open>log n \<ge> Suc 0\<close> have "2 ^ log n \<le> n div 2 * 2"
    unfolding power_add [symmetric] by simp
  also have "n div 2 * 2 \<le> n" by (cases "even n") simp_all
  finally show ?case .
qed

lemma log_exp2_gt: "2 * 2 ^ log n > n"
proof (cases "n > 0")
  case True
  thus ?thesis
  proof (induct n rule: log_induct)
    case (double n)
    thus ?case
      by (cases "even n") (auto elim!: evenE oddE simp: field_simps log.simps)
  qed simp_all
qed simp_all

lemma log_exp2_ge: "2 * 2 ^ log n \<ge> n"
  using log_exp2_gt[of n] by simp

lemma log_le_iff: "m \<le> n \<Longrightarrow> log m \<le> log n"
  by (rule monoD [OF log_mono])

lemma log_eqI:
  assumes "n > 0" "2^k \<le> n" "n < 2 * 2^k"
  shows   "log n = k"
proof (rule antisym)
  from \<open>n > 0\<close> have "2 ^ log n \<le> n" by (rule log_exp2_le)
  also have "\<dots> < 2 ^ Suc k" using assms by simp
  finally have "log n < Suc k" by (subst (asm) power_strict_increasing_iff) simp_all
  thus "log n \<le> k" by simp
next
  have "2^k \<le> n" by fact
  also have "\<dots> < 2^(Suc (log n))" by (simp add: log_exp2_gt)
  finally have "k < Suc (log n)" by (subst (asm) power_strict_increasing_iff) simp_all
  thus "k \<le> log n" by simp
qed

lemma log_altdef: "log n = (if n = 0 then 0 else nat \<lfloor>Transcendental.log 2 (real_of_nat n)\<rfloor>)"
proof (cases "n = 0")
  case False
  have "\<lfloor>Transcendental.log 2 (real_of_nat n)\<rfloor> = int (log n)"
  proof (rule floor_unique)
    from False have "2 powr (real (log n)) \<le> real n"
      by (simp add: powr_realpow log_exp2_le)
    hence "Transcendental.log 2 (2 powr (real (log n))) \<le> Transcendental.log 2 (real n)"
      using False by (subst Transcendental.log_le_cancel_iff) simp_all
    also have "Transcendental.log 2 (2 powr (real (log n))) = real (log n)" by simp
    finally show "real_of_int (int (log n)) \<le> Transcendental.log 2 (real n)" by simp
  next
    have "real n < real (2 * 2 ^ log n)"
      by (subst of_nat_less_iff) (rule log_exp2_gt)
    also have "\<dots> = 2 powr (real (log n) + 1)"
      by (simp add: powr_add powr_realpow)
    finally have "Transcendental.log 2 (real n) < Transcendental.log 2 \<dots>"
      using False by (subst Transcendental.log_less_cancel_iff) simp_all
    also have "\<dots> = real (log n) + 1" by simp
    finally show "Transcendental.log 2 (real n) < real_of_int (int (log n)) + 1" by simp
  qed
  thus ?thesis by simp
qed simp_all

subsection \<open>Discrete square root\<close>

qualified definition sqrt :: "nat \<Rightarrow> nat"
  where "sqrt n = Max {m. m\<^sup>2 \<le> n}"

lemma sqrt_aux:
  fixes n :: nat
  shows "finite {m. m\<^sup>2 \<le> n}" and "{m. m\<^sup>2 \<le> n} \<noteq> {}"
proof -
  { fix m
    assume "m\<^sup>2 \<le> n"
    then have "m \<le> n"
      by (cases m) (simp_all add: power2_eq_square)
  } note ** = this
  then have "{m. m\<^sup>2 \<le> n} \<subseteq> {m. m \<le> n}" by auto
  then show "finite {m. m\<^sup>2 \<le> n}" by (rule finite_subset) rule
  have "0\<^sup>2 \<le> n" by simp
  then show *: "{m. m\<^sup>2 \<le> n} \<noteq> {}" by blast
qed

lemma sqrt_unique:
  assumes "m^2 \<le> n" "n < (Suc m)^2"
  shows   "Discrete.sqrt n = m"
proof -
  have "m' \<le> m" if "m'^2 \<le> n" for m'
  proof -
    note that
    also note assms(2)
    finally have "m' < Suc m" by (rule power_less_imp_less_base) simp_all
    thus "m' \<le> m" by simp
  qed
  with \<open>m^2 \<le> n\<close> sqrt_aux[of n] show ?thesis unfolding Discrete.sqrt_def
    by (intro antisym Max.boundedI Max.coboundedI) simp_all
qed

lemma sqrt_code[code]: "sqrt n = Max (Set.filter (\<lambda>m. m\<^sup>2 \<le> n) {0..n})"
proof -
  from power2_nat_le_imp_le [of _ n] have "{m. m \<le> n \<and> m\<^sup>2 \<le> n} = {m. m\<^sup>2 \<le> n}" by auto
  then show ?thesis by (simp add: sqrt_def Set.filter_def)
qed

lemma sqrt_inverse_power2 [simp]: "sqrt (n\<^sup>2) = n"
proof -
  have "{m. m \<le> n} \<noteq> {}" by auto
  then have "Max {m. m \<le> n} \<le> n" by auto
  then show ?thesis
    by (auto simp add: sqrt_def power2_nat_le_eq_le intro: antisym)
qed

lemma sqrt_zero [simp]: "sqrt 0 = 0"
  using sqrt_inverse_power2 [of 0] by simp

lemma sqrt_one [simp]: "sqrt 1 = 1"
  using sqrt_inverse_power2 [of 1] by simp

lemma mono_sqrt: "mono sqrt"
proof
  fix m n :: nat
  have *: "0 * 0 \<le> m" by simp
  assume "m \<le> n"
  then show "sqrt m \<le> sqrt n"
    by (auto intro!: Max_mono \<open>0 * 0 \<le> m\<close> finite_less_ub simp add: power2_eq_square sqrt_def)
qed

lemma mono_sqrt': "m \<le> n \<Longrightarrow> Discrete.sqrt m \<le> Discrete.sqrt n"
  using mono_sqrt unfolding mono_def by auto

lemma sqrt_greater_zero_iff [simp]: "sqrt n > 0 \<longleftrightarrow> n > 0"
proof -
  have *: "0 < Max {m. m\<^sup>2 \<le> n} \<longleftrightarrow> (\<exists>a\<in>{m. m\<^sup>2 \<le> n}. 0 < a)"
    by (rule Max_gr_iff) (fact sqrt_aux)+
  show ?thesis
  proof
    assume "0 < sqrt n"
    then have "0 < Max {m. m\<^sup>2 \<le> n}" by (simp add: sqrt_def)
    with * show "0 < n" by (auto dest: power2_nat_le_imp_le)
  next
    assume "0 < n"
    then have "1\<^sup>2 \<le> n \<and> 0 < (1::nat)" by simp
    then have "\<exists>q. q\<^sup>2 \<le> n \<and> 0 < q" ..
    with * have "0 < Max {m. m\<^sup>2 \<le> n}" by blast
    then show "0 < sqrt n" by  (simp add: sqrt_def)
  qed
qed

lemma sqrt_power2_le [simp]: "(sqrt n)\<^sup>2 \<le> n" (* FIXME tune proof *)
proof (cases "n > 0")
  case False then show ?thesis by simp
next
  case True then have "sqrt n > 0" by simp
  then have "mono (times (Max {m. m\<^sup>2 \<le> n}))" by (auto intro: mono_times_nat simp add: sqrt_def)
  then have *: "Max {m. m\<^sup>2 \<le> n} * Max {m. m\<^sup>2 \<le> n} = Max (times (Max {m. m\<^sup>2 \<le> n}) ` {m. m\<^sup>2 \<le> n})"
    using sqrt_aux [of n] by (rule mono_Max_commute)
  have "\<And>a. a * a \<le> n \<Longrightarrow> Max {m. m * m \<le> n} * a \<le> n"
  proof -
    fix q
    assume "q * q \<le> n"
    show "Max {m. m * m \<le> n} * q \<le> n"
    proof (cases "q > 0")
      case False then show ?thesis by simp
    next
      case True then have "mono (times q)" by (rule mono_times_nat)
      then have "q * Max {m. m * m \<le> n} = Max (times q ` {m. m * m \<le> n})"
        using sqrt_aux [of n] by (auto simp add: power2_eq_square intro: mono_Max_commute)
      then have "Max {m. m * m \<le> n} * q = Max (times q ` {m. m * m \<le> n})" by (simp add: ac_simps)
      moreover have "finite ((*) q ` {m. m * m \<le> n})"
        by (metis (mono_tags) finite_imageI finite_less_ub le_square)
      moreover have "\<exists>x. x * x \<le> n"
        by (metis \<open>q * q \<le> n\<close>)
      ultimately show ?thesis
        by simp (metis \<open>q * q \<le> n\<close> le_cases mult_le_mono1 mult_le_mono2 order_trans)
    qed
  qed
  then have "Max ((*) (Max {m. m * m \<le> n}) ` {m. m * m \<le> n}) \<le> n"
    apply (subst Max_le_iff)
      apply (metis (mono_tags) finite_imageI finite_less_ub le_square)
     apply auto
    apply (metis le0 mult_0_right)
    done
  with * show ?thesis by (simp add: sqrt_def power2_eq_square)
qed

lemma sqrt_le: "sqrt n \<le> n"
  using sqrt_aux [of n] by (auto simp add: sqrt_def intro: power2_nat_le_imp_le)

text \<open>Additional facts about the discrete square root, thanks to Julian Biendarra, Manuel Eberl\<close>

lemma Suc_sqrt_power2_gt: "n < (Suc (Discrete.sqrt n))^2"
  using Max_ge[OF Discrete.sqrt_aux(1), of "Discrete.sqrt n + 1" n]
  by (cases "n < (Suc (Discrete.sqrt n))^2") (simp_all add: Discrete.sqrt_def)

lemma le_sqrt_iff: "x \<le> Discrete.sqrt y \<longleftrightarrow> x^2 \<le> y"
proof -
  have "x \<le> Discrete.sqrt y \<longleftrightarrow> (\<exists>z. z\<^sup>2 \<le> y \<and> x \<le> z)"
    using Max_ge_iff[OF Discrete.sqrt_aux, of x y] by (simp add: Discrete.sqrt_def)
  also have "\<dots> \<longleftrightarrow> x^2 \<le> y"
  proof safe
    fix z assume "x \<le> z" "z ^ 2 \<le> y"
    thus "x^2 \<le> y" by (intro le_trans[of "x^2" "z^2" y]) (simp_all add: power2_nat_le_eq_le)
  qed auto
  finally show ?thesis .
qed

lemma le_sqrtI: "x^2 \<le> y \<Longrightarrow> x \<le> Discrete.sqrt y"
  by (simp add: le_sqrt_iff)

lemma sqrt_le_iff: "Discrete.sqrt y \<le> x \<longleftrightarrow> (\<forall>z. z^2 \<le> y \<longrightarrow> z \<le> x)"
  using Max.bounded_iff[OF Discrete.sqrt_aux] by (simp add: Discrete.sqrt_def)

lemma sqrt_leI:
  "(\<And>z. z^2 \<le> y \<Longrightarrow> z \<le> x) \<Longrightarrow> Discrete.sqrt y \<le> x"
  by (simp add: sqrt_le_iff)

lemma sqrt_Suc:
  "Discrete.sqrt (Suc n) = (if \<exists>m. Suc n = m^2 then Suc (Discrete.sqrt n) else Discrete.sqrt n)"
proof cases
  assume "\<exists> m. Suc n = m^2"
  then obtain m where m_def: "Suc n = m^2" by blast
  then have lhs: "Discrete.sqrt (Suc n) = m" by simp
  from m_def sqrt_power2_le[of n]
    have "(Discrete.sqrt n)^2 < m^2" by linarith
  with power2_less_imp_less have lt_m: "Discrete.sqrt n < m" by blast
  from m_def Suc_sqrt_power2_gt[of "n"]
    have "m^2 \<le> (Suc(Discrete.sqrt n))^2"
      by linarith
  with power2_nat_le_eq_le have "m \<le> Suc (Discrete.sqrt n)" by blast
  with lt_m have "m = Suc (Discrete.sqrt n)" by simp
  with lhs m_def show ?thesis by fastforce
next
  assume asm: "\<not> (\<exists> m. Suc n = m^2)"
  hence "Suc n \<noteq> (Discrete.sqrt (Suc n))^2" by simp
  with sqrt_power2_le[of "Suc n"]
    have "Discrete.sqrt (Suc n) \<le> Discrete.sqrt n" by (intro le_sqrtI) linarith
  moreover have "Discrete.sqrt (Suc n) \<ge> Discrete.sqrt n"
    by (intro monoD[OF mono_sqrt]) simp_all
  ultimately show ?thesis using asm by simp
qed

end

end


subsection \<open>Exponentiation is a Diophantine Relation\<close>

theory Exponential_Relation
  imports Alpha_Sequence "Exponentiation"
begin

(* Exponentiation is diophantine *)
definition exp_equations :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "exp_equations p q r b m = (b = Exp_Matrices.\<alpha> (q + 4) (r + 1) + q * q + 2 \<and>
                              m + q^2 + 1 = b * q \<and>
                              p < m \<and>
                              (p + b * Exp_Matrices.\<alpha> b r) mod m = (q * Exp_Matrices.\<alpha> b r +
                                                                   Exp_Matrices.\<alpha> b (r + 1)) mod m)"

lemma exp_repr:
  fixes p q r :: nat
  shows "p = q^r \<longleftrightarrow> ((q = 0 \<and> r = 0 \<and> p = 1) \<or>
                          (q = 0 \<and> 0 < r \<and> p = 0) \<or>
                          (q > 0 \<and> (\<exists>b m :: nat. exp_equations p q r b m)))"  (is "?P \<longleftrightarrow> ?Q")
proof
  assume P: ?P
    (* 3 disjunction elims applied to assumption; makes cases 1 and 2 trivial *)
    consider (c1)"q = 0 \<and> r = 0 \<and> p = 1" | (c2) "q = 0 \<and> 0 < r \<and> p = 0" | (c3) "q > 0 \<and>
          (\<exists>b m. b = Exp_Matrices.\<alpha> (q + 4) (r + 1) + q * q + 2 \<and> m = b * q - q * q - 1 \<and>
          p < m \<and> p mod m = (q * Exp_Matrices.\<alpha> b r - (b * Exp_Matrices.\<alpha> b r -
            Exp_Matrices.\<alpha> b (r + 1))) mod m)" using exp_alpha[of p q r] P by auto
    then show ?Q using P
    proof cases
      case c1
      then show ?thesis by auto
    next
      case c2
      then show ?thesis by auto
    next
      case c3
      obtain b m where
        b_def: "b = Exp_Matrices.\<alpha> (q + 4) (r + 1) + q * q + 2" and
        "m = b * q - q * q - 1" and
        "p < m" and
        "int (p mod m) = (int q * Exp_Matrices.\<alpha> b r - (int b * Exp_Matrices.\<alpha> b r -
        Exp_Matrices.\<alpha> b (r + 1))) mod int m"
        using exp_alpha[of p q r] c3 by blast
      then have "exp_equations p q r b m" unfolding exp_equations_def
        apply(intro conjI, auto simp add: power2_eq_square) using mod_add_right_eq by smt
      then show ?thesis using c3 by blast
    qed
next
  assume ?Q
  then show ?P
  proof (elim disjE)
    (* eliminate disjs, first two trivial cases by auto *)
    show "q = 0 \<and> r = 0 \<and> p = 1 \<Longrightarrow> p = q ^ r" by auto
    show "q = 0 \<and> 0 < r \<and> p = 0 \<Longrightarrow> p = q ^ r" by auto
    (* third, non-trivial case *)
    assume prems: "0 < q \<and> (\<exists>b m. exp_equations p q r b m)"
    obtain b m where cond: "exp_equations p q r b m" using prems by auto
    (* show that the four relevant conditions in exp_alpha hold; first three are easy *)
    hence "int b = Exp_Matrices.\<alpha> (q + 4) (r + 1) + int (q * q) + 2 \<and>
                                        m = b * q - q * q - 1 \<and> p < m"
      unfolding exp_equations_def power2_eq_square by auto
    (* the last one requires some extra care; but it's mainly mod_diff_cong *)
    moreover have "int (p mod m) = (int q * Exp_Matrices.\<alpha> b r -
                               (int b * Exp_Matrices.\<alpha> b r - Exp_Matrices.\<alpha> b (r + 1))) mod int m"
      using cond unfolding exp_equations_def
      using mod_diff_cong[of "(p + b * Exp_Matrices.\<alpha> b r)" m "(q * Exp_Matrices.\<alpha> b r +
        Exp_Matrices.\<alpha> b (r + 1))" "b * Exp_Matrices.\<alpha> b r" "b * Exp_Matrices.\<alpha> b r"]
      unfolding diff_diff_eq2 by auto
    ultimately show "p = q ^ r" using prems exp_alpha by auto
  qed
qed

definition exp ("[_ = _ ^ _]" 1000)
  where "[Q = R ^ S] \<equiv> (TERNARY (\<lambda>a b c. a = b ^ c) Q R S)"

lemma exp_dioph[dioph]:
  fixes P Q R :: polynomial
  defines "D \<equiv> [P = Q ^ R]"
  shows "is_dioph_rel D"
proof -
  define P' Q' R' where pushed_def:
    "P' \<equiv> (push_param P 5)" "Q' \<equiv> (push_param Q 5)" "R' \<equiv> (push_param R 5)"
  define b m a0 a1 a2 where params_def: "b = Param 0" "m = Param 1" "a0 = Param 2"
    "a1 = Param 3" "a2 = Param 4"

  define S1 where "S1 \<equiv> [0=] Q [\<and>] [0=] R [\<and>] P [=] \<^bold>1 [\<or>]
                         [0=] Q [\<and>] (Const 0) [<] R [\<and>] [0=] P"
  define S2 where "S2 \<equiv> [a0 = \<alpha> (Q' [+] (Const 4)) (R' [+] \<^bold>1)]
                         [\<and>] b [=] (a0 [+] Q'[^2] [+] Const 2)"
  define S3 where "S3 \<equiv> (m [+] Q'[^2] [+] Const 1) [=] b [*] Q'
                         [\<and>] P' [<] m"
  define S4 where "S4 \<equiv> [a1 = \<alpha> b R']
                         [\<and>] [a2 = \<alpha> b (R' [+] \<^bold>1)]
                         [\<and>] MOD (P' [+] b [*] a1) m (Q' [*] a1 [+] a2)"

  note S_defs = S1_def S2_def S3_def S4_def

  define S where "S \<equiv> S1 [\<or>] (Q [>] Const 0) [\<and>] ([\<exists>5] S2 [\<and>] S3 [\<and>] S4)"

  have "is_dioph_rel S"
    unfolding S_def S_defs by (auto simp: dioph)

  moreover have "eval S a = eval D a" for a
  proof -
    define p q r where evaled_defs: "p = peval P a" "q = peval Q a" "r = peval R a"

    show ?thesis
    proof (rule)
      assume "eval S a"
      then show "eval D a"
        unfolding S_def S_defs defs apply (simp add: sq_p_eval)
        unfolding D_def exp_def defs apply simp_all
        unfolding pushed_def params_def apply (auto simp add: push_push[where ?n = 5] push_list_eval)
        unfolding exp_repr exp_equations_def apply simp
        subgoal for ks
          apply (rule exI[of _ "ks!0"], auto)
          subgoal by (simp add: power2_eq_square)
          subgoal apply (rule exI[of _ "ks!1"], auto)
            by (smt int_ops(7) mult_Suc of_nat_Suc of_nat_add power2_eq_square zmod_int)
          done
        done
    next
      assume "eval D a"
      then obtain b_val m_val where cond: "(q = 0 \<and> r = 0 \<and> p = 1) \<or>
                                           (q = 0 \<and> 0 < r \<and> p = 0) \<or>
                                           (q > 0 \<and> exp_equations p q r b_val m_val)"
        unfolding D_def exp_def exp_repr evaled_defs ternary_eval by auto

      moreover define a0_val a1_val a2_val where
        "a0_val \<equiv> nat (Exp_Matrices.\<alpha> (q + 4) (r + 1))"
        "a1_val \<equiv> nat (Exp_Matrices.\<alpha> b_val r)"
        "a2_val \<equiv> nat (Exp_Matrices.\<alpha> b_val (r + 1))"
      ultimately show "eval S a"
        unfolding S_def S_defs defs evaled_defs apply (simp add: sq_p_eval)
        apply (elim disjE)
        subgoal unfolding defs by simp
        subgoal unfolding defs by simp
        subgoal apply(elim conjE) apply(intro disjI2, intro conjI)
          subgoal by simp
          subgoal premises prems
          proof-
            have bg3: "3 < b_val"
            proof-
              have "b_val = Exp_Matrices.\<alpha> (q + 4) (r + 1) + int q * int q + 2"
                using cond prems(4) evaled_defs(2) unfolding exp_equations_def by linarith
              moreover have "int q * int q > 0" using evaled_defs(2) prems by simp
              moreover have "Exp_Matrices.\<alpha> (q + 4) (r + 1) > 0"
                using Exp_Matrices.alpha_superlinear[of "q+4" "r+1"] by linarith
              ultimately show ?thesis by linarith
            qed
            show ?thesis apply (rule exI[of _ "[b_val, m_val, a0_val, a1_val, a2_val]"], intro conjI)
              using prems
              unfolding exp_equations_def pushed_def params_def
              using push_list_def push_push bg3 Exp_Matrices.alpha_nonnegative apply simp_all
              subgoal using push_list_def by (smt Exp_Matrices.alpha_strictly_increasing int_nat_eq
                    nat_int numeral_Bit0 numeral_One of_nat_1 of_nat_add of_nat_power plus_1_eq_Suc
                     power2_eq_square)
              subgoal using push_list_def apply auto by (smt One_nat_def Suc_1 Suc_less_eq
                      int_nat_eq less_Suc_eq nat_int numeral_3_eq_3 of_nat_add of_nat_mult zmod_int)
            done
          qed
        done
      done
    qed
  qed

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare exp_def[defs]

end