theory Normalized_Fraction
imports
  Main
  "~~/src/HOL/Number_Theory/Euclidean_Algorithm"
  "~~/src/HOL/Library/Fraction_Field"
begin

lemma dvd_neg_div': "y dvd (x :: 'a :: idom_divide) \<Longrightarrow> -x div y = - (x div y)"
apply (case_tac "y = 0") apply simp
apply (auto simp add: dvd_def)
apply (subgoal_tac "-(y * k) = y * - k")
apply (simp only:)
apply (erule nonzero_mult_div_cancel_left)
apply simp
done

(* TODO Move *)
lemma (in semiring_gcd) coprime_mul_eq': "coprime (a * b) d \<longleftrightarrow> coprime a d \<and> coprime b d"
  using coprime_mul_eq[of d a b] by (simp add: gcd.commute)

lemma dvd_div_eq_0_iff:
  assumes "b dvd (a :: 'a :: semidom_divide)"
  shows   "a div b = 0 \<longleftrightarrow> a = 0"
  using assms by (elim dvdE, cases "b = 0") simp_all

lemma dvd_div_eq_0_iff':
  assumes "b dvd (a :: 'a :: semiring_div)"
  shows   "a div b = 0 \<longleftrightarrow> a = 0"
  using assms by (elim dvdE, cases "b = 0") simp_all

lemma unit_div_eq_0_iff:
  assumes "is_unit (b :: 'a :: {algebraic_semidom,semidom_divide})"
  shows   "a div b = 0 \<longleftrightarrow> a = 0"
  by (rule dvd_div_eq_0_iff) (insert assms, auto)

lemma unit_div_eq_0_iff':
  assumes "is_unit (b :: 'a :: semiring_div)"
  shows   "a div b = 0 \<longleftrightarrow> a = 0"
  by (rule dvd_div_eq_0_iff) (insert assms, auto)

lemma dvd_div_eq_cancel:
  "a div c = b div c \<Longrightarrow> (c :: 'a :: semiring_div) dvd a \<Longrightarrow> c dvd b \<Longrightarrow> a = b"
  by (elim dvdE, cases "c = 0") simp_all

lemma dvd_div_eq_iff:
  "(c :: 'a :: semiring_div) dvd a \<Longrightarrow> c dvd b \<Longrightarrow> a div c = b div c \<longleftrightarrow> a = b"
  by (elim dvdE, cases "c = 0") simp_all

lemma normalize_imp_eq:
  "normalize a = normalize b \<Longrightarrow> unit_factor a = unit_factor b \<Longrightarrow> a = b"
  by (cases "a = 0 \<or> b = 0")
     (auto simp add: div_unit_factor [symmetric] unit_div_cancel simp del: div_unit_factor)

lemma coprime_crossproduct':
  fixes a b c d :: "'a :: semiring_gcd"
  assumes nz: "b \<noteq> 0"
  assumes unit_factors: "unit_factor b = unit_factor d"
  assumes coprime: "coprime a b" "coprime c d"
  shows "a * d = b * c \<longleftrightarrow> a = c \<and> b = d"
proof safe
  assume eq: "a * d = b * c"
  hence "normalize a * normalize d = normalize c * normalize b"
    by (simp only: normalize_mult [symmetric] mult_ac)
  with coprime have "normalize b = normalize d"
    by (subst (asm) coprime_crossproduct) simp_all
  from this and unit_factors show "b = d" by (rule normalize_imp_eq)
  from eq have "a * d = c * d" by (simp only: \<open>b = d\<close> mult_ac)
  with nz \<open>b = d\<close> show "a = c" by simp
qed (simp_all add: mult_ac)

lemma div_mult_unit2: "is_unit c \<Longrightarrow> b dvd a \<Longrightarrow> a div (b * c) = a div b div c"
  by (subst dvd_div_mult2_eq) (simp_all add: mult_unit_dvd_iff)
(* END TODO *)

definition quot_to_fract :: "'a :: {idom} \<times> 'a \<Rightarrow> 'a fract" where
  "quot_to_fract = (\<lambda>(a,b). Fraction_Field.Fract a b)"

definition normalize_quot :: "'a :: {ring_gcd,idom_divide} \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  "normalize_quot =
     (\<lambda>(a,b). if b = 0 then (0,1) else let d = gcd a b * unit_factor b in (a div d, b div d))"

definition normalized_fracts :: "('a :: {ring_gcd,idom_divide} \<times> 'a) set" where
  "normalized_fracts = {(a,b). coprime a b \<and> unit_factor b = 1}"

lemma not_normalized_fracts_0_denom [simp]: "(a, 0) \<notin> normalized_fracts"
  by (auto simp: normalized_fracts_def)

lemma unit_factor_snd_normalize_quot [simp]:
  "unit_factor (snd (normalize_quot x)) = 1"
  by (simp add: normalize_quot_def case_prod_unfold Let_def dvd_unit_factor_div
                mult_unit_dvd_iff unit_factor_mult unit_factor_gcd)

lemma snd_normalize_quot_nonzero [simp]: "snd (normalize_quot x) \<noteq> 0"
  using unit_factor_snd_normalize_quot[of x]
  by (auto simp del: unit_factor_snd_normalize_quot)

lemma normalize_quot_aux:
  fixes a b
  assumes "b \<noteq> 0"
  defines "d \<equiv> gcd a b * unit_factor b"
  shows   "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
          "d dvd a" "d dvd b" "d \<noteq> 0"
proof -
  from assms show "d dvd a" "d dvd b"
    by (simp_all add: d_def mult_unit_dvd_iff)
  thus "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d" "d \<noteq> 0"
    by (auto simp: normalize_quot_def Let_def d_def \<open>b \<noteq> 0\<close>)
qed

lemma normalize_quotE:
  assumes "b \<noteq> 0"
  obtains d where "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
                  "d dvd a" "d dvd b" "d \<noteq> 0"
  using that[OF normalize_quot_aux[OF assms]] .

lemma normalize_quotE':
  assumes "snd x \<noteq> 0"
  obtains d where "fst x = fst (normalize_quot x) * d" "snd x = snd (normalize_quot x) * d"
                  "d dvd fst x" "d dvd snd x" "d \<noteq> 0"
proof -
  from normalize_quotE[OF assms, of "fst x"] guess d .
  from this show ?thesis unfolding prod.collapse by (intro that[of d])
qed

lemma coprime_normalize_quot:
  "coprime (fst (normalize_quot x)) (snd (normalize_quot x))"
  by (simp add: normalize_quot_def case_prod_unfold Let_def
        div_mult_unit2 gcd_div_unit1 gcd_div_unit2 div_gcd_coprime)

lemma normalize_quot_in_normalized_fracts [simp]: "normalize_quot x \<in> normalized_fracts"
  by (simp add: normalized_fracts_def coprime_normalize_quot case_prod_unfold)

lemma normalize_quot_eq_iff:
  assumes "b \<noteq> 0" "d \<noteq> 0"
  shows   "normalize_quot (a,b) = normalize_quot (c,d) \<longleftrightarrow> a * d = b * c"
proof -
  define x y where "x = normalize_quot (a,b)" and "y = normalize_quot (c,d)"
  from normalize_quotE[OF assms(1), of a] normalize_quotE[OF assms(2), of c]
    obtain d1 d2
      where "a = fst x * d1" "b = snd x * d1" "c = fst y * d2" "d = snd y * d2" "d1 \<noteq> 0" "d2 \<noteq> 0"
    unfolding x_def y_def by metis
  hence "a * d = b * c \<longleftrightarrow> fst x * snd y = snd x * fst y" by simp
  also have "\<dots> \<longleftrightarrow> fst x = fst y \<and> snd x = snd y"
    by (intro coprime_crossproduct') (simp_all add: x_def y_def coprime_normalize_quot)
  also have "\<dots> \<longleftrightarrow> x = y" using prod_eqI by blast
  finally show "x = y \<longleftrightarrow> a * d = b * c" ..
qed

lemma normalize_quot_eq_iff':
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot x = normalize_quot y \<longleftrightarrow> fst x * snd y = snd x * fst y"
  using assms by (cases x, cases y, hypsubst) (subst normalize_quot_eq_iff, simp_all)

lemma normalize_quot_id: "x \<in> normalized_fracts \<Longrightarrow> normalize_quot x = x"
  by (auto simp: normalized_fracts_def normalize_quot_def case_prod_unfold)

lemma normalize_quot_idem [simp]: "normalize_quot (normalize_quot x) = normalize_quot x"
  by (rule normalize_quot_id) simp_all

lemma fractrel_iff_normalize_quot_eq:
  "fractrel x y \<longleftrightarrow> normalize_quot x = normalize_quot y \<and> snd x \<noteq> 0 \<and> snd y \<noteq> 0"
  by (cases x, cases y) (auto simp: fractrel_def normalize_quot_eq_iff)

lemma fractrel_normalize_quot_left:
  assumes "snd x \<noteq> 0"
  shows   "fractrel (normalize_quot x) y \<longleftrightarrow> fractrel x y"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lemma fractrel_normalize_quot_right:
  assumes "snd x \<noteq> 0"
  shows   "fractrel y (normalize_quot x) \<longleftrightarrow> fractrel y x"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lift_definition quot_of_fract :: "'a :: {ring_gcd,idom_divide} fract \<Rightarrow> 'a \<times> 'a"
    is normalize_quot
  by (subst (asm) fractrel_iff_normalize_quot_eq) simp_all

lemma quot_to_fract_quot_of_fract [simp]: "quot_to_fract (quot_of_fract x) = x"
  unfolding quot_to_fract_def
proof transfer
  fix x :: "'a \<times> 'a" assume rel: "fractrel x x"
  define x' where "x' = normalize_quot x"
  obtain a b where [simp]: "x = (a, b)" by (cases x)
  from rel have "b \<noteq> 0" by simp
  from normalize_quotE[OF this, of a] guess d .
  hence "a = fst x' * d" "b = snd x' * d" "d \<noteq> 0" "snd x' \<noteq> 0" by (simp_all add: x'_def)
  thus "fractrel (case x' of (a, b) \<Rightarrow> if b = 0 then (0, 1) else (a, b)) x"
    by (auto simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract: "quot_of_fract (quot_to_fract x) = normalize_quot x"
proof (cases "snd x = 0")
  case True
  thus ?thesis unfolding quot_to_fract_def
    by transfer (simp add: case_prod_unfold normalize_quot_def)
next
  case False
  thus ?thesis unfolding quot_to_fract_def by transfer (simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract':
  "x \<in> normalized_fracts \<Longrightarrow> quot_of_fract (quot_to_fract x) = x"
  unfolding quot_to_fract_def by transfer (auto simp: normalize_quot_id)

lemma quot_of_fract_in_normalized_fracts [simp]: "quot_of_fract x \<in> normalized_fracts"
  by transfer simp

lemma normalize_quotI:
  assumes "a * d = b * c" "b \<noteq> 0" "(c, d) \<in> normalized_fracts"
  shows   "normalize_quot (a, b) = (c, d)"
proof -
  from assms have "normalize_quot (a, b) = normalize_quot (c, d)"
    by (subst normalize_quot_eq_iff) auto
  also have "\<dots> = (c, d)" by (intro normalize_quot_id) fact
  finally show ?thesis .
qed

lemma td_normalized_fract:
  "type_definition quot_of_fract quot_to_fract normalized_fracts"
  by standard (simp_all add: quot_of_fract_quot_to_fract')

lemma quot_of_fract_add_aux:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "(fst x * snd y + fst y * snd x) * (snd (normalize_quot x) * snd (normalize_quot y)) =
             snd x * snd y * (fst (normalize_quot x) * snd (normalize_quot y) +
             snd (normalize_quot x) * fst (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] guess d . note d = this
  from normalize_quotE'[OF assms(2)] guess e . note e = this
  show ?thesis by (simp_all add: d e algebra_simps)
qed

locale fract_as_normalized_quot
begin
setup_lifting td_normalized_fract
end

lemma quot_of_fract_add:
  "quot_of_fract (x + y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d + b * c, b * d))"
  by transfer (insert quot_of_fract_add_aux,
               simp_all add: Let_def case_prod_unfold normalize_quot_eq_iff)

lemma quot_of_fract_uminus:
  "quot_of_fract (-x) = (let (a,b) = quot_of_fract x in (-a, b))"
  by transfer (auto simp: case_prod_unfold Let_def normalize_quot_def dvd_neg_div' mult_unit_dvd_iff)

lemma quot_of_fract_diff:
  "quot_of_fract (x - y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d - b * c, b * d))" (is "_ = ?rhs")
proof -
  have "x - y = x + -y" by simp
  also have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_add quot_of_fract_uminus Let_def case_prod_unfold) simp_all
  finally show ?thesis .
qed

lemma normalize_quot_mult_coprime:
  assumes "coprime a b" "coprime c d" "unit_factor b = 1" "unit_factor d = 1"
  defines "e \<equiv> fst (normalize_quot (a, d))" and "f \<equiv> snd (normalize_quot (a, d))"
     and  "g \<equiv> fst (normalize_quot (c, b))" and "h \<equiv> snd (normalize_quot (c, b))"
  shows   "normalize_quot (a * c, b * d) = (e * g, f * h)"
proof (rule normalize_quotI)
  from assms have "b \<noteq> 0" "d \<noteq> 0" by auto
  from normalize_quotE[OF \<open>b \<noteq> 0\<close>, of c] guess k . note k = this [folded assms]
  from normalize_quotE[OF \<open>d \<noteq> 0\<close>, of a] guess l . note l = this [folded assms]
  from k l show "a * c * (f * h) = b * d * (e * g)" by (simp_all)
  from assms have [simp]: "unit_factor f = 1" "unit_factor h = 1"
    by simp_all
  from assms have "coprime e f" "coprime g h" by (simp_all add: coprime_normalize_quot)
  with k l assms(1,2) show "(e * g, f * h) \<in> normalized_fracts"
    by (simp add: normalized_fracts_def unit_factor_mult coprime_mul_eq coprime_mul_eq')
qed (insert assms(3,4), auto)

lemma normalize_quot_mult:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot (fst x * fst y, snd x * snd y) = normalize_quot
             (fst (normalize_quot x) * fst (normalize_quot y),
              snd (normalize_quot x) * snd (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] guess d . note d = this
  from normalize_quotE'[OF assms(2)] guess e . note e = this
  show ?thesis by (simp_all add: d e algebra_simps normalize_quot_eq_iff)
qed

lemma quot_of_fract_mult:
  "quot_of_fract (x * y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,d); (g,h) = normalize_quot (c,b)
      in  (e*g, f*h))"
  by transfer (simp_all add: Let_def case_prod_unfold normalize_quot_mult_coprime [symmetric]
                 coprime_normalize_quot normalize_quot_mult [symmetric])

lemma normalize_quot_0 [simp]:
    "normalize_quot (0, x) = (0, 1)" "normalize_quot (x, 0) = (0, 1)"
  by (simp_all add: normalize_quot_def)

lemma normalize_quot_eq_0_iff [simp]: "fst (normalize_quot x) = 0 \<longleftrightarrow> fst x = 0 \<or> snd x = 0"
  by (auto simp: normalize_quot_def case_prod_unfold Let_def div_mult_unit2 dvd_div_eq_0_iff)
  find_theorems "_ div _ = 0"

lemma fst_quot_of_fract_0_imp: "fst (quot_of_fract x) = 0 \<Longrightarrow> snd (quot_of_fract x) = 1"
  by transfer auto

lemma normalize_quot_swap:
  assumes "a \<noteq> 0" "b \<noteq> 0"
  defines "a' \<equiv> fst (normalize_quot (a, b))" and "b' \<equiv> snd (normalize_quot (a, b))"
  shows   "normalize_quot (b, a) = (b' div unit_factor a', a' div unit_factor a')"
proof (rule normalize_quotI)
  from normalize_quotE[OF assms(2), of a] guess d . note d = this [folded assms(3,4)]
  show "b * (a' div unit_factor a') = a * (b' div unit_factor a')"
    using assms(1,2) d
    by (simp add: div_unit_factor [symmetric] unit_div_mult_swap mult_ac del: div_unit_factor)
  have "coprime a' b'" by (simp add: a'_def b'_def coprime_normalize_quot)
  thus "(b' div unit_factor a', a' div unit_factor a') \<in> normalized_fracts"
    using assms(1,2) d by (auto simp: normalized_fracts_def gcd_div_unit1 gcd_div_unit2 gcd.commute)
qed fact+

lemma quot_of_fract_inverse:
  "quot_of_fract (inverse x) =
     (let (a,b) = quot_of_fract x; d = unit_factor a
      in  if d = 0 then (0, 1) else (b div d, a div d))"
proof (transfer, goal_cases)
  case (1 x)
  from normalize_quot_swap[of "fst x" "snd x"] show ?case
    by (auto simp: Let_def case_prod_unfold)
qed

lemma normalize_quot_div_unit_left:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x div u, y) = (x' div u, y')"
proof (cases "y = 0")
  case False
  from normalize_quotE[OF this, of x] guess d . note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1" by (simp_all add: coprime_normalize_quot)
  with False d \<open>is_unit u\<close> show ?thesis
    by (intro normalize_quotI)
       (auto simp: normalized_fracts_def unit_div_mult_swap unit_div_commute unit_div_cancel
          gcd_div_unit1)
qed (simp_all add: assms)

lemma normalize_quot_div_unit_right:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, y div u) = (x' * u, y')"
proof (cases "y = 0")
  case False
  from normalize_quotE[OF this, of x] guess d . note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1" by (simp_all add: coprime_normalize_quot)
  with False d \<open>is_unit u\<close> show ?thesis
    by (intro normalize_quotI)
       (auto simp: normalized_fracts_def unit_div_mult_swap unit_div_commute unit_div_cancel
          gcd_mult_unit1 unit_div_eq_0_iff mult.assoc [symmetric])
qed (simp_all add: assms)

lemma normalize_quot_normalize_left:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (normalize x, y) = (x' div unit_factor x, y')"
  using normalize_quot_div_unit_left[of "unit_factor x" x y]
  by (cases "x = 0") (simp_all add: assms)

lemma normalize_quot_normalize_right:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, normalize y) = (x' * unit_factor y, y')"
  using normalize_quot_div_unit_right[of "unit_factor y" x y]
  by (cases "y = 0") (simp_all add: assms)

lemma quot_of_fract_0 [simp]: "quot_of_fract 0 = (0, 1)"
  by transfer auto

lemma quot_of_fract_1 [simp]: "quot_of_fract 1 = (1, 1)"
  by transfer (rule normalize_quotI, simp_all add: normalized_fracts_def)

lemma quot_of_fract_divide:
  "quot_of_fract (x / y) = (if y = 0 then (0, 1) else
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,c); (g,h) = normalize_quot (d,b)
      in  (e * g, f * h)))" (is "_ = ?rhs")
proof (cases "y = 0")
  case False
  hence A: "fst (quot_of_fract y) \<noteq> 0" by transfer auto
  have "x / y = x * inverse y" by (simp add: divide_inverse)
  also from False A have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_mult quot_of_fract_inverse)
       (simp_all add: Let_def case_prod_unfold fst_quot_of_fract_0_imp
          normalize_quot_div_unit_left normalize_quot_div_unit_right
          normalize_quot_normalize_right normalize_quot_normalize_left)
  finally show ?thesis .
qed simp_all

end


theory BoundedQuants
  imports "../GST_Features"
begin

context GZF begin

lemmas Subset_def = spec[OF spec[OF Subset_ax]]
   and SetMem_def = spec[OF SetMem_ax]
   and ReplPred_def = spec[OF spec[OF ReplPred_ax]]
   and SetOf_def = spec[OF spec[OF SetOf_ax]]

subsection \<open>Soft typing rules\<close>

declare SetOf_def [typdef] SetMem_def [typdef]

lemma setof_set_subtyp : "SetOf \<alpha> << Set"
  unfolding SetOf_def by (rule subtypI, drule tyE, simp)

lemma setof_iff :
  "x : SetOf \<alpha> \<longleftrightarrow> x : Set \<and> (\<forall>b. b \<in> x \<longrightarrow> b : \<alpha>)"
  unfolding SetOf_def by (unfold_typs)

lemma setof_subtyp : "\<alpha> << \<beta> \<Longrightarrow> SetOf \<alpha> << SetOf \<beta>"
  unfolding subtyp_def setof_iff by auto

lemma setofI : "\<lbrakk> x : Set ; \<And>b. b \<in> x \<Longrightarrow> b : P \<rbrakk> \<Longrightarrow> x : SetOf P"
  unfolding SetOf_def by (unfold_typs, auto)

lemma setof_mem : "x : SetOf \<alpha> \<Longrightarrow> b \<in> x \<Longrightarrow> b : \<alpha>"
  unfolding SetOf_def has_ty_def by auto

lemma setmemI : "x : Set \<Longrightarrow> a \<in> x \<Longrightarrow> a : SetMem"
  unfolding SetMem_def by (unfold_typs, auto)

lemma setmem_iff :
 "b : SetMem \<longleftrightarrow> (\<exists>x : Set. b \<in> x)"
 by (unfold_typs)

lemma setof_set : "x : SetOf \<alpha> \<Longrightarrow> x : Set"
  by (rule subtypE[OF setof_set_subtyp])

lemma set_setof : "x : Set \<Longrightarrow> x : SetOf (SetMem)"
  by (rule setofI, use setmemI in auto)

definition MemOf :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "MemOf x b \<equiv> b \<in> x"

lemma memofI :
  assumes "b \<in> x"
  shows "b : MemOf x"
  using assms unfolding MemOf_def
  by (unfold_typs)

lemma memofD :
  assumes "b : MemOf x"
  shows "b \<in> x"
  using assms unfolding MemOf_def
  by (unfold_typs)

lemmas memof_setmem = setmemI[OF _ memofD]

lemma set_setof_memof :
  assumes x:"x : Set"
  shows "x : SetOf (MemOf x)"
  using setofI[OF x memofI] by auto

abbreviation not_mem :: "['a, 'a] \<Rightarrow> bool"  (infixl \<open>\<notin>\<close> 50)  \<comment> \<open>negated membership relation\<close>
  where "x \<notin> y \<equiv> \<not> (x \<in> y)"

section \<open>Bounding quantification over a set\<close>

definition ball :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  ball_def : "ball x P \<equiv> rall (\<lambda>a. a \<in> x) P"
definition bex :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  bex_def : "bex x P \<equiv> rex (\<lambda>a. a \<in> x) P"

end

(*Temporarily exiting GZF context to perform
  syntax declarations for \<in>-bounded quantification*)
syntax
  "_ball" :: "[pttrn, 'a, bool] \<Rightarrow> bool"  (\<open>(3\<forall>_\<in>_./ _)\<close> 10)
  "_bex"  :: "[pttrn, 'a, bool] \<Rightarrow> bool"   (\<open>(3\<exists>_\<in>_./ _)\<close> 10)
translations
  "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST ball A (\<lambda>x. P)"
  "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST bex A (\<lambda>x. P)"

syntax
  "_depfun_set" :: "[pttrn, 'a, bool] => bool" (\<open>(3\<Pi>_\<in>_./ _)\<close> 10)
translations
  "\<Pi> b\<in>x. B" \<rightleftharpoons> "CONST depfun_ty (CONST MemOf x) (\<lambda>b. B)"

context GZF begin

(*Lemmas taken from ZF/ZF_Base*)
lemma ballI [intro!]: "(\<And>x. x \<in> A \<Longrightarrow> P x) \<Longrightarrow> \<forall>x\<in>A. P x"
  by (simp add: ball_def)

lemma bspec [dest?]: "[| \<forall>x\<in>A. P x;  x\<in>A |] ==> P x"
  unfolding ball_def by auto

lemma rev_ballE [elim]:
    "[| \<forall>x\<in>A. P x;  x\<notin>A ==> Q;  P x ==> Q |] ==> Q"
  by (simp add: ball_def, blast)

lemma ballE: "[| \<forall>x\<in>A. P x;  P x ==> Q;  x\<notin>A \<Longrightarrow>  Q |] ==> Q"
  by auto

lemma ball_triv [simp]: "\<forall>x\<in>A. P \<longleftrightarrow> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
 by (simp add: ball_def)

lemma ball_cong [cong]:
 "[| A=A';  !!x. x\<in>A' ==> P x \<longleftrightarrow> P' x |] ==> ((\<forall>x\<in>A. P x) \<longleftrightarrow> (\<forall>x\<in>A'. P' x))"
  by (simp add: ball_def)

lemma bexI [intro]: "[| P x;  x \<in> A |] ==> \<exists>x\<in>A. P x"
  by (simp add: bex_def, blast)

lemma rev_bexI: "[| x\<in>A;  P x |] ==> \<exists>x\<in>A. P x" by blast

lemma bexCI: "[| ball A  (\<lambda>x. \<not> P x) \<Longrightarrow> P a;  a\<in> A |] ==> \<exists>x\<in>A. P x"
  by blast

lemma bexE [elim!]:
  "[|  \<exists>x\<in>A. P x ;  !!x. [| x\<in>A; P x |] ==> Q |] ==> Q"
by (simp add: bex_def, blast)

lemma bex_triv [simp]: "(\<exists>x\<in>A. P) \<longleftrightarrow> ((\<exists>x. x\<in>A) \<and> P)"
by (simp add: bex_def)

lemma bex_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P x \<longleftrightarrow> P'(x) |]
     ==> (\<exists>x\<in>A. P x) \<longleftrightarrow> (\<exists>x\<in>A'. P' x)"
  by (simp add: bex_def cong: conj_cong)

subsection \<open>Rules for the subset relation\<close>
(*Removed the need for x and y to be sets for x \<subseteq> y to be true.
  x \<subseteq> y now holds if \<forall>a. a \<in> x \<longrightarrow> a \<in> y.
  This change is in anticipation of having other objects that implement \<in>
  (e.g., groups G \<subseteq> H being equivalent to carrier G \<subseteq> carrier H) *)

lemma subset_iff :
  "x \<subseteq> y \<longleftrightarrow> (\<forall>a \<in> x. a \<in> y)"
  using Subset_def by auto

lemma subsetI [intro]:
  "(\<And>a. a \<in> x \<Longrightarrow> a \<in> y) \<Longrightarrow> x \<subseteq> y"
  using subset_iff by auto
(*WAS: by (simp add: subset_def) *)

lemma subsetD [elim]:
  "[| A \<subseteq> B;  c\<in>A |] ==> c\<in>B"
  using subset_iff by auto
(*WAS: apply (unfold subset_def)
       apply (erule bspec, assumption)
       done*)

lemma subsetCE [elim]:
  "[| A \<subseteq> B;  c\<notin>A ==> P;  c\<in>B ==> P |] ==> P"
  using subsetD by auto
(*WAS: by (simp add: subset_def, blast)*)

lemma rev_subsetD:
  "[| c\<in>A; A \<subseteq> B |] ==> c\<in>B"
   by blast

lemma contra_subsetD:
  "[| A \<subseteq> B; c \<notin> B |] ==> c \<notin> A"
   by blast

lemma rev_contra_subsetD:
  "[| c \<notin> B;  A \<subseteq> B |] ==> c \<notin> A"
  by blast

lemma subset_refl : "A \<subseteq> A"
  by blast

lemma subset_trans:
   "[| A \<subseteq> B;  B \<subseteq> C |] ==> A \<subseteq> C"
  using subset_iff by blast
(*WAS: by blast*)

end
end


theory tutorial_2 imports Main

begin

lemma 1: "(\<forall> x. P x \<longrightarrow> Q) \<longrightarrow> (\<exists> x. P x \<longrightarrow> Q)"
  apply (rule impI)
  apply (rule exI)
  apply (rule allE)
   apply assumption+

lemma 2: "\<not>(\<exists> x. P x) \<Longrightarrow> \<forall> x. \<not>P x"
  apply (rule allI)
  apply (rule notI)
  apply (erule notE)
  apply (rule exI)
  apply assumption

lemma 3: "\<not>(\<forall> x. P x) \<Longrightarrow> \<exists> x. \<not>P x"
  apply (rule ccontr)
  apply (erule notE)
  apply (rule allI)
  apply (rule ccontr)
  apply (erule notE)
  apply (rule exI)
  apply assumption

end


(*  Title:      HOL/Hoare/Arith2.thy
    Author:     Norbert Galm
    Copyright   1995 TUM

More arithmetic.  Much of this duplicates ex/Primes.
*)

theory Arith2
imports Main
begin

definition cd :: "[nat, nat, nat] => bool"
  where "cd x m n \<longleftrightarrow> x dvd m & x dvd n"

definition gcd :: "[nat, nat] => nat"
  where "gcd m n = (SOME x. cd x m n & (!y.(cd y m n) --> y<=x))"

primrec fac :: "nat => nat"
where
  "fac 0 = Suc 0"
| "fac (Suc n) = Suc n * fac n"

subsubsection {* cd *}

lemma cd_nnn: "0<n ==> cd n n n"
  apply (simp add: cd_def)
  done

lemma cd_le: "[| cd x m n; 0<m; 0<n |] ==> x<=m & x<=n"
  apply (unfold cd_def)
  apply (blast intro: dvd_imp_le)
  done

lemma cd_swap: "cd x m n = cd x n m"
  apply (unfold cd_def)
  apply blast
  done

lemma cd_diff_l: "n<=m ==> cd x m n = cd x (m-n) n"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

lemma cd_diff_r: "m<=n ==> cd x m n = cd x m (n-m)"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

subsubsection {* gcd *}

lemma gcd_nnn: "0<n ==> n = gcd n n"
  apply (unfold gcd_def)
  apply (frule cd_nnn)
  apply (rule some_equality [symmetric])
  apply (blast dest: cd_le)
  apply (blast intro: le_antisym dest: cd_le)
  done

lemma gcd_swap: "gcd m n = gcd n m"
  apply (simp add: gcd_def cd_swap)
  done

lemma gcd_diff_l: "n<=m ==> gcd m n = gcd (m-n) n"
  apply (unfold gcd_def)
  apply (subgoal_tac "n<=m ==> !x. cd x m n = cd x (m-n) n")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_l)
  done

lemma gcd_diff_r: "m<=n ==> gcd m n = gcd m (n-m)"
  apply (unfold gcd_def)
  apply (subgoal_tac "m<=n ==> !x. cd x m n = cd x m (n-m) ")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_r)
  done

subsubsection {* pow *}

lemma sq_pow_div2 [simp]:
    "m mod 2 = 0 ==> ((n::nat)*n)^(m div 2) = n^m"
  apply (simp add: power2_eq_square [symmetric] power_mult [symmetric] mult_div_cancel)
  done

end


theory prop_23
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

datatype NPair = Pairn Nat Nat
datatype PList = PNil | PCons NPair PList
fun ptake :: "Nat => PList => PList" where
"ptake Z     xs           = PNil"
| "ptake (S _) PNil         = PNil"
| "ptake (S n) (PCons x xs) = PCons x (ptake n xs)"

  fun pzip :: "NL => NL => PList" where
  "pzip (Nil) y = PNil"
  | "pzip (Cons z x2) (Nil) = PNil"
  | "pzip (Cons z x2) (Cons x3 x4) = PCons (Pairn z x3) (pzip x2 x4)"

  fun pappend :: "PList => PList => PList" where
  "pappend (PNil) y = y"
  | "pappend (PCons z xs) y = PCons z (pappend xs y)"
  fun prev :: "PList => PList" where
  "prev (PNil) = PNil"
  | "prev (PCons y xs) = pappend (prev xs) (PCons y (PNil))"

theorem zipNotNil: "notNil rs \<Longrightarrow> pzip (Cons t ts) rs = PCons (Pairn t (head rs)) (pzip ts (tail rs))"
by hipster_induct_schemes

end


(*  Title:      HOL/Nitpick_Examples/Datatype_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to datatypes.
*)

section \<open>Examples Featuring Nitpick Applied to Datatypes\<close>

theory Datatype_Nits
imports Main
begin

nitpick_params [verbose, card = 1-8, max_potential = 0,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

datatype nibble = Nibble0 | Nibble1 | Nibble2 | Nibble3
  | Nibble4 | Nibble5 | Nibble6 | Nibble7
  | Nibble8 | Nibble9 | NibbleA | NibbleB
  | NibbleC | NibbleD | NibbleE | NibbleF

primrec rot where
"rot Nibble0 = Nibble1" | "rot Nibble1 = Nibble2" | "rot Nibble2 = Nibble3" |
"rot Nibble3 = Nibble4" | "rot Nibble4 = Nibble5" | "rot Nibble5 = Nibble6" |
"rot Nibble6 = Nibble7" | "rot Nibble7 = Nibble8" | "rot Nibble8 = Nibble9" |
"rot Nibble9 = NibbleA" | "rot NibbleA = NibbleB" | "rot NibbleB = NibbleC" |
"rot NibbleC = NibbleD" | "rot NibbleD = NibbleE" | "rot NibbleE = NibbleF" |
"rot NibbleF = Nibble0"

lemma "rot n \<noteq> n"
nitpick [card = 1-8,16, verbose, expect = none]
sorry

lemma "rot Nibble2 \<noteq> Nibble3"
nitpick [card = 1, expect = none]
nitpick [card = 2, max Nibble4 = 0, expect = genuine]
nitpick [card = 2, max Nibble2 = 0, expect = none]
oops

lemma "(rot ^^ 15) n \<noteq> n"
nitpick [card = 17, expect = none]
sorry

lemma "(rot ^^ 15) n = n"
nitpick [card = 17, expect = genuine]
oops

lemma "(rot ^^ 16) n = n"
nitpick [card = 17, expect = none]
oops

datatype ('a, 'b) pd = Pd "'a \<times> 'b"

fun fs where
"fs (Pd (a, _)) = a"

fun sn where
"sn (Pd (_, b)) = b"

lemma "fs (Pd p) = fst p"
nitpick [card = 12, expect = none]
sorry

lemma "fs (Pd p) = snd p"
nitpick [expect = genuine]
oops

lemma "sn (Pd p) = snd p"
nitpick [card = 12, expect = none]
sorry

lemma "sn (Pd p) = fst p"
nitpick [expect = genuine]
oops

lemma "fs (Pd ((a, b), (c, d))) = (a, b)"
nitpick [expect = none]
sorry

lemma "fs (Pd ((a, b), (c, d))) = (c, d)"
nitpick [expect = genuine]
oops

datatype ('a, 'b) fn = Fn "'a \<Rightarrow> 'b"

fun app where
"app (Fn f) x = f x"

lemma "app (Fn g) y = g y"
nitpick [expect = none]
sorry

lemma "app (Fn g) y = g' y"
nitpick [expect = genuine]
oops

lemma "app (Fn g) y = g y'"
nitpick [expect = genuine]
oops

end


(*  Title:      ZF/OrderType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Order Types and Ordinal Arithmetic\<close>

theory OrderType imports OrderArith OrdQuant Nat begin

text\<open>The order type of a well-ordering is the least ordinal isomorphic to it.
Ordinal arithmetic is traditionally defined in terms of order types, as it is
here.  But a definition by transfinite recursion would be much simpler!\<close>

definition
  ordermap  :: "[i,i]=>i"  where
   "ordermap(A,r) == \<lambda>x\<in>A. wfrec[A](r, x, %x f. f `` pred(A,x,r))"

definition
  ordertype :: "[i,i]=>i"  where
   "ordertype(A,r) == ordermap(A,r)``A"

definition
  (*alternative definition of ordinal numbers*)
  Ord_alt   :: "i => o"  where
   "Ord_alt(X) == well_ord(X, Memrel(X)) & (\<forall>u\<in>X. u=pred(X, u, Memrel(X)))"

definition
  (*coercion to ordinal: if not, just 0*)
  ordify    :: "i=>i"  where
    "ordify(x) == if Ord(x) then x else 0"

definition
  (*ordinal multiplication*)
  omult      :: "[i,i]=>i"           (infixl \<open>**\<close> 70)  where
   "i ** j == ordertype(j*i, rmult(j,Memrel(j),i,Memrel(i)))"

definition
  (*ordinal addition*)
  raw_oadd   :: "[i,i]=>i"  where
    "raw_oadd(i,j) == ordertype(i+j, radd(i,Memrel(i),j,Memrel(j)))"

definition
  oadd      :: "[i,i]=>i"           (infixl \<open>++\<close> 65)  where
    "i ++ j == raw_oadd(ordify(i),ordify(j))"

definition
  (*ordinal subtraction*)
  odiff      :: "[i,i]=>i"           (infixl \<open>--\<close> 65)  where
    "i -- j == ordertype(i-j, Memrel(i))"

subsection\<open>Proofs needing the combination of Ordinal.thy and Order.thy\<close>

lemma le_well_ord_Memrel: "j \<le> i ==> well_ord(j, Memrel(i))"
apply (rule well_ordI)
apply (rule wf_Memrel [THEN wf_imp_wf_on])
apply (simp add: ltD lt_Ord linear_def
                 ltI [THEN lt_trans2 [of _ j i]])
apply (intro ballI Ord_linear)
apply (blast intro: Ord_in_Ord lt_Ord)+
done

(*"Ord(i) ==> well_ord(i, Memrel(i))"*)
lemmas well_ord_Memrel = le_refl [THEN le_well_ord_Memrel]

(*Kunen's Theorem 7.3 (i), page 16;  see also Ordinal/Ord_in_Ord
  The smaller ordinal is an initial segment of the larger *)
lemma lt_pred_Memrel:
    "j<i ==> pred(i, j, Memrel(i)) = j"
apply (simp add: pred_def lt_def)
apply (blast intro: Ord_trans)
done

lemma pred_Memrel:
      "x \<in> A ==> pred(A, x, Memrel(A)) = A \<inter> x"
by (unfold pred_def Memrel_def, blast)

lemma Ord_iso_implies_eq_lemma:
     "[| j<i;  f \<in> ord_iso(i,Memrel(i),j,Memrel(j)) |] ==> R"
apply (frule lt_pred_Memrel)
apply (erule ltE)
apply (rule well_ord_Memrel [THEN well_ord_iso_predE, of i f j], auto)
apply (unfold ord_iso_def)
(*Combining the two simplifications causes looping*)
apply (simp (no_asm_simp))
apply (blast intro: bij_is_fun [THEN apply_type] Ord_trans)
done

(*Kunen's Theorem 7.3 (ii), page 16.  Isomorphic ordinals are equal*)
lemma Ord_iso_implies_eq:
     "[| Ord(i);  Ord(j);  f \<in> ord_iso(i,Memrel(i),j,Memrel(j)) |]
      ==> i=j"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: ord_iso_sym Ord_iso_implies_eq_lemma)+
done

subsection\<open>Ordermap and ordertype\<close>

lemma ordermap_type:
    "ordermap(A,r) \<in> A -> ordertype(A,r)"
apply (unfold ordermap_def ordertype_def)
apply (rule lam_type)
apply (rule lamI [THEN imageI], assumption+)
done

subsubsection\<open>Unfolding of ordermap\<close>

(*Useful for cardinality reasoning; see CardinalArith.ML*)
lemma ordermap_eq_image:
    "[| wf[A](r);  x \<in> A |]
     ==> ordermap(A,r) ` x = ordermap(A,r) `` pred(A,x,r)"
apply (unfold ordermap_def pred_def)
apply (simp (no_asm_simp))
apply (erule wfrec_on [THEN trans], assumption)
apply (simp (no_asm_simp) add: subset_iff image_lam vimage_singleton_iff)
done

(*Useful for rewriting PROVIDED pred is not unfolded until later!*)
lemma ordermap_pred_unfold:
     "[| wf[A](r);  x \<in> A |]
      ==> ordermap(A,r) ` x = {ordermap(A,r)`y . y \<in> pred(A,x,r)}"
by (simp add: ordermap_eq_image pred_subset ordermap_type [THEN image_fun])

(*pred-unfolded version.  NOT suitable for rewriting -- loops!*)
lemmas ordermap_unfold = ordermap_pred_unfold [simplified pred_def]

(*The theorem above is

[| wf[A](r); x \<in> A |]
==> ordermap(A,r) ` x = {ordermap(A,r) ` y . y: {y \<in> A . <y,x> \<in> r}}

NOTE: the definition of ordermap used here delivers ordinals only if r is
transitive.  If r is the predecessor relation on the naturals then
ordermap(nat,predr) ` n equals {n-1} and not n.  A more complicated definition,
like

  ordermap(A,r) ` x = Union{succ(ordermap(A,r) ` y) . y: {y \<in> A . <y,x> \<in> r}},

might eliminate the need for r to be transitive.
*)

subsubsection\<open>Showing that ordermap, ordertype yield ordinals\<close>

lemma Ord_ordermap:
    "[| well_ord(A,r);  x \<in> A |] ==> Ord(ordermap(A,r) ` x)"
apply (unfold well_ord_def tot_ord_def part_ord_def, safe)
apply (rule_tac a=x in wf_on_induct, assumption+)
apply (simp (no_asm_simp) add: ordermap_pred_unfold)
apply (rule OrdI [OF _ Ord_is_Transset])
apply (unfold pred_def Transset_def)
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])+
done

lemma Ord_ordertype:
    "well_ord(A,r) ==> Ord(ordertype(A,r))"
apply (unfold ordertype_def)
apply (subst image_fun [OF ordermap_type subset_refl])
apply (rule OrdI [OF _ Ord_is_Transset])
prefer 2 apply (blast intro: Ord_ordermap)
apply (unfold Transset_def well_ord_def)
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])
done

subsubsection\<open>ordermap preserves the orderings in both directions\<close>

lemma ordermap_mono:
     "[| <w,x>: r;  wf[A](r);  w \<in> A; x \<in> A |]
      ==> ordermap(A,r)`w \<in> ordermap(A,r)`x"
apply (erule_tac x1 = x in ordermap_unfold [THEN ssubst], assumption, blast)
done

(*linearity of r is crucial here*)
lemma converse_ordermap_mono:
    "[| ordermap(A,r)`w \<in> ordermap(A,r)`x;  well_ord(A,r); w \<in> A; x \<in> A |]
     ==> <w,x>: r"
apply (unfold well_ord_def tot_ord_def, safe)
apply (erule_tac x=w and y=x in linearE, assumption+)
apply (blast elim!: mem_not_refl [THEN notE])
apply (blast dest: ordermap_mono intro: mem_asym)
done

lemma ordermap_surj: "ordermap(A, r) \<in> surj(A, ordertype(A, r))"
  unfolding ordertype_def
  by (rule surj_image) (rule ordermap_type)

lemma ordermap_bij:
    "well_ord(A,r) ==> ordermap(A,r) \<in> bij(A, ordertype(A,r))"
apply (unfold well_ord_def tot_ord_def bij_def inj_def)
apply (force intro!: ordermap_type ordermap_surj
             elim: linearE dest: ordermap_mono
             simp add: mem_not_refl)
done

subsubsection\<open>Isomorphisms involving ordertype\<close>

lemma ordertype_ord_iso:
 "well_ord(A,r)
  ==> ordermap(A,r) \<in> ord_iso(A,r, ordertype(A,r), Memrel(ordertype(A,r)))"
apply (unfold ord_iso_def)
apply (safe elim!: well_ord_is_wf
            intro!: ordermap_type [THEN apply_type] ordermap_mono ordermap_bij)
apply (blast dest!: converse_ordermap_mono)
done

lemma ordertype_eq:
     "[| f \<in> ord_iso(A,r,B,s);  well_ord(B,s) |]
      ==> ordertype(A,r) = ordertype(B,s)"
apply (frule well_ord_ord_iso, assumption)
apply (rule Ord_iso_implies_eq, (erule Ord_ordertype)+)
apply (blast intro: ord_iso_trans ord_iso_sym ordertype_ord_iso)
done

lemma ordertype_eq_imp_ord_iso:
     "[| ordertype(A,r) = ordertype(B,s); well_ord(A,r);  well_ord(B,s) |]
      ==> \<exists>f. f \<in> ord_iso(A,r,B,s)"
apply (rule exI)
apply (rule ordertype_ord_iso [THEN ord_iso_trans], assumption)
apply (erule ssubst)
apply (erule ordertype_ord_iso [THEN ord_iso_sym])
done

subsubsection\<open>Basic equalities for ordertype\<close>

(*Ordertype of Memrel*)
lemma le_ordertype_Memrel: "j \<le> i ==> ordertype(j,Memrel(i)) = j"
apply (rule Ord_iso_implies_eq [symmetric])
apply (erule ltE, assumption)
apply (blast intro: le_well_ord_Memrel Ord_ordertype)
apply (rule ord_iso_trans)
apply (erule_tac [2] le_well_ord_Memrel [THEN ordertype_ord_iso])
apply (rule id_bij [THEN ord_isoI])
apply (simp (no_asm_simp))
apply (fast elim: ltE Ord_in_Ord Ord_trans)
done

(*"Ord(i) ==> ordertype(i, Memrel(i)) = i"*)
lemmas ordertype_Memrel = le_refl [THEN le_ordertype_Memrel]

lemma ordertype_0 [simp]: "ordertype(0,r) = 0"
apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq, THEN trans])
apply (erule emptyE)
apply (rule well_ord_0)
apply (rule Ord_0 [THEN ordertype_Memrel])
done

(*Ordertype of rvimage:  [| f \<in> bij(A,B);  well_ord(B,s) |] ==>
                         ordertype(A, rvimage(A,f,s)) = ordertype(B,s) *)
lemmas bij_ordertype_vimage = ord_iso_rvimage [THEN ordertype_eq]

subsubsection\<open>A fundamental unfolding law for ordertype.\<close>

(*Ordermap returns the same result if applied to an initial segment*)
lemma ordermap_pred_eq_ordermap:
     "[| well_ord(A,r);  y \<in> A;  z \<in> pred(A,y,r) |]
      ==> ordermap(pred(A,y,r), r) ` z = ordermap(A, r) ` z"
apply (frule wf_on_subset_A [OF well_ord_is_wf pred_subset])
apply (rule_tac a=z in wf_on_induct, assumption+)
apply (safe elim!: predE)
apply (simp (no_asm_simp) add: ordermap_pred_unfold well_ord_is_wf pred_iff)
(*combining these two simplifications LOOPS! *)
apply (simp (no_asm_simp) add: pred_pred_eq)
apply (simp add: pred_def)
apply (rule RepFun_cong [OF _ refl])
apply (drule well_ord_is_trans_on)
apply (fast elim!: trans_onD)
done

lemma ordertype_unfold:
    "ordertype(A,r) = {ordermap(A,r)`y . y \<in> A}"
apply (unfold ordertype_def)
apply (rule image_fun [OF ordermap_type subset_refl])
done

text\<open>Theorems by Krzysztof Grabczewski; proofs simplified by lcp\<close>

lemma ordertype_pred_subset: "[| well_ord(A,r);  x \<in> A |] ==>
          ordertype(pred(A,x,r),r) \<subseteq> ordertype(A,r)"
apply (simp add: ordertype_unfold well_ord_subset [OF _ pred_subset])
apply (fast intro: ordermap_pred_eq_ordermap elim: predE)
done

lemma ordertype_pred_lt:
     "[| well_ord(A,r);  x \<in> A |]
      ==> ordertype(pred(A,x,r),r) < ordertype(A,r)"
apply (rule ordertype_pred_subset [THEN subset_imp_le, THEN leE])
apply (simp_all add: Ord_ordertype well_ord_subset [OF _ pred_subset])
apply (erule sym [THEN ordertype_eq_imp_ord_iso, THEN exE])
apply (erule_tac [3] well_ord_iso_predE)
apply (simp_all add: well_ord_subset [OF _ pred_subset])
done

(*May rewrite with this -- provided no rules are supplied for proving that
        well_ord(pred(A,x,r), r) *)
lemma ordertype_pred_unfold:
     "well_ord(A,r)
      ==> ordertype(A,r) = {ordertype(pred(A,x,r),r). x \<in> A}"
apply (rule equalityI)
apply (safe intro!: ordertype_pred_lt [THEN ltD])
apply (auto simp add: ordertype_def well_ord_is_wf [THEN ordermap_eq_image]
                      ordermap_type [THEN image_fun]
                      ordermap_pred_eq_ordermap pred_subset)
done

subsection\<open>Alternative definition of ordinal\<close>

(*proof by Krzysztof Grabczewski*)
lemma Ord_is_Ord_alt: "Ord(i) ==> Ord_alt(i)"
apply (unfold Ord_alt_def)
apply (rule conjI)
apply (erule well_ord_Memrel)
apply (unfold Ord_def Transset_def pred_def Memrel_def, blast)
done

(*proof by lcp*)
lemma Ord_alt_is_Ord:
    "Ord_alt(i) ==> Ord(i)"
apply (unfold Ord_alt_def Ord_def Transset_def well_ord_def
                     tot_ord_def part_ord_def trans_on_def)
apply (simp add: pred_Memrel)
apply (blast elim!: equalityE)
done

subsection\<open>Ordinal Addition\<close>

subsubsection\<open>Order Type calculations for radd\<close>

text\<open>Addition with 0\<close>

lemma bij_sum_0: "(\<lambda>z\<in>A+0. case(%x. x, %y. y, z)) \<in> bij(A+0, A)"
apply (rule_tac d = Inl in lam_bijective, safe)
apply (simp_all (no_asm_simp))
done

lemma ordertype_sum_0_eq:
     "well_ord(A,r) ==> ordertype(A+0, radd(A,r,0,s)) = ordertype(A,r)"
apply (rule bij_sum_0 [THEN ord_isoI, THEN ordertype_eq])
prefer 2 apply assumption
apply force
done

lemma bij_0_sum: "(\<lambda>z\<in>0+A. case(%x. x, %y. y, z)) \<in> bij(0+A, A)"
apply (rule_tac d = Inr in lam_bijective, safe)
apply (simp_all (no_asm_simp))
done

lemma ordertype_0_sum_eq:
     "well_ord(A,r) ==> ordertype(0+A, radd(0,s,A,r)) = ordertype(A,r)"
apply (rule bij_0_sum [THEN ord_isoI, THEN ordertype_eq])
prefer 2 apply assumption
apply force
done

text\<open>Initial segments of radd.  Statements by Grabczewski\<close>

(*In fact, pred(A+B, Inl(a), radd(A,r,B,s)) = pred(A,a,r)+0 *)
lemma pred_Inl_bij:
 "a \<in> A ==> (\<lambda>x\<in>pred(A,a,r). Inl(x))
          \<in> bij(pred(A,a,r), pred(A+B, Inl(a), radd(A,r,B,s)))"
apply (unfold pred_def)
apply (rule_tac d = "case (%x. x, %y. y) " in lam_bijective)
apply auto
done

lemma ordertype_pred_Inl_eq:
     "[| a \<in> A;  well_ord(A,r) |]
      ==> ordertype(pred(A+B, Inl(a), radd(A,r,B,s)), radd(A,r,B,s)) =
          ordertype(pred(A,a,r), r)"
apply (rule pred_Inl_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
apply (simp_all add: well_ord_subset [OF _ pred_subset])
apply (simp add: pred_def)
done

lemma pred_Inr_bij:
 "b \<in> B ==>
         id(A+pred(B,b,s))
         \<in> bij(A+pred(B,b,s), pred(A+B, Inr(b), radd(A,r,B,s)))"
apply (unfold pred_def id_def)
apply (rule_tac d = "%z. z" in lam_bijective, auto)
done

lemma ordertype_pred_Inr_eq:
     "[| b \<in> B;  well_ord(A,r);  well_ord(B,s) |]
      ==> ordertype(pred(A+B, Inr(b), radd(A,r,B,s)), radd(A,r,B,s)) =
          ordertype(A+pred(B,b,s), radd(A,r,pred(B,b,s),s))"
apply (rule pred_Inr_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
prefer 2 apply (force simp add: pred_def id_def, assumption)
apply (blast intro: well_ord_radd well_ord_subset [OF _ pred_subset])
done

subsubsection\<open>ordify: trivial coercion to an ordinal\<close>

lemma Ord_ordify [iff, TC]: "Ord(ordify(x))"
by (simp add: ordify_def)

(*Collapsing*)
lemma ordify_idem [simp]: "ordify(ordify(x)) = ordify(x)"
by (simp add: ordify_def)

subsubsection\<open>Basic laws for ordinal addition\<close>

lemma Ord_raw_oadd: "[|Ord(i); Ord(j)|] ==> Ord(raw_oadd(i,j))"
by (simp add: raw_oadd_def ordify_def Ord_ordertype well_ord_radd
              well_ord_Memrel)

lemma Ord_oadd [iff,TC]: "Ord(i++j)"
by (simp add: oadd_def Ord_raw_oadd)

text\<open>Ordinal addition with zero\<close>

lemma raw_oadd_0: "Ord(i) ==> raw_oadd(i,0) = i"
by (simp add: raw_oadd_def ordify_def ordertype_sum_0_eq
              ordertype_Memrel well_ord_Memrel)

lemma oadd_0 [simp]: "Ord(i) ==> i++0 = i"
apply (simp (no_asm_simp) add: oadd_def raw_oadd_0 ordify_def)
done

lemma raw_oadd_0_left: "Ord(i) ==> raw_oadd(0,i) = i"
by (simp add: raw_oadd_def ordify_def ordertype_0_sum_eq ordertype_Memrel
              well_ord_Memrel)

lemma oadd_0_left [simp]: "Ord(i) ==> 0++i = i"
by (simp add: oadd_def raw_oadd_0_left ordify_def)

lemma oadd_eq_if_raw_oadd:
     "i++j = (if Ord(i) then (if Ord(j) then raw_oadd(i,j) else i)
              else (if Ord(j) then j else 0))"
by (simp add: oadd_def ordify_def raw_oadd_0_left raw_oadd_0)

lemma raw_oadd_eq_oadd: "[|Ord(i); Ord(j)|] ==> raw_oadd(i,j) = i++j"
by (simp add: oadd_def ordify_def)

(*** Further properties of ordinal addition.  Statements by Grabczewski,
    proofs by lcp. ***)

(*Surely also provable by transfinite induction on j?*)
lemma lt_oadd1: "k<i ==> k < i++j"
apply (simp add: oadd_def ordify_def lt_Ord2 raw_oadd_0, clarify)
apply (simp add: raw_oadd_def)
apply (rule ltE, assumption)
apply (rule ltI)
apply (force simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel
          ordertype_pred_Inl_eq lt_pred_Memrel leI [THEN le_ordertype_Memrel])
apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)
done

(*Thus also we obtain the rule  @{term"i++j = k ==> i \<le> k"} *)
lemma oadd_le_self: "Ord(i) ==> i \<le> i++j"
apply (rule all_lt_imp_le)
apply (auto simp add: Ord_oadd lt_oadd1)
done

text\<open>Various other results\<close>

lemma id_ord_iso_Memrel: "A<=B ==> id(A) \<in> ord_iso(A, Memrel(A), A, Memrel(B))"
apply (rule id_bij [THEN ord_isoI])
apply (simp (no_asm_simp))
apply blast
done

lemma subset_ord_iso_Memrel:
     "[| f \<in> ord_iso(A,Memrel(B),C,r); A<=B |] ==> f \<in> ord_iso(A,Memrel(A),C,r)"
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN fun_is_rel])
apply (frule ord_iso_trans [OF id_ord_iso_Memrel], assumption)
apply (simp add: right_comp_id)
done

lemma restrict_ord_iso:
     "[| f \<in> ord_iso(i, Memrel(i), Order.pred(A,a,r), r);  a \<in> A; j < i;
       trans[A](r) |]
      ==> restrict(f,j) \<in> ord_iso(j, Memrel(j), Order.pred(A,f`j,r), r)"
apply (frule ltD)
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
apply (frule ord_iso_restrict_pred, assumption)
apply (simp add: pred_iff trans_pred_pred_eq lt_pred_Memrel)
apply (blast intro!: subset_ord_iso_Memrel le_imp_subset [OF leI])
done

lemma restrict_ord_iso2:
     "[| f \<in> ord_iso(Order.pred(A,a,r), r, i, Memrel(i));  a \<in> A;
       j < i; trans[A](r) |]
      ==> converse(restrict(converse(f), j))
          \<in> ord_iso(Order.pred(A, converse(f)`j, r), r, j, Memrel(j))"
by (blast intro: restrict_ord_iso ord_iso_sym ltI)

lemma ordertype_sum_Memrel:
     "[| well_ord(A,r);  k<j |]
      ==> ordertype(A+k, radd(A, r, k, Memrel(j))) =
          ordertype(A+k, radd(A, r, k, Memrel(k)))"
apply (erule ltE)
apply (rule ord_iso_refl [THEN sum_ord_iso_cong, THEN ordertype_eq])
apply (erule OrdmemD [THEN id_ord_iso_Memrel, THEN ord_iso_sym])
apply (simp_all add: well_ord_radd well_ord_Memrel)
done

lemma oadd_lt_mono2: "k<j ==> i++k < i++j"
apply (simp add: oadd_def ordify_def raw_oadd_0_left lt_Ord lt_Ord2, clarify)
apply (simp add: raw_oadd_def)
apply (rule ltE, assumption)
apply (rule ordertype_pred_unfold [THEN equalityD2, THEN subsetD, THEN ltI])
apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
apply (rule bexI)
apply (erule_tac [2] InrI)
apply (simp add: ordertype_pred_Inr_eq well_ord_Memrel lt_pred_Memrel
                 leI [THEN le_ordertype_Memrel] ordertype_sum_Memrel)
done

lemma oadd_lt_cancel2: "[| i++j < i++k;  Ord(j) |] ==> j<k"
apply (simp (asm_lr) add: oadd_eq_if_raw_oadd split: split_if_asm)
 prefer 2
 apply (frule_tac i = i and j = j in oadd_le_self)
 apply (simp (asm_lr) add: oadd_def ordify_def lt_Ord not_lt_iff_le [THEN iff_sym])
apply (rule Ord_linear_lt, auto)
apply (simp_all add: raw_oadd_eq_oadd)
apply (blast dest: oadd_lt_mono2 elim: lt_irrefl lt_asym)+
done

lemma oadd_lt_iff2: "Ord(j) ==> i++j < i++k \<longleftrightarrow> j<k"
by (blast intro!: oadd_lt_mono2 dest!: oadd_lt_cancel2)

lemma oadd_inject: "[| i++j = i++k;  Ord(j); Ord(k) |] ==> j=k"
apply (simp add: oadd_eq_if_raw_oadd split: split_if_asm)
apply (simp add: raw_oadd_eq_oadd)
apply (rule Ord_linear_lt, auto)
apply (force dest: oadd_lt_mono2 [of concl: i] simp add: lt_not_refl)+
done

lemma lt_oadd_disj: "k < i++j ==> k<i | (\<exists>l\<in>j. k = i++l )"
apply (simp add: Ord_in_Ord' [of _ j] oadd_eq_if_raw_oadd
            split: split_if_asm)
 prefer 2
 apply (simp add: Ord_in_Ord' [of _ j] lt_def)
apply (simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel raw_oadd_def)
apply (erule ltD [THEN RepFunE])
apply (force simp add: ordertype_pred_Inl_eq well_ord_Memrel ltI
                       lt_pred_Memrel le_ordertype_Memrel leI
                       ordertype_pred_Inr_eq ordertype_sum_Memrel)
done

subsubsection\<open>Ordinal addition with successor -- via associativity!\<close>

lemma oadd_assoc: "(i++j)++k = i++(j++k)"
apply (simp add: oadd_eq_if_raw_oadd Ord_raw_oadd raw_oadd_0 raw_oadd_0_left, clarify)
apply (simp add: raw_oadd_def)
apply (rule ordertype_eq [THEN trans])
apply (rule sum_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                 ord_iso_refl])
apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
apply (rule sum_assoc_ord_iso [THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] sum_ord_iso_cong [OF ord_iso_refl ordertype_ord_iso])
apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)+
done

lemma oadd_unfold: "[| Ord(i);  Ord(j) |] ==> i++j = i \<union> (\<Union>k\<in>j. {i++k})"
apply (rule subsetI [THEN equalityI])
apply (erule ltI [THEN lt_oadd_disj, THEN disjE])
apply (blast intro: Ord_oadd)
apply (blast elim!: ltE, blast)
apply (force intro: lt_oadd1 oadd_lt_mono2 simp add: Ord_mem_iff_lt)
done

lemma oadd_1: "Ord(i) ==> i++1 = succ(i)"
apply (simp (no_asm_simp) add: oadd_unfold Ord_1 oadd_0)
apply blast
done

lemma oadd_succ [simp]: "Ord(j) ==> i++succ(j) = succ(i++j)"
apply (simp add: oadd_eq_if_raw_oadd, clarify)
apply (simp add: raw_oadd_eq_oadd)
apply (simp add: oadd_1 [of j, symmetric] oadd_1 [of "i++j", symmetric]
                 oadd_assoc)
done

text\<open>Ordinal addition with limit ordinals\<close>

lemma oadd_UN:
     "[| !!x. x \<in> A ==> Ord(j(x));  a \<in> A |]
      ==> i ++ (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i++j(x))"
by (blast intro: ltI Ord_UN Ord_oadd lt_oadd1 [THEN ltD]
                 oadd_lt_mono2 [THEN ltD]
          elim!: ltE dest!: ltI [THEN lt_oadd_disj])

lemma oadd_Limit: "Limit(j) ==> i++j = (\<Union>k\<in>j. i++k)"
apply (frule Limit_has_0 [THEN ltD])
apply (simp add: Limit_is_Ord [THEN Ord_in_Ord] oadd_UN [symmetric]
                 Union_eq_UN [symmetric] Limit_Union_eq)
done

lemma oadd_eq_0_iff: "[| Ord(i); Ord(j) |] ==> (i ++ j) = 0 \<longleftrightarrow> i=0 & j=0"
apply (erule trans_induct3 [of j])
apply (simp_all add: oadd_Limit)
apply (simp add: Union_empty_iff Limit_def lt_def, blast)
done

lemma oadd_eq_lt_iff: "[| Ord(i); Ord(j) |] ==> 0 < (i ++ j) \<longleftrightarrow> 0<i | 0<j"
by (simp add: Ord_0_lt_iff [symmetric] oadd_eq_0_iff)

lemma oadd_LimitI: "[| Ord(i); Limit(j) |] ==> Limit(i ++ j)"
apply (simp add: oadd_Limit)
apply (frule Limit_has_1 [THEN ltD])
apply (rule increasing_LimitI)
 apply (rule Ord_0_lt)
  apply (blast intro: Ord_in_Ord [OF Limit_is_Ord])
 apply (force simp add: Union_empty_iff oadd_eq_0_iff
                        Limit_is_Ord [of j, THEN Ord_in_Ord], auto)
apply (rule_tac x="succ(y)" in bexI)
 apply (simp add: ltI Limit_is_Ord [of j, THEN Ord_in_Ord])
apply (simp add: Limit_def lt_def)
done

text\<open>Order/monotonicity properties of ordinal addition\<close>

lemma oadd_le_self2: "Ord(i) ==> i \<le> j++i"
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: Ord_0_le)
next
  case (succ i) thus ?case by (simp add: oadd_succ succ_leI)
next
  case (limit l)
  hence "l = (\<Union>x\<in>l. x)"
    by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
  also have "... \<le> (\<Union>x\<in>l. j++x)"
    by (rule le_implies_UN_le_UN) (rule limit.hyps)
  finally have "l \<le> (\<Union>x\<in>l. j++x)" .
  thus ?case using limit.hyps by (simp add: oadd_Limit)
qed

lemma oadd_le_mono1: "k \<le> j ==> k++i \<le> j++i"
apply (frule lt_Ord)
apply (frule le_Ord2)
apply (simp add: oadd_eq_if_raw_oadd, clarify)
apply (simp add: raw_oadd_eq_oadd)
apply (erule_tac i = i in trans_induct3)
apply (simp (no_asm_simp))
apply (simp (no_asm_simp) add: oadd_succ succ_le_iff)
apply (simp (no_asm_simp) add: oadd_Limit)
apply (rule le_implies_UN_le_UN, blast)
done

lemma oadd_lt_mono: "[| i' \<le> i;  j'<j |] ==> i'++j' < i++j"
by (blast intro: lt_trans1 oadd_le_mono1 oadd_lt_mono2 Ord_succD elim: ltE)

lemma oadd_le_mono: "[| i' \<le> i;  j' \<le> j |] ==> i'++j' \<le> i++j"
by (simp del: oadd_succ add: oadd_succ [symmetric] le_Ord2 oadd_lt_mono)

lemma oadd_le_iff2: "[| Ord(j); Ord(k) |] ==> i++j \<le> i++k \<longleftrightarrow> j \<le> k"
by (simp del: oadd_succ add: oadd_lt_iff2 oadd_succ [symmetric] Ord_succ)

lemma oadd_lt_self: "[| Ord(i);  0<j |] ==> i < i++j"
apply (rule lt_trans2)
apply (erule le_refl)
apply (simp only: lt_Ord2  oadd_1 [of i, symmetric])
apply (blast intro: succ_leI oadd_le_mono)
done

text\<open>Every ordinal is exceeded by some limit ordinal.\<close>
lemma Ord_imp_greater_Limit: "Ord(i) ==> \<exists>k. i<k & Limit(k)"
apply (rule_tac x="i ++ nat" in exI)
apply (blast intro: oadd_LimitI  oadd_lt_self  Limit_nat [THEN Limit_has_0])
done

lemma Ord2_imp_greater_Limit: "[|Ord(i); Ord(j)|] ==> \<exists>k. i<k & j<k & Limit(k)"
apply (insert Ord_Un [of i j, THEN Ord_imp_greater_Limit])
apply (simp add: Un_least_lt_iff)
done

subsection\<open>Ordinal Subtraction\<close>

text\<open>The difference is \<^term>\<open>ordertype(j-i, Memrel(j))\<close>.
    It's probably simpler to define the difference recursively!\<close>

lemma bij_sum_Diff:
     "A<=B ==> (\<lambda>y\<in>B. if(y \<in> A, Inl(y), Inr(y))) \<in> bij(B, A+(B-A))"
apply (rule_tac d = "case (%x. x, %y. y) " in lam_bijective)
apply (blast intro!: if_type)
apply (fast intro!: case_type)
apply (erule_tac [2] sumE)
apply (simp_all (no_asm_simp))
done

lemma ordertype_sum_Diff:
     "i \<le> j ==>
            ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j))) =
            ordertype(j, Memrel(j))"
apply (safe dest!: le_subset_iff [THEN iffD1])
apply (rule bij_sum_Diff [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
apply (erule_tac [3] well_ord_Memrel, assumption)
apply (simp (no_asm_simp))
apply (frule_tac j = y in Ord_in_Ord, assumption)
apply (frule_tac j = x in Ord_in_Ord, assumption)
apply (simp (no_asm_simp) add: Ord_mem_iff_lt lt_Ord not_lt_iff_le)
apply (blast intro: lt_trans2 lt_trans)
done

lemma Ord_odiff [simp,TC]:
    "[| Ord(i);  Ord(j) |] ==> Ord(i--j)"
apply (unfold odiff_def)
apply (blast intro: Ord_ordertype Diff_subset well_ord_subset well_ord_Memrel)
done

lemma raw_oadd_ordertype_Diff:
   "i \<le> j
    ==> raw_oadd(i,j--i) = ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j)))"
apply (simp add: raw_oadd_def odiff_def)
apply (safe dest!: le_subset_iff [THEN iffD1])
apply (rule sum_ord_iso_cong [THEN ordertype_eq])
apply (erule id_ord_iso_Memrel)
apply (rule ordertype_ord_iso [THEN ord_iso_sym])
apply (blast intro: well_ord_radd Diff_subset well_ord_subset well_ord_Memrel)+
done

lemma oadd_odiff_inverse: "i \<le> j ==> i ++ (j--i) = j"
by (simp add: lt_Ord le_Ord2 oadd_def ordify_def raw_oadd_ordertype_Diff
              ordertype_sum_Diff ordertype_Memrel lt_Ord2 [THEN Ord_succD])

(*By oadd_inject, the difference between i and j is unique.  Note that we get
  i++j = k  ==>  j = k--i.  *)
lemma odiff_oadd_inverse: "[| Ord(i); Ord(j) |] ==> (i++j) -- i = j"
apply (rule oadd_inject)
apply (blast intro: oadd_odiff_inverse oadd_le_self)
apply (blast intro: Ord_ordertype Ord_oadd Ord_odiff)+
done

lemma odiff_lt_mono2: "[| i<j;  k \<le> i |] ==> i--k < j--k"
apply (rule_tac i = k in oadd_lt_cancel2)
apply (simp add: oadd_odiff_inverse)
apply (subst oadd_odiff_inverse)
apply (blast intro: le_trans leI, assumption)
apply (simp (no_asm_simp) add: lt_Ord le_Ord2)
done

subsection\<open>Ordinal Multiplication\<close>

lemma Ord_omult [simp,TC]:
    "[| Ord(i);  Ord(j) |] ==> Ord(i**j)"
apply (unfold omult_def)
apply (blast intro: Ord_ordertype well_ord_rmult well_ord_Memrel)
done

subsubsection\<open>A useful unfolding law\<close>

lemma pred_Pair_eq:
 "[| a \<in> A;  b \<in> B |] ==> pred(A*B, <a,b>, rmult(A,r,B,s)) =
                      pred(A,a,r)*B \<union> ({a} * pred(B,b,s))"
apply (unfold pred_def, blast)
done

lemma ordertype_pred_Pair_eq:
     "[| a \<in> A;  b \<in> B;  well_ord(A,r);  well_ord(B,s) |] ==>
         ordertype(pred(A*B, <a,b>, rmult(A,r,B,s)), rmult(A,r,B,s)) =
         ordertype(pred(A,a,r)*B + pred(B,b,s),
                  radd(A*B, rmult(A,r,B,s), B, s))"
apply (simp (no_asm_simp) add: pred_Pair_eq)
apply (rule ordertype_eq [symmetric])
apply (rule prod_sum_singleton_ord_iso)
apply (simp_all add: pred_subset well_ord_rmult [THEN well_ord_subset])
apply (blast intro: pred_subset well_ord_rmult [THEN well_ord_subset]
             elim!: predE)
done

lemma ordertype_pred_Pair_lemma:
    "[| i'<i;  j'<j |]
     ==> ordertype(pred(i*j, <i',j'>, rmult(i,Memrel(i),j,Memrel(j))),
                   rmult(i,Memrel(i),j,Memrel(j))) =
         raw_oadd (j**i', j')"
apply (unfold raw_oadd_def omult_def)
apply (simp add: ordertype_pred_Pair_eq lt_pred_Memrel ltD lt_Ord2
                 well_ord_Memrel)
apply (rule trans)
 apply (rule_tac [2] ordertype_ord_iso
                      [THEN sum_ord_iso_cong, THEN ordertype_eq])
  apply (rule_tac [3] ord_iso_refl)
apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq])
apply (elim SigmaE sumE ltE ssubst)
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype lt_Ord lt_Ord2)
apply (blast intro: Ord_trans)+
done

lemma lt_omult:
 "[| Ord(i);  Ord(j);  k<j**i |]
  ==> \<exists>j' i'. k = j**i' ++ j' & j'<j & i'<i"
apply (unfold omult_def)
apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel)
apply (safe elim!: ltE)
apply (simp add: ordertype_pred_Pair_lemma ltI raw_oadd_eq_oadd
            omult_def [symmetric] Ord_in_Ord' [of _ i] Ord_in_Ord' [of _ j])
apply (blast intro: ltI)
done

lemma omult_oadd_lt:
     "[| j'<j;  i'<i |] ==> j**i' ++ j'  <  j**i"
apply (unfold omult_def)
apply (rule ltI)
 prefer 2
 apply (simp add: Ord_ordertype well_ord_rmult well_ord_Memrel lt_Ord2)
apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel lt_Ord2)
apply (rule bexI [of _ i'])
apply (rule bexI [of _ j'])
apply (simp add: ordertype_pred_Pair_lemma ltI omult_def [symmetric])
apply (simp add: lt_Ord lt_Ord2 raw_oadd_eq_oadd)
apply (simp_all add: lt_def)
done

lemma omult_unfold:
     "[| Ord(i);  Ord(j) |] ==> j**i = (\<Union>j'\<in>j. \<Union>i'\<in>i. {j**i' ++ j'})"
apply (rule subsetI [THEN equalityI])
apply (rule lt_omult [THEN exE])
apply (erule_tac [3] ltI)
apply (simp_all add: Ord_omult)
apply (blast elim!: ltE)
apply (blast intro: omult_oadd_lt [THEN ltD] ltI)
done

subsubsection\<open>Basic laws for ordinal multiplication\<close>

text\<open>Ordinal multiplication by zero\<close>

lemma omult_0 [simp]: "i**0 = 0"
apply (unfold omult_def)
apply (simp (no_asm_simp))
done

lemma omult_0_left [simp]: "0**i = 0"
apply (unfold omult_def)
apply (simp (no_asm_simp))
done

text\<open>Ordinal multiplication by 1\<close>

lemma omult_1 [simp]: "Ord(i) ==> i**1 = i"
apply (unfold omult_def)
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = snd and d = "%z.<0,z>"  in lam_bijective)
apply (auto elim!: snd_type well_ord_Memrel ordertype_Memrel)
done

lemma omult_1_left [simp]: "Ord(i) ==> 1**i = i"
apply (unfold omult_def)
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = fst and d = "%z.<z,0>" in lam_bijective)
apply (auto elim!: fst_type well_ord_Memrel ordertype_Memrel)
done

text\<open>Distributive law for ordinal multiplication and addition\<close>

lemma oadd_omult_distrib:
     "[| Ord(i);  Ord(j);  Ord(k) |] ==> i**(j++k) = (i**j)++(i**k)"
apply (simp add: oadd_eq_if_raw_oadd)
apply (simp add: omult_def raw_oadd_def)
apply (rule ordertype_eq [THEN trans])
apply (rule prod_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                  ord_iso_refl])
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype)
apply (rule sum_prod_distrib_ord_iso [THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] sum_ord_iso_cong [OF ordertype_ord_iso ordertype_ord_iso])
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype)
done

lemma omult_succ: "[| Ord(i);  Ord(j) |] ==> i**succ(j) = (i**j)++i"
by (simp del: oadd_succ add: oadd_1 [of j, symmetric] oadd_omult_distrib)

text\<open>Associative law\<close>

lemma omult_assoc:
    "[| Ord(i);  Ord(j);  Ord(k) |] ==> (i**j)**k = i**(j**k)"
apply (unfold omult_def)
apply (rule ordertype_eq [THEN trans])
apply (rule prod_ord_iso_cong [OF ord_iso_refl
                                  ordertype_ord_iso [THEN ord_iso_sym]])
apply (blast intro: well_ord_rmult well_ord_Memrel)+
apply (rule prod_assoc_ord_iso
             [THEN ord_iso_sym, THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] prod_ord_iso_cong [OF ordertype_ord_iso ord_iso_refl])
apply (blast intro: well_ord_rmult well_ord_Memrel Ord_ordertype)+
done

text\<open>Ordinal multiplication with limit ordinals\<close>

lemma omult_UN:
     "[| Ord(i);  !!x. x \<in> A ==> Ord(j(x)) |]
      ==> i ** (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i**j(x))"
by (simp (no_asm_simp) add: Ord_UN omult_unfold, blast)

lemma omult_Limit: "[| Ord(i);  Limit(j) |] ==> i**j = (\<Union>k\<in>j. i**k)"
by (simp add: Limit_is_Ord [THEN Ord_in_Ord] omult_UN [symmetric]
              Union_eq_UN [symmetric] Limit_Union_eq)

subsubsection\<open>Ordering/monotonicity properties of ordinal multiplication\<close>

(*As a special case we have "[| 0<i;  0<j |] ==> 0 < i**j" *)
lemma lt_omult1: "[| k<i;  0<j |] ==> k < i**j"
apply (safe elim!: ltE intro!: ltI Ord_omult)
apply (force simp add: omult_unfold)
done

lemma omult_le_self: "[| Ord(i);  0<j |] ==> i \<le> i**j"
by (blast intro: all_lt_imp_le Ord_omult lt_omult1 lt_Ord2)

lemma omult_le_mono1:
  assumes kj: "k \<le> j" and i: "Ord(i)" shows "k**i \<le> j**i"
proof -
  have o: "Ord(k)" "Ord(j)" by (rule lt_Ord [OF kj] le_Ord2 [OF kj])+
  show ?thesis using i
  proof (induct i rule: trans_induct3)
    case 0 thus ?case
      by simp
  next
    case (succ i) thus ?case
      by (simp add: o kj omult_succ oadd_le_mono)
  next
    case (limit l)
    thus ?case
      by (auto simp add: o kj omult_Limit le_implies_UN_le_UN)
  qed
qed

lemma omult_lt_mono2: "[| k<j;  0<i |] ==> i**k < i**j"
apply (rule ltI)
apply (simp (no_asm_simp) add: omult_unfold lt_Ord2)
apply (safe elim!: ltE intro!: Ord_omult)
apply (force simp add: Ord_omult)
done

lemma omult_le_mono2: "[| k \<le> j;  Ord(i) |] ==> i**k \<le> i**j"
apply (rule subset_imp_le)
apply (safe elim!: ltE dest!: Ord_succD intro!: Ord_omult)
apply (simp add: omult_unfold)
apply (blast intro: Ord_trans)
done

lemma omult_le_mono: "[| i' \<le> i;  j' \<le> j |] ==> i'**j' \<le> i**j"
by (blast intro: le_trans omult_le_mono1 omult_le_mono2 Ord_succD elim: ltE)

lemma omult_lt_mono: "[| i' \<le> i;  j'<j;  0<i |] ==> i'**j' < i**j"
by (blast intro: lt_trans1 omult_le_mono1 omult_lt_mono2 Ord_succD elim: ltE)

lemma omult_le_self2:
  assumes i: "Ord(i)" and j: "0<j" shows "i \<le> j**i"
proof -
  have oj: "Ord(j)" by (rule lt_Ord2 [OF j])
  show ?thesis using i
  proof (induct i rule: trans_induct3)
    case 0 thus ?case
      by simp
  next
    case (succ i)
    have "j ** i ++ 0 < j ** i ++ j"
      by (rule oadd_lt_mono2 [OF j])
    with succ.hyps show ?case
      by (simp add: oj j omult_succ ) (rule lt_trans1)
  next
    case (limit l)
    hence "l = (\<Union>x\<in>l. x)"
      by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
    also have "... \<le> (\<Union>x\<in>l. j**x)"
      by (rule le_implies_UN_le_UN) (rule limit.hyps)
    finally have "l \<le> (\<Union>x\<in>l. j**x)" .
    thus ?case using limit.hyps by (simp add: oj omult_Limit)
  qed
qed

text\<open>Further properties of ordinal multiplication\<close>

lemma omult_inject: "[| i**j = i**k;  0<i;  Ord(j);  Ord(k) |] ==> j=k"
apply (rule Ord_linear_lt)
prefer 4 apply assumption
apply auto
apply (force dest: omult_lt_mono2 simp add: lt_not_refl)+
done

subsection\<open>The Relation \<^term>\<open>Lt\<close>\<close>

lemma wf_Lt: "wf(Lt)"
apply (rule wf_subset)
apply (rule wf_Memrel)
apply (auto simp add: Lt_def Memrel_def lt_def)
done

lemma irrefl_Lt: "irrefl(A,Lt)"
by (auto simp add: Lt_def irrefl_def)

lemma trans_Lt: "trans[A](Lt)"
apply (simp add: Lt_def trans_on_def)
apply (blast intro: lt_trans)
done

lemma part_ord_Lt: "part_ord(A,Lt)"
by (simp add: part_ord_def irrefl_Lt trans_Lt)

lemma linear_Lt: "linear(nat,Lt)"
apply (auto dest!: not_lt_imp_le simp add: Lt_def linear_def le_iff)
apply (drule lt_asym, auto)
done

lemma tot_ord_Lt: "tot_ord(nat,Lt)"
by (simp add: tot_ord_def linear_Lt part_ord_Lt)

lemma well_ord_Lt: "well_ord(nat,Lt)"
by (simp add: well_ord_def wf_Lt wf_imp_wf_on tot_ord_Lt)

end


theory StreamFriends
  imports Main "$HIPSTER_HOME/IsaHipster"
    "~~/src/HOL/Library/BNF_Corec"
begin
(* Set Hipster tactic *)
setup Tactic_Data.set_sledgehammer_coinduct

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")
primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "siterate f a = SCons a (siterate f (f a))"
primcorec monomap :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a Stream \<Rightarrow> 'a Stream" where
  "monomap f xs = SCons (f (shd xs)) (monomap f (stl xs))"
friend_of_corec monomap where
   "monomap f xs = SCons (f (shd xs)) (monomap f (stl xs))"
  by (auto intro: monomap.code)

corec srecurse :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "srecurse f a = SCons a (monomap f (srecurse f a))"
(*
lemma recurse_simps[simp]:
      "stl (srecurse f a) = monomap f (srecurse f a)"
  by - (subst srecurse.code,simp)+
*)
(* Call Hipster for coinductive theory exploration *)
cohipster srecurse siterate
lemma lemma_a [thy_expl]: "monomap y (siterate y z) = siterate y (y z)"
  by(coinduction arbitrary: y z rule: Stream.coinduct_strong)
    auto

lemma lemma_aa [thy_expl]: "monomap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
  by (metis Stream.sel(1) Stream.sel(2) StreamFriends.lemma_a monomap.friend.code)

lemma lemma_ab [thy_expl]: "srecurse y z = siterate y z"
  by(coinduction rule: srecurse.coinduct)
    (smt Stream.sel(1) Stream.sel(2) lemma_a siterate.code srecurse.code srecurse.cong_base srecurse.cong_monomap)

end