(* ---------------------------------------------------------------------------- *)
section \<open>Homogeneous coordinates in extended complex plane\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Extended complex plane $\mathbb{\overline{C}}$ is complex plane with an additional element
(treated as the infinite point). The extended complex plane $\mathbb{\overline{C}}$ is identified
with a complex projective line (the one-dimensional projective space over the complex field, sometimes denoted by $\mathbb{C}P^1$).
Each point of $\mathbb{\overline{C}}$ is represented by a pair of complex homogeneous coordinates (not
both equal to zero), and two pairs of homogeneous coordinates represent the same
point in $\mathbb{\overline{C}}$ iff they are proportional by a non-zero complex factor.\<close>

theory Homogeneous_Coordinates
imports More_Complex Matrices
begin

(* ---------------------------------------------------------------------------- *)
subsection \<open>Definition of homogeneous coordinates\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Two complex vectors are equivalent iff they are proportional.\<close>

definition complex_cvec_eq :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> bool" (infix "\<approx>\<^sub>v" 50)  where
  [simp]: "z1 \<approx>\<^sub>v z2 \<longleftrightarrow> (\<exists> k. k \<noteq> (0::complex) \<and> z2 = k *\<^sub>s\<^sub>v z1)"

lemma complex_cvec_eq_mix:
  assumes "(z1, z2) \<noteq> vec_zero" and "(w1, w2) \<noteq> vec_zero"
  shows "(z1, z2) \<approx>\<^sub>v (w1, w2) \<longleftrightarrow> z1*w2 = z2*w1"
proof safe
  assume "(z1, z2) \<approx>\<^sub>v (w1, w2)"
  thus "z1 * w2 = z2 * w1"
    by auto
next
  assume *: "z1 * w2 = z2 * w1"
  show "(z1, z2) \<approx>\<^sub>v (w1, w2)"
  proof (cases "z2 = 0")
    case True
    thus ?thesis
      using * assms
      by auto
  next
    case False
    hence "w1 = (w2/z2)*z1 \<and> w2 = (w2/z2)*z2" "w2/z2 \<noteq> 0"
      using * assms
      by (auto simp add: field_simps)
    thus "(z1, z2) \<approx>\<^sub>v (w1, w2)"
      by (metis complex_cvec_eq_def mult_sv.simps)
  qed
qed

lemma complex_eq_cvec_reflp [simp]:
  shows "reflp (\<approx>\<^sub>v)"
  unfolding reflp_def complex_cvec_eq_def
  by safe (rule_tac x="1" in exI, simp)

lemma complex_eq_cvec_symp [simp]:
  shows "symp (\<approx>\<^sub>v)"
  unfolding symp_def complex_cvec_eq_def
  by safe (rule_tac x="1/k" in exI, simp)

lemma complex_eq_cvec_transp [simp]:
  shows "transp (\<approx>\<^sub>v)"
  unfolding transp_def complex_cvec_eq_def
  by safe (rule_tac x="k*ka" in exI, simp)

lemma complex_eq_cvec_equivp [simp]:
  shows "equivp (\<approx>\<^sub>v)"
  by (auto intro: equivpI)

text \<open>Non-zero pairs of complex numbers (also treated as non-zero complex vectors)\<close>

typedef complex_homo_coords = "{v::complex_vec. v \<noteq> vec_zero}"
  by (rule_tac x="(1, 0)" in exI, simp)

setup_lifting type_definition_complex_homo_coords

lift_definition complex_homo_coords_eq :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> bool" (infix "\<approx>" 50) is complex_cvec_eq
  done

lemma complex_homo_coords_eq_reflp [simp]:
  shows "reflp (\<approx>)"
  using complex_eq_cvec_reflp
  unfolding reflp_def
  by transfer blast

lemma complex_homo_coords_eq_symp [simp]:
  shows "symp (\<approx>)"
  using complex_eq_cvec_symp
  unfolding symp_def
  by transfer blast

lemma complex_homo_coords_eq_transp [simp]:
  shows "transp (\<approx>)"
  using complex_eq_cvec_transp
  unfolding transp_def
  by transfer blast

lemma complex_homo_coords_eq_equivp:
  shows "equivp (\<approx>)"
  by (auto intro: equivpI)

lemma complex_homo_coords_eq_refl [simp]:
  shows "z \<approx> z"
  using complex_homo_coords_eq_reflp
  unfolding reflp_def refl_on_def
  by blast

lemma complex_homo_coords_eq_sym:
  assumes "z1 \<approx> z2"
  shows "z2 \<approx> z1"
  using assms complex_homo_coords_eq_symp
  unfolding symp_def
  by blast

lemma complex_homo_coords_eq_trans:
  assumes "z1 \<approx> z2" and "z2 \<approx> z3"
  shows "z1 \<approx> z3"
  using assms complex_homo_coords_eq_transp
  unfolding transp_def
  by blast

text \<open>Quotient type of homogeneous coordinates\<close>
quotient_type
  complex_homo = complex_homo_coords / "complex_homo_coords_eq"
  by (rule complex_homo_coords_eq_equivp)

(* ---------------------------------------------------------------------------- *)
subsection \<open>Some characteristic points in $\mathbb{C}P^1$\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Infinite point\<close>
definition inf_cvec :: "complex_vec" ("\<infinity>\<^sub>v") where
  [simp]: "inf_cvec = (1, 0)"
lift_definition inf_hcoords :: "complex_homo_coords"  ("\<infinity>\<^sub>h\<^sub>c") is inf_cvec
  by simp
lift_definition inf :: "complex_homo"  ("\<infinity>\<^sub>h")  is inf_hcoords
done

lemma inf_cvec_z2_zero_iff:
  assumes "(z1, z2) \<noteq> vec_zero"
  shows "(z1, z2) \<approx>\<^sub>v \<infinity>\<^sub>v \<longleftrightarrow> z2 = 0"
  using assms
  by auto

text \<open>Zero\<close>
definition zero_cvec :: "complex_vec" ("0\<^sub>v") where
  [simp]: "zero_cvec = (0, 1)"
lift_definition zero_hcoords :: "complex_homo_coords" ("0\<^sub>h\<^sub>c") is zero_cvec
  by simp
lift_definition zero :: "complex_homo" ("0\<^sub>h") is zero_hcoords
  done

lemma zero_cvec_z1_zero_iff:
  assumes "(z1, z2) \<noteq> vec_zero"
  shows "(z1, z2) \<approx>\<^sub>v 0\<^sub>v \<longleftrightarrow> z1 = 0"
  using assms
  by auto

text \<open>One\<close>
definition one_cvec :: "complex_vec" ("1\<^sub>v")where
  [simp]: "one_cvec = (1, 1)"
lift_definition one_hcoords :: "complex_homo_coords" ("1\<^sub>h\<^sub>c") is one_cvec
  by simp
lift_definition one :: "complex_homo" ("1\<^sub>h") is one_hcoords
  done

text \<open>Imaginary unit\<close>
definition ii_cvec :: "complex_vec" ("ii\<^sub>v") where
  [simp]: "ii_cvec = (\<i>, 1)"
lift_definition ii_hcoords :: "complex_homo_coords" ("ii\<^sub>h\<^sub>c") is ii_cvec
  by simp
lift_definition ii :: "complex_homo" ("ii\<^sub>h") is ii_hcoords
  done

lemma ex_3_different_points:
  fixes z::complex_homo
  shows "\<exists> z1 z2. z \<noteq> z1 \<and> z1 \<noteq> z2 \<and> z \<noteq> z2"
proof (cases "z \<noteq> 0\<^sub>h \<and> z \<noteq> 1\<^sub>h")
  case True
  thus ?thesis
    by (rule_tac x="0\<^sub>h" in exI, rule_tac x="1\<^sub>h" in exI, auto)
next
  case False
  hence "z = 0\<^sub>h \<or> z = 1\<^sub>h"
    by simp
  thus ?thesis
  proof
    assume "z = 0\<^sub>h"
    thus ?thesis
      by (rule_tac x="\<infinity>\<^sub>h" in exI, rule_tac x="1\<^sub>h" in exI, auto)
  next
    assume "z = 1\<^sub>h"
    thus ?thesis
      by (rule_tac x="\<infinity>\<^sub>h" in exI, rule_tac x="0\<^sub>h" in exI, auto)
  qed
qed

(* ---------------------------------------------------------------------------- *)
subsection \<open>Connection to ordinary complex plane $\mathbb{C}$\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Conversion from complex\<close>

definition of_complex_cvec :: "complex \<Rightarrow> complex_vec" where
  [simp]: "of_complex_cvec z = (z, 1)"
lift_definition of_complex_hcoords :: "complex \<Rightarrow> complex_homo_coords" is of_complex_cvec
  by simp
lift_definition of_complex :: "complex \<Rightarrow> complex_homo" is of_complex_hcoords
  done

lemma of_complex_inj:
  assumes "of_complex x = of_complex y"
  shows "x = y"
  using assms
  by (transfer, transfer, simp)

lemma of_complex_image_inj:
  assumes "of_complex ` A = of_complex ` B"
  shows "A = B"
  using assms
  using of_complex_inj
  by auto

lemma of_complex_not_inf [simp]:
  shows "of_complex x \<noteq> \<infinity>\<^sub>h"
  by (transfer, transfer, simp)

lemma inf_not_of_complex [simp]:
  shows "\<infinity>\<^sub>h \<noteq> of_complex x"
  by (transfer, transfer, simp)

lemma inf_or_of_complex:
  shows "z = \<infinity>\<^sub>h \<or> (\<exists> x. z = of_complex x)"
proof (transfer, transfer)
  fix z :: complex_vec
  obtain z1 z2 where *: "z = (z1, z2)"
    by (cases z) auto
  assume "z \<noteq> vec_zero"
  thus "z \<approx>\<^sub>v \<infinity>\<^sub>v \<or> (\<exists>x. z \<approx>\<^sub>v of_complex_cvec x)"
    using *
    by (cases "z2 = 0", auto)
qed

lemma of_complex_zero [simp]:
  shows "of_complex 0 = 0\<^sub>h"
  by (transfer, transfer, simp)

lemma of_complex_one [simp]:
  shows "of_complex 1 = 1\<^sub>h"
  by (transfer, transfer, simp)

lemma of_complex_ii [simp]:
  shows "of_complex \<i> = ii\<^sub>h"
  by (transfer, transfer, simp)

lemma of_complex_zero_iff [simp]:
  shows "of_complex x = 0\<^sub>h \<longleftrightarrow> x = 0"
  by (subst of_complex_zero[symmetric]) (auto simp add: of_complex_inj)

lemma of_complex_one_iff [simp]:
  shows "of_complex x = 1\<^sub>h \<longleftrightarrow> x = 1"
  by (subst of_complex_one[symmetric]) (auto simp add: of_complex_inj)

lemma of_complex_ii_iff [simp]:
  shows "of_complex x = ii\<^sub>h \<longleftrightarrow> x = \<i>"
  by (subst of_complex_ii[symmetric]) (auto simp add: of_complex_inj)

text \<open>Conversion to complex\<close>

definition to_complex_cvec :: "complex_vec \<Rightarrow> complex" where
  [simp]: "to_complex_cvec z = (let (z1, z2) = z in z1/z2)"
lift_definition to_complex_homo_coords :: "complex_homo_coords \<Rightarrow> complex" is to_complex_cvec
  done
lift_definition to_complex :: "complex_homo \<Rightarrow> complex" is to_complex_homo_coords
proof-
  fix z w
  assume "z \<approx> w"
  thus "to_complex_homo_coords z = to_complex_homo_coords w"
    by transfer auto
qed

lemma to_complex_of_complex [simp]:
  shows "to_complex (of_complex z) = z"
  by (transfer, transfer, simp)

lemma of_complex_to_complex [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "(of_complex (to_complex z)) = z"
  using assms
proof (transfer, transfer)
  fix z :: complex_vec
  obtain z1 z2 where *: "z = (z1, z2)"
    by (cases z, auto)
  assume "z \<noteq> vec_zero" "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v"
  hence "z2 \<noteq> 0"
    using *
    by (simp, erule_tac x="1/z1" in allE, auto)
  thus "(of_complex_cvec (to_complex_cvec z)) \<approx>\<^sub>v z"
    using *
    by simp
qed

lemma to_complex_zero_zero [simp]:
  shows "to_complex 0\<^sub>h = 0"
  by (metis of_complex_zero to_complex_of_complex)

lemma to_complex_one_one [simp]:
  shows "to_complex 1\<^sub>h = 1"
  by (metis of_complex_one to_complex_of_complex)

lemma to_complex_img_one [simp]:
  shows "to_complex ii\<^sub>h = \<i>"
  by (metis of_complex_ii to_complex_of_complex)

(* ---------------------------------------------------------------------------- *)
subsection \<open>Arithmetic operations\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Due to the requirement of HOL that all functions are total, we could not define the function
only for the well-defined cases, and in the lifting proofs we must also handle the ill-defined
cases. For example, $\infty_h +_h \infty_h$ is ill-defined, but we must define it, so we define it
arbitrarily to be $\infty_h$.\<close>

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Addition\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>$\infty_h\ +_h\ \infty_h$ is ill-defined. Since functions must be total, for formal reasons we
define it arbitrarily to be $\infty_h$.\<close>

definition add_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "+\<^sub>v" 60) where
  [simp]: "add_cvec z w = (let (z1, z2) = z; (w1, w2) = w
                                in if z2 \<noteq> 0 \<or> w2 \<noteq> 0 then
                                      (z1*w2 + w1*z2, z2*w2)
                                   else
                                      (1, 0))"
lift_definition add_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" (infixl "+\<^sub>h\<^sub>c" 60) is add_cvec
  by (auto split: if_split_asm)

lift_definition add :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl "+\<^sub>h" 60) is add_hcoords
proof transfer
  fix z w z' w' :: complex_vec
  obtain z1 z2 w1 w2 z'1 z'2 w'1 w'2 where
    *: "z = (z1, z2)" "w = (w1, w2)" "z' = (z'1, z'2)" "w' = (w'1, w'2)"
    by (cases z, auto, cases w, auto, cases z', auto, cases w', auto)
  assume **:
         "z \<noteq> vec_zero" "w \<noteq> vec_zero" "z \<approx>\<^sub>v z'"
         "z' \<noteq> vec_zero" "w' \<noteq> vec_zero" "w \<approx>\<^sub>v w'"
  show "z +\<^sub>v w \<approx>\<^sub>v z' +\<^sub>v w'"
  proof (cases "z2 \<noteq> 0 \<or> w2 \<noteq> 0")
    case True
    hence "z'2 \<noteq> 0 \<or> w'2 \<noteq> 0"
      using * **
      by auto
    show ?thesis
      using \<open>z2 \<noteq> 0 \<or> w2 \<noteq> 0\<close> \<open>z'2 \<noteq> 0 \<or> w'2 \<noteq> 0\<close>
      using * **
      by simp ((erule exE)+, rule_tac x="k*ka" in exI, simp add: field_simps)
  next
    case False
    hence "z'2 = 0 \<or> w'2 = 0"
      using * **
      by auto
    show ?thesis
      using \<open>\<not> (z2 \<noteq> 0 \<or> w2 \<noteq> 0)\<close> \<open>z'2 = 0 \<or> w'2 = 0\<close>
      using * **
      by auto
  qed
qed

lemma add_commute:
  shows "z +\<^sub>h w = w +\<^sub>h z"
  apply (transfer, transfer)
  unfolding complex_cvec_eq_def
  by (rule_tac x="1" in exI, auto split: if_split_asm)

lemma add_zero_right [simp]:
  shows "z +\<^sub>h 0\<^sub>h = z"
  by (transfer, transfer, force)

lemma add_zero_left [simp]:
  shows "0\<^sub>h +\<^sub>h z = z"
  by (subst add_commute) simp

lemma of_complex_add_of_complex [simp]:
  shows "(of_complex x) +\<^sub>h (of_complex y) = of_complex (x + y)"
  by (transfer, transfer, simp)

lemma of_complex_add_inf [simp]:
  shows "(of_complex x) +\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
  by (transfer, transfer, simp)

lemma inf_add_of_complex [simp]:
  shows "\<infinity>\<^sub>h +\<^sub>h (of_complex x) = \<infinity>\<^sub>h"
  by (subst add_commute) simp

lemma inf_add_right:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "z +\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
  using assms
  using inf_or_of_complex[of z]
  by auto

lemma inf_add_left:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "\<infinity>\<^sub>h +\<^sub>h z = \<infinity>\<^sub>h"
  using assms
  by (subst add_commute) (rule inf_add_right, simp)

text \<open>This is ill-defined, but holds by our definition\<close>
lemma inf_add_inf:
  shows "\<infinity>\<^sub>h +\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
  by (transfer, transfer, simp)

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Unary minus\<close>
(* ---------------------------------------------------------------------------- *)

definition uminus_cvec :: "complex_vec \<Rightarrow> complex_vec" ("~\<^sub>v") where
  [simp]: "~\<^sub>v z = (let (z1, z2) = z in (-z1, z2))"
lift_definition uminus_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords" ("~\<^sub>h\<^sub>c") is uminus_cvec
  by auto
lift_definition uminus :: "complex_homo \<Rightarrow> complex_homo" ("~\<^sub>h") is uminus_hcoords
  by transfer auto

lemma uminus_of_complex [simp]:
  shows "~\<^sub>h (of_complex z) = of_complex (-z)"
  by (transfer, transfer, simp)

lemma uminus_zero [simp]:
  shows "~\<^sub>h 0\<^sub>h = 0\<^sub>h"
  by (transfer, transfer, simp)

lemma uminus_inf [simp]:
  shows "~\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
  apply (transfer, transfer)
  unfolding complex_cvec_eq_def
  by (rule_tac x="-1" in exI, simp)

lemma uminus_inf_iff:
  shows "~\<^sub>h z = \<infinity>\<^sub>h \<longleftrightarrow> z = \<infinity>\<^sub>h"
  apply (transfer, transfer)
  by auto (rule_tac x="-1/a" in exI, auto)

lemma uminus_id_iff:
  shows "~\<^sub>h z = z \<longleftrightarrow> z = 0\<^sub>h \<or> z = \<infinity>\<^sub>h"
  apply (transfer, transfer)
  apply auto
   apply (erule_tac x="1/a" in allE, simp)
  apply (rule_tac x="-1" in exI, simp)
  done

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Subtraction\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Operation $\infty_h\ -_h\ \infty_h$ is ill-defined, but we define it arbitrarily to $0_h$. It breaks the connection between
   subtraction with addition and unary minus, but seems more intuitive.\<close>

definition sub :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl "-\<^sub>h" 60) where
  "z -\<^sub>h w = (if z = \<infinity>\<^sub>h \<and> w = \<infinity>\<^sub>h then 0\<^sub>h else z +\<^sub>h (~\<^sub>h w))"

lemma of_complex_sub_of_complex [simp]:
  shows "(of_complex x) -\<^sub>h (of_complex y) = of_complex (x - y)"
  unfolding sub_def
  by simp

lemma zero_sub_right[simp]:
  shows "z -\<^sub>h 0\<^sub>h = z"
  unfolding sub_def
  by simp

lemma zero_sub_left[simp]:
  shows "0\<^sub>h -\<^sub>h of_complex x = of_complex (-x)"
  by (subst of_complex_zero[symmetric], simp del: of_complex_zero)

lemma zero_sub_one[simp]:
  shows "0\<^sub>h -\<^sub>h 1\<^sub>h = of_complex (-1)"
  by (metis of_complex_one zero_sub_left)

lemma of_complex_sub_one [simp]:
  shows "of_complex x -\<^sub>h 1\<^sub>h = of_complex (x - 1)"
  by (metis of_complex_one of_complex_sub_of_complex)

lemma sub_eq_zero_iff:
  assumes "z \<noteq> \<infinity>\<^sub>h \<or> w \<noteq> \<infinity>\<^sub>h"
  shows "z -\<^sub>h w = 0\<^sub>h \<longleftrightarrow> z = w"
proof
  assume "z -\<^sub>h w = 0\<^sub>h"
  thus "z = w"
    using assms
    unfolding sub_def
  proof (transfer, transfer)
    fix z w :: complex_vec
    obtain z1 z2 w1 w2 where *: "z = (z1, z2)" "w = (w1, w2)"
      by (cases z, auto, cases w, auto)
    assume "z \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v \<or> \<not> w \<approx>\<^sub>v \<infinity>\<^sub>v" and
           **: "(if z \<approx>\<^sub>v \<infinity>\<^sub>v \<and> w \<approx>\<^sub>v \<infinity>\<^sub>v then 0\<^sub>v else z +\<^sub>v ~\<^sub>v w) \<approx>\<^sub>v 0\<^sub>v"
    have "z2 \<noteq> 0 \<or> w2 \<noteq> 0"
      using * \<open>\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v \<or> \<not> w \<approx>\<^sub>v \<infinity>\<^sub>v\<close> \<open>z \<noteq> vec_zero\<close> \<open>w \<noteq> vec_zero\<close>
      apply auto
       apply (erule_tac x="1/z1" in allE, simp)
      apply (erule_tac x="1/w1" in allE, simp)
      done

    thus "z \<approx>\<^sub>v w"
      using * **
      by simp (rule_tac x="w2/z2" in exI, auto simp add: field_simps)
  qed
next
  assume "z = w"
  thus "z -\<^sub>h w = 0\<^sub>h"
    using sub_eq_zero[of z] assms
    by auto
qed

lemma inf_sub_left [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "\<infinity>\<^sub>h -\<^sub>h z = \<infinity>\<^sub>h"
  using assms
  using uminus_inf_iff
  using inf_or_of_complex
  unfolding sub_def
  by force

lemma inf_sub_right [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "z -\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
  using assms
  using inf_or_of_complex
  unfolding sub_def
  by force

text \<open>This is ill-defined, but holds by our definition\<close>
lemma inf_sub_inf:
  shows "\<infinity>\<^sub>h -\<^sub>h \<infinity>\<^sub>h = 0\<^sub>h"
  unfolding sub_def
  by simp

lemma sub_noteq_inf:
  assumes "z \<noteq> \<infinity>\<^sub>h" and "w \<noteq> \<infinity>\<^sub>h"
  shows "z -\<^sub>h w \<noteq> \<infinity>\<^sub>h"
  using assms
  using inf_or_of_complex[of z]
  using inf_or_of_complex[of w]
  using inf_or_of_complex[of "z -\<^sub>h w"]
  using of_complex_sub_of_complex
  by auto

lemma sub_eq_inf:
  assumes "z -\<^sub>h w = \<infinity>\<^sub>h"
  shows "z = \<infinity>\<^sub>h \<or> w = \<infinity>\<^sub>h"
  using assms sub_noteq_inf
  by blast

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Multiplication\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Operations $0_h \cdot_h \infty_h$ and $\infty_h \cdot_h 0_h$ are ill defined. Since all
functions must be total, for formal reasons we define it arbitrarily to be $1_h$.\<close>

definition mult_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec" (infixl "*\<^sub>v" 70) where
 [simp]: "z *\<^sub>v w = (let (z1, z2) = z; (w1, w2) = w
                     in if (z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0) then
                          (1, 1)
                        else
                          (z1*w1, z2*w2))"
lift_definition mult_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" (infixl "*\<^sub>h\<^sub>c" 70) is mult_cvec
  by (auto split: if_split_asm)

lift_definition mult :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl "*\<^sub>h" 70) is mult_hcoords
proof transfer
  fix z w z' w' :: complex_vec
  obtain z1 z2 w1 w2 z'1 z'2 w'1 w'2 where
    *: "z = (z1, z2)" "w = (w1, w2)" "z' = (z'1, z'2)" "w' = (w'1, w'2)"
    by (cases z, auto, cases w, auto, cases z', auto, cases w', auto)
  assume **:
         "z \<noteq> vec_zero" "w \<noteq> vec_zero" "z \<approx>\<^sub>v z'"
         "z' \<noteq> vec_zero" "w' \<noteq> vec_zero" "w \<approx>\<^sub>v w'"
  show "z *\<^sub>v w \<approx>\<^sub>v z' *\<^sub>v w'"
  proof (cases "(z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0)")
    case True
    hence "(z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0)"
      using * **
      by auto
    show ?thesis
      using \<open>(z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0)\<close> \<open>(z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0)\<close>
      using * **
      by simp
  next
    case False
    hence "\<not>((z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0))"
      using * **
      by auto
    hence ***: "z *\<^sub>v w = (z1*w1, z2*w2)" "z' *\<^sub>v w' = (z'1*w'1, z'2*w'2)"
      using \<open>\<not>((z1 = 0 \<and> w2 = 0) \<or> (w1 = 0 \<and> z2 = 0))\<close> \<open>\<not>((z'1 = 0 \<and> w'2 = 0) \<or> (w'1 = 0 \<and> z'2 = 0))\<close>
      using *
      by auto
    show ?thesis
      apply (subst ***)+
      using * **
      by simp ((erule exE)+, rule_tac x="k*ka" in exI, simp)
  qed
qed

lemma of_complex_mult_of_complex [simp]:
  shows "(of_complex z1) *\<^sub>h (of_complex z2) = of_complex (z1 * z2)"
  by (transfer, transfer, simp)

lemma mult_commute:
  shows "z1 *\<^sub>h z2 = z2 *\<^sub>h z1"
  apply (transfer, transfer)
  unfolding complex_cvec_eq_def
  by (rule_tac x="1" in exI, auto split: if_split_asm)

lemma mult_zero_left [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "0\<^sub>h *\<^sub>h z = 0\<^sub>h"
  using assms
proof (transfer, transfer)
  fix z :: complex_vec
  obtain z1 z2 where *: "z = (z1, z2)"
    by (cases z, auto)
  assume "z \<noteq> vec_zero" "\<not> (z \<approx>\<^sub>v \<infinity>\<^sub>v)"
  hence "z2 \<noteq> 0"
    using *
    by force
  thus "0\<^sub>v *\<^sub>v z \<approx>\<^sub>v 0\<^sub>v"
    using *
    by simp
qed

lemma mult_zero_right [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "z *\<^sub>h 0\<^sub>h = 0\<^sub>h"
  using mult_zero_left[OF assms]
  by (simp add: mult_commute)

lemma mult_inf_right [simp]:
  assumes "z \<noteq> 0\<^sub>h"
  shows "z *\<^sub>h \<infinity>\<^sub>h = \<infinity>\<^sub>h"
using assms
proof (transfer, transfer)
  fix z :: complex_vec
  obtain z1 z2 where *: "z = (z1, z2)"
    by (cases z, auto)
  assume "z \<noteq> vec_zero" "\<not> (z \<approx>\<^sub>v 0\<^sub>v)"
  hence "z1 \<noteq> 0"
    using *
    by force
  thus "z *\<^sub>v \<infinity>\<^sub>v \<approx>\<^sub>v \<infinity>\<^sub>v"
    using *
    by simp
qed

lemma mult_inf_left [simp]:
  assumes "z \<noteq> 0\<^sub>h"
  shows "\<infinity>\<^sub>h *\<^sub>h z = \<infinity>\<^sub>h"
  using mult_inf_right[OF assms]
  by (simp add: mult_commute)

lemma mult_one_left [simp]:
  shows "1\<^sub>h *\<^sub>h z = z"
  by (transfer, transfer, force)

lemma mult_one_right [simp]:
  shows "z *\<^sub>h 1\<^sub>h = z"
  using mult_one_left[of z]
  by (simp add: mult_commute)

text \<open>This is ill-defined, but holds by our definition\<close>
lemma inf_mult_zero:
  shows "\<infinity>\<^sub>h *\<^sub>h 0\<^sub>h = 1\<^sub>h"
  by (transfer, transfer, simp)
lemma zero_mult_inf:
  shows "0\<^sub>h *\<^sub>h \<infinity>\<^sub>h = 1\<^sub>h"
  by (transfer, transfer, simp)

lemma mult_eq_inf:
  assumes "z *\<^sub>h w = \<infinity>\<^sub>h"
  shows "z = \<infinity>\<^sub>h \<or> w = \<infinity>\<^sub>h"
  using assms
  using inf_or_of_complex[of z]
  using inf_or_of_complex[of w]
  using inf_or_of_complex[of "z *\<^sub>h w"]
  using of_complex_mult_of_complex
  by auto

subsubsection \<open>Reciprocal\<close>
definition reciprocal_cvec :: "complex_vec \<Rightarrow> complex_vec" where
  [simp]: "reciprocal_cvec z = (let (z1, z2) = z in (z2, z1))"
lift_definition reciprocal_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords" is reciprocal_cvec
  by auto

lift_definition reciprocal :: "complex_homo \<Rightarrow> complex_homo" is reciprocal_hcoords
  by transfer auto

lemma reciprocal_involution [simp]: "reciprocal (reciprocal z) = z"
  by (transfer, transfer, auto)

lemma reciprocal_zero [simp]: "reciprocal 0\<^sub>h = \<infinity>\<^sub>h"
  by (transfer, transfer, simp)

lemma reciprocal_inf [simp]: "reciprocal \<infinity>\<^sub>h = 0\<^sub>h"
  by (transfer, transfer, simp)

lemma reciprocal_one [simp]: "reciprocal 1\<^sub>h = 1\<^sub>h"
  by (transfer, transfer, simp)

lemma reciprocal_inf_iff [iff]: "reciprocal z = \<infinity>\<^sub>h \<longleftrightarrow> z = 0\<^sub>h"
  by (transfer, transfer, auto)

lemma reciprocal_zero_iff [iff]: "reciprocal z = 0\<^sub>h \<longleftrightarrow> z = \<infinity>\<^sub>h"
  by (transfer, transfer, auto)

lemma reciprocal_of_complex [simp]:
  assumes "z \<noteq> 0"
  shows "reciprocal (of_complex z) = of_complex (1 / z)"
  using assms
  by (transfer, transfer, simp)

lemma reciprocal_real:
  assumes "is_real (to_complex z)" and "z \<noteq> 0\<^sub>h" and "z \<noteq> \<infinity>\<^sub>h"
  shows "Re (to_complex (reciprocal z)) = 1 / Re (to_complex z)"
proof-
  obtain c where "z = of_complex c" "c \<noteq> 0" "is_real c"
    using assms inf_or_of_complex[of z]
    by auto
  thus ?thesis
    by (simp add: Re_divide_real)
qed

lemma reciprocal_id_iff:
  shows "reciprocal z = z \<longleftrightarrow> z = of_complex 1 \<or> z = of_complex (-1)"
proof (cases "z = 0\<^sub>h")
  case True
  thus ?thesis
    by (metis inf_not_of_complex of_complex_zero_iff reciprocal_inf_iff zero_neq_neg_one zero_neq_one)
next
  case False
  thus ?thesis
    using inf_or_of_complex[of z]
    by (smt complex_sqrt_1 of_complex_zero_iff reciprocal_inf_iff reciprocal_of_complex to_complex_of_complex)
qed

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Division\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Operations $0_h :_h 0_h$ and $\infty_h :_h \infty_h$ are ill-defined. For formal reasons they
are defined to be $1_h$ (by the definition of multiplication).\<close>

definition divide :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" (infixl ":\<^sub>h" 70) where
  "x :\<^sub>h y = x *\<^sub>h (reciprocal y)"

lemma divide_zero_right [simp]:
  assumes "z \<noteq> 0\<^sub>h"
  shows "z :\<^sub>h 0\<^sub>h = \<infinity>\<^sub>h"
  using assms
  unfolding divide_def
  by simp

lemma divide_zero_left [simp]:
  assumes "z \<noteq> 0\<^sub>h"
  shows "0\<^sub>h :\<^sub>h z = 0\<^sub>h"
  using assms
  unfolding divide_def
  by simp

lemma divide_inf_right [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "z :\<^sub>h \<infinity>\<^sub>h = 0\<^sub>h"
  using assms
  unfolding divide_def
  by simp

lemma divide_inf_left [simp]:
  assumes "z \<noteq> \<infinity>\<^sub>h"
  shows "\<infinity>\<^sub>h :\<^sub>h z = \<infinity>\<^sub>h"
  using assms reciprocal_zero_iff[of z] mult_inf_left
  unfolding divide_def
  by simp

lemma divide_eq_inf:
  assumes "z :\<^sub>h w = \<infinity>\<^sub>h"
  shows "z = \<infinity>\<^sub>h \<or> w = 0\<^sub>h"
  using assms
  using reciprocal_inf_iff[of w] mult_eq_inf
  unfolding divide_def
  by auto

lemma inf_divide_zero [simp]:
  shows "\<infinity>\<^sub>h :\<^sub>h 0\<^sub>h = \<infinity>\<^sub>h"
  unfolding divide_def
  by (transfer, simp)

lemma zero_divide_inf [simp]:
  shows "0\<^sub>h :\<^sub>h \<infinity>\<^sub>h =  0\<^sub>h"
  unfolding divide_def
  by (transfer, simp)

lemma divide_one_right [simp]:
  shows "z :\<^sub>h 1\<^sub>h = z"
  unfolding divide_def
  by simp

lemma of_complex_divide_of_complex [simp]:
  assumes "z2 \<noteq> 0"
  shows "(of_complex z1) :\<^sub>h (of_complex z2) = of_complex (z1 / z2)"
using assms
  unfolding divide_def
  apply transfer
  apply transfer
  by (simp, rule_tac x="1/z2" in exI, simp)

lemma one_div_of_complex [simp]:
  assumes "x \<noteq> 0"
  shows "1\<^sub>h :\<^sub>h of_complex x = of_complex (1 / x)"
  using assms
  unfolding divide_def
  by simp

text \<open> This is ill-defined, but holds by our definition\<close>
lemma inf_divide_inf:
  shows "\<infinity>\<^sub>h :\<^sub>h \<infinity>\<^sub>h = 1\<^sub>h"
  unfolding divide_def
  by (simp add: inf_mult_zero)

text \<open> This is ill-defined, but holds by our definition\<close>
lemma zero_divide_zero:
  shows "0\<^sub>h :\<^sub>h 0\<^sub>h = 1\<^sub>h"
  unfolding divide_def
  by (simp add: zero_mult_inf)

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Conjugate\<close>
(* ---------------------------------------------------------------------------- *)

definition conjugate_cvec :: "complex_vec \<Rightarrow> complex_vec" where
  [simp]: "conjugate_cvec z = vec_cnj z"
lift_definition conjugate_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords" is conjugate_cvec
  by (auto simp add: vec_cnj_def)
lift_definition conjugate :: "complex_homo \<Rightarrow> complex_homo" is conjugate_hcoords
  by transfer (auto simp add: vec_cnj_def)

lemma conjugate_involution [simp]:
  shows "conjugate (conjugate z) = z"
  by (transfer, transfer, auto)

lemma conjugate_conjugate_comp [simp]:
  shows "conjugate \<circ> conjugate = id"
  by (rule ext, simp)

lemma inv_conjugate [simp]:
  shows "inv conjugate = conjugate"
  using inv_unique_comp[of conjugate conjugate]
  by simp

lemma conjugate_of_complex [simp]:
  shows "conjugate (of_complex z) = of_complex (cnj z)"
  by (transfer, transfer, simp add: vec_cnj_def)

lemma conjugate_inf [simp]:
  shows "conjugate \<infinity>\<^sub>h = \<infinity>\<^sub>h"
  by (transfer, transfer, simp add: vec_cnj_def)

lemma conjugate_zero [simp]:
  shows "conjugate 0\<^sub>h = 0\<^sub>h"
  by (transfer, transfer, simp add: vec_cnj_def)

lemma conjugate_one [simp]:
  shows "conjugate 1\<^sub>h = 1\<^sub>h"
  by (transfer, transfer, simp add: vec_cnj_def)

lemma conjugate_inj:
  assumes "conjugate x = conjugate y"
  shows "x = y"
  using assms
  using conjugate_involution[of x] conjugate_involution[of y]
  by metis

lemma bij_conjugate [simp]:
  shows "bij conjugate"
  unfolding bij_def inj_on_def
proof auto
  fix x y
  assume "conjugate x = conjugate y"
  thus "x = y"
   by (simp add: conjugate_inj)
next
  fix x
  show "x \<in> range conjugate"
    by (metis conjugate_involution range_eqI)
qed

lemma conjugate_id_iff:
  shows "conjugate a = a \<longleftrightarrow> is_real (to_complex a) \<or> a = \<infinity>\<^sub>h"
  using inf_or_of_complex[of a]
  by (metis conjugate_inf conjugate_of_complex eq_cnj_iff_real to_complex_of_complex)

subsubsection \<open>Inversion\<close>

text \<open>Geometric inversion wrt. the unit circle\<close>

definition inversion where
  "inversion = conjugate \<circ> reciprocal"

lemma inversion_sym:
  shows "inversion = reciprocal \<circ> conjugate"
  unfolding inversion_def
  apply (rule ext, simp)
  apply transfer
  apply transfer
  apply (auto simp add: vec_cnj_def)
  using one_neq_zero
  by blast+

lemma inversion_involution [simp]:
  shows "inversion (inversion z) = z"
proof-
  have *: "conjugate \<circ> reciprocal = reciprocal \<circ> conjugate"
    using inversion_sym
    by (simp add: inversion_def)
  show ?thesis
    unfolding inversion_def
    by (subst *) simp
qed

lemma inversion_inversion_id [simp]:
  shows "inversion \<circ> inversion = id"
  by (rule ext, simp)

lemma inversion_zero [simp]:
  shows "inversion 0\<^sub>h = \<infinity>\<^sub>h"
  by (simp add: inversion_def)

lemma inversion_infty [simp]:
  shows "inversion \<infinity>\<^sub>h = 0\<^sub>h"
  by (simp add: inversion_def)

lemma inversion_of_complex [simp]:
  assumes "z \<noteq> 0"
  shows "inversion (of_complex z) = of_complex (1 / cnj z)"
  using assms
  by (simp add: inversion_def)

lemma is_real_inversion:
  assumes "is_real x" and "x \<noteq> 0"
  shows "is_real (to_complex (inversion (of_complex x)))"
  using assms eq_cnj_iff_real[of x]
  by simp

lemma inversion_id_iff:
  shows "a = inversion a \<longleftrightarrow> a \<noteq> \<infinity>\<^sub>h \<and> (to_complex a) * cnj (to_complex a) = 1" (is "?lhs = ?rhs")
proof
  assume "a = inversion a"
  thus ?rhs
    unfolding inversion_def
    using inf_or_of_complex[of a]
    by (metis (full_types) comp_apply complex_cnj_cancel_iff complex_cnj_zero inversion_def inversion_infty inversion_of_complex inversion_sym nonzero_eq_divide_eq of_complex_zero reciprocal_zero to_complex_of_complex zero_one_infty_not_equal(5))
next
  assume ?rhs
  thus ?lhs
    using inf_or_of_complex[of a]
    by (metis inversion_of_complex mult_not_zero nonzero_mult_div_cancel_right one_neq_zero to_complex_of_complex)
qed

(* ---------------------------------------------------------------------------- *)
subsection \<open>Ratio and cross-ratio\<close>
(* ---------------------------------------------------------------------------- *)

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Ratio\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Ratio of points $z$, $v$ and $w$ is usually defined as
$\frac{z-v}{z-w}$. Our definition introduces it in homogeneous
coordinates. It is well-defined if $z_1 \neq z_2 \vee z_1 \neq z_3$ and $z_1 \neq \infty_h$ and
$z_2 \neq \infty_h \vee z_3 \neq \infty_h$\<close>

definition ratio :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" where
  "ratio za zb zc = (za -\<^sub>h zb) :\<^sub>h (za -\<^sub>h zc)"

text \<open>This is ill-defined, but holds by our definition\<close>
lemma
  assumes "zb \<noteq> \<infinity>\<^sub>h" and "zc \<noteq> \<infinity>\<^sub>h"
  shows "ratio \<infinity>\<^sub>h zb zc = 1\<^sub>h"
  using assms
  using inf_sub_left[OF assms(1)]
  using inf_sub_left[OF assms(2)]
  unfolding ratio_def
  by (simp add: inf_divide_inf)

lemma
  assumes "za \<noteq> \<infinity>\<^sub>h" and "zc \<noteq> \<infinity>\<^sub>h"
  shows "ratio za \<infinity>\<^sub>h zc = \<infinity>\<^sub>h"
  using assms
  unfolding ratio_def
  using inf_sub_right[OF assms(1)]
  using sub_noteq_inf[OF assms]
  using divide_inf_left
  by simp

lemma
  assumes "za \<noteq> \<infinity>\<^sub>h" and "zb \<noteq> \<infinity>\<^sub>h"
  shows "ratio za zb \<infinity>\<^sub>h = 0\<^sub>h"
  unfolding ratio_def
  using sub_noteq_inf[OF assms]
  using inf_sub_right[OF assms(1)]
  using divide_inf_right
  by simp

lemma
  assumes "z1 \<noteq> z2" and "z1 \<noteq> \<infinity>\<^sub>h"
  shows "ratio z1 z2 z1 = \<infinity>\<^sub>h"
  using assms
  unfolding ratio_def
  using divide_zero_right[of "z1 -\<^sub>h z2"]
  using sub_eq_zero_iff[of z1 z2]
  by simp

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Cross-ratio\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>The cross-ratio is defined over 4 points $(z, u, v, w)$, usually as
$\frac{(z-u)(v-w)}{(z-w)(v-u)}$. We define it using homogeneous coordinates. Cross ratio is
ill-defined when $z = u \vee v = w$ and $z = w$ and $v = u$ i.e. when 3 points are equal. Since
function must be total, in that case we define it arbitrarily to 1.\<close>

definition cross_ratio_cvec :: "complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec \<Rightarrow> complex_vec" where
  [simp]: "cross_ratio_cvec z u v w =
     (let (z', z'') = z;
          (u', u'') = u;
          (v', v'') = v;
          (w', w'') = w;
          n1 = z'*u'' - u'*z'';
          n2 = v'*w'' - w'*v'';
          d1 = z'*w'' - w'*z'';
          d2 = v'*u'' - u'*v''
       in
         if n1 * n2 \<noteq> 0 \<or> d1 * d2 \<noteq> 0 then
              (n1 * n2, d1 * d2)
         else
              (1, 1))"

lift_definition cross_ratio_hcoords :: "complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords \<Rightarrow> complex_homo_coords" is cross_ratio_cvec
  by (auto split: if_split_asm)

lift_definition cross_ratio :: "complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo \<Rightarrow> complex_homo" is cross_ratio_hcoords
proof transfer
  fix z u v w z' u' v' w' :: complex_vec
  obtain z1 z2 u1 u2 v1 v2 w1 w2 z'1 z'2 u'1 u'2 v'1 v'2 w'1 w'2
    where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
             "z' = (z'1, z'2)" "u' = (u'1, u'2)" "v' = (v'1, v'2)" "w' = (w'1, w'2)"
    by (cases z, auto, cases u, auto, cases v, auto, cases w, auto,
        cases z', auto, cases u', auto, cases v', auto, cases w', auto)
  let ?n1 = "z1*u2 - u1*z2"
  let ?n2 = "v1*w2 - w1*v2"
  let ?d1 = "z1*w2 - w1*z2"
  let ?d2 = "v1*u2 - u1*v2"
  let ?n1' = "z'1*u'2 - u'1*z'2"
  let ?n2' = "v'1*w'2 - w'1*v'2"
  let ?d1' = "z'1*w'2 - w'1*z'2"
  let ?d2' = "v'1*u'2 - u'1*v'2"

  assume **:
         "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
         "z' \<noteq> vec_zero" "u' \<noteq> vec_zero" "v' \<noteq> vec_zero" "w' \<noteq> vec_zero"
         "z \<approx>\<^sub>v z'" "v \<approx>\<^sub>v v'" "u \<approx>\<^sub>v u'" "w \<approx>\<^sub>v w'"
  show "cross_ratio_cvec z u v w \<approx>\<^sub>v cross_ratio_cvec z' u' v' w'"
  proof (cases "?n1*?n2 \<noteq> 0 \<or> ?d1*?d2 \<noteq> 0")
    case True
    hence "?n1'*?n2' \<noteq> 0 \<or> ?d1'*?d2' \<noteq> 0"
      using * **
      by simp ((erule exE)+, simp)
    show ?thesis
      using \<open>?n1*?n2 \<noteq> 0 \<or> ?d1*?d2 \<noteq> 0\<close>
      using \<open>?n1'*?n2' \<noteq> 0 \<or> ?d1'*?d2' \<noteq> 0\<close>
      using * **
      by simp ((erule exE)+, rule_tac x="k*ka*kb*kc" in exI, simp add: field_simps)
  next
    case False
    hence "\<not> (?n1'*?n2' \<noteq> 0 \<or> ?d1'*?d2' \<noteq> 0)"
      using * **
      by simp ((erule exE)+, simp)
    show ?thesis
      using \<open>\<not> (?n1*?n2 \<noteq> 0 \<or> ?d1*?d2 \<noteq> 0)\<close>
      using \<open>\<not> (?n1'*?n2' \<noteq> 0 \<or> ?d1'*?d2' \<noteq> 0)\<close>
      using * **
      by simp blast
  qed
qed

lemma cross_ratio_01inf_id [simp]:
  shows "cross_ratio z 0\<^sub>h 1\<^sub>h \<infinity>\<^sub>h = z"
proof (transfer, transfer)
  fix z :: complex_vec
  obtain z1 z2 where *: "z = (z1, z2)"
    by (cases z, auto)
  assume "z \<noteq> vec_zero"
  thus "cross_ratio_cvec z 0\<^sub>v 1\<^sub>v \<infinity>\<^sub>v \<approx>\<^sub>v z"
    using *
    by simp (rule_tac x="-1" in exI, simp)
qed

lemma cross_ratio_0:
  assumes "u \<noteq> v" and "u \<noteq> w"
  shows "cross_ratio u u v w = 0\<^sub>h"
  using assms
proof (transfer, transfer)
  fix u v w  :: complex_vec
  obtain u1 u2 v1 v2 w1 w2
    where *: "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
    by (cases u, auto, cases v, auto, cases w, auto)
  assume "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> u \<approx>\<^sub>v v" "\<not> u \<approx>\<^sub>v w"
  thus "cross_ratio_cvec u u v w \<approx>\<^sub>v 0\<^sub>v"
    using * complex_cvec_eq_mix[of u1 u2 v1 v2] complex_cvec_eq_mix[of u1 u2 w1 w2]
    by (force simp add: mult.commute)
qed

lemma cross_ratio_1:
  assumes "u \<noteq> v" and "v \<noteq> w"
  shows "cross_ratio v u v w = 1\<^sub>h"
  using assms
proof (transfer, transfer)
  fix u v w  :: complex_vec
  obtain u1 u2 v1 v2 w1 w2
    where *: "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
    by (cases u, auto, cases v, auto, cases w, auto)
  let ?n1 = "v1*u2 - u1*v2"
  let ?n2 = "v1*w2 - w1*v2"
  assume "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> u \<approx>\<^sub>v v" "\<not> v \<approx>\<^sub>v w"
  hence "?n1 \<noteq> 0 \<and> ?n2 \<noteq> 0"
    using * complex_cvec_eq_mix[of u1 u2 v1 v2] complex_cvec_eq_mix[of v1 v2 w1 w2]
    by (auto simp add: field_simps)
  thus "cross_ratio_cvec v u v w \<approx>\<^sub>v 1\<^sub>v"
    using *
    by simp (rule_tac x="1 / (?n1 * ?n2)" in exI, simp)
qed

lemma cross_ratio_inf:
  assumes "u \<noteq> w" and "v \<noteq> w"
  shows "cross_ratio w u v w = \<infinity>\<^sub>h"
  using assms
proof (transfer, transfer)
  fix u v w  :: complex_vec
  obtain u1 u2 v1 v2 w1 w2
    where *: "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
    by (cases u, auto, cases v, auto, cases w, auto)
  let ?n1 = "w1*u2 - u1*w2"
  let ?n2 = "v1*w2 - w1*v2"
  assume "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero" "\<not> u \<approx>\<^sub>v w" "\<not> v \<approx>\<^sub>v w"
  hence "?n1 \<noteq> 0 \<and> ?n2 \<noteq> 0"
    using * complex_cvec_eq_mix[of u1 u2 w1 w2] complex_cvec_eq_mix[of v1 v2 w1 w2]
    by (auto simp add: field_simps)
  thus "cross_ratio_cvec w u v w \<approx>\<^sub>v \<infinity>\<^sub>v"
    using *
    by simp
qed

lemma cross_ratio_0inf:
  assumes "y \<noteq> 0"
  shows "cross_ratio (of_complex x) 0\<^sub>h (of_complex y) \<infinity>\<^sub>h = (of_complex (x / y))"
  using assms
  by (transfer, transfer) (simp, rule_tac x="-1/y" in exI, simp)

lemma cross_ratio_commute_13:
  shows "cross_ratio z u v w = reciprocal (cross_ratio v u z w)"
  by (transfer, transfer, case_tac z, case_tac u, case_tac v, case_tac w, simp)

lemma cross_ratio_commute_24:
  shows "cross_ratio z u v w = reciprocal (cross_ratio z w v u)"
  by (transfer, transfer, case_tac z, case_tac u, case_tac v, case_tac w, simp)

lemma cross_ratio_not_inf:
  assumes "z \<noteq> w" and "u \<noteq> v"
  shows "cross_ratio z u v w \<noteq> \<infinity>\<^sub>h"
  using assms
proof (transfer, transfer)
  fix z u v w
  assume nz: "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
  obtain z1 z2 u1 u2 v1 v2 w1 w2 where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
    by (cases z, cases u, cases v, cases w, auto)
  obtain x1 x2 where **: "cross_ratio_cvec z u v w = (x1, x2)"
    by (cases "cross_ratio_cvec z u v w", auto)
  assume "\<not> z \<approx>\<^sub>v w" "\<not> u \<approx>\<^sub>v v"
  hence "z1*w2 \<noteq> z2*w1" "u1*v2 \<noteq> u2*v1"
    using * nz complex_cvec_eq_mix
    by blast+
  hence "x2 \<noteq> 0"
    using * **
    by (auto split: if_split_asm) (simp add: field_simps)
  thus "\<not> cross_ratio_cvec z u v w \<approx>\<^sub>v \<infinity>\<^sub>v"
    using inf_cvec_z2_zero_iff * **
    by simp
qed

lemma cross_ratio_not_zero:
  assumes "z \<noteq> u" and "v \<noteq> w"
  shows "cross_ratio z u v w \<noteq> 0\<^sub>h"
  using assms
proof (transfer, transfer)
  fix z u v w
  assume nz: "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
  obtain z1 z2 u1 u2 v1 v2 w1 w2 where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
    by (cases z, cases u, cases v, cases w, auto)
  obtain x1 x2 where **: "cross_ratio_cvec z u v w = (x1, x2)"
    by (cases "cross_ratio_cvec z u v w", auto)
  assume "\<not> z \<approx>\<^sub>v u" "\<not> v \<approx>\<^sub>v w"
  hence "z1*u2 \<noteq> z2*u1" "v1*w2 \<noteq> v2*w1"
    using * nz complex_cvec_eq_mix
    by blast+
  hence "x1 \<noteq> 0"
    using * **
    by (auto split: if_split_asm)
  thus "\<not> cross_ratio_cvec z u v w \<approx>\<^sub>v 0\<^sub>v"
    using zero_cvec_z1_zero_iff * **
    by simp
qed

lemma cross_ratio_real:
  assumes "is_real z" and "is_real u" and "is_real v" and "is_real w"
  assumes "z \<noteq> u \<and> v \<noteq> w \<or> z \<noteq> w \<and> u \<noteq> v"
  shows "is_real (to_complex (cross_ratio (of_complex z) (of_complex u) (of_complex v) (of_complex w)))"
  using assms
  by (transfer, transfer, auto)

lemma cross_ratio:
  assumes "(z \<noteq> u \<and> v \<noteq> w) \<or> (z \<noteq> w \<and> u \<noteq> v)" and
          "z \<noteq> \<infinity>\<^sub>h" and  "u \<noteq> \<infinity>\<^sub>h" and "v \<noteq> \<infinity>\<^sub>h" and "w \<noteq> \<infinity>\<^sub>h"
  shows "cross_ratio z u v w = ((z -\<^sub>h u) *\<^sub>h (v -\<^sub>h w)) :\<^sub>h ((z -\<^sub>h w) *\<^sub>h (v -\<^sub>h u))"
  unfolding sub_def divide_def
  using assms
  apply transfer
  apply simp
  apply transfer
proof-
  fix z u v w :: complex_vec
  obtain z1 z2 u1 u2 v1 v2 w1 w2
    where *: "z = (z1, z2)" "u = (u1, u2)" "v = (v1, v2)" "w = (w1, w2)"
    by (cases z, auto, cases u, auto, cases v, auto, cases w, auto)

  let ?n1 = "z1*u2 - u1*z2"
  let ?n2 = "v1*w2 - w1*v2"
  let ?d1 = "z1*w2 - w1*z2"
  let ?d2 = "v1*u2 - u1*v2"
  assume **: "z \<noteq> vec_zero" "u \<noteq> vec_zero" "v \<noteq> vec_zero" "w \<noteq> vec_zero"
         "\<not> z \<approx>\<^sub>v u \<and> \<not> v \<approx>\<^sub>v w \<or> \<not> z \<approx>\<^sub>v w \<and> \<not> u \<approx>\<^sub>v v"
         "\<not> z \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> u \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> v \<approx>\<^sub>v \<infinity>\<^sub>v" "\<not> w \<approx>\<^sub>v \<infinity>\<^sub>v"

  hence ***: "?n1 * ?n2 \<noteq> 0 \<or> ?d1 * ?d2 \<noteq> 0"
    using *
    using complex_cvec_eq_mix[of z1 z2 u1 u2] complex_cvec_eq_mix[of v1 v2 w1 w2]
    using complex_cvec_eq_mix[of z1 z2 w1 w2] complex_cvec_eq_mix[of u1 u2 v1 v2]
    by (metis eq_iff_diff_eq_0 mult.commute mult_eq_0_iff)

  have ****: "z2 \<noteq> 0" "w2 \<noteq> 0" "u2 \<noteq> 0" "v2 \<noteq> 0"
    using * **(1-4) **(6-9)
    using inf_cvec_z2_zero_iff[of z1 z2]
    using inf_cvec_z2_zero_iff[of u1 u2]
    using inf_cvec_z2_zero_iff[of v1 v2]
    using inf_cvec_z2_zero_iff[of w1 w2]
    by blast+

  have "cross_ratio_cvec z u v w = (?n1*?n2, ?d1*?d2)"
    using * ***
    by simp
  moreover
  let ?k = "z2*u2*v2*w2"
  have "(z +\<^sub>v ~\<^sub>v u) *\<^sub>v (v +\<^sub>v ~\<^sub>v w) *\<^sub>v reciprocal_cvec ((z +\<^sub>v ~\<^sub>v w) *\<^sub>v (v +\<^sub>v ~\<^sub>v u)) = (?k * ?n1 * ?n2, ?k * ?d1 * ?d2)"
    using * *** ****
    by auto
  ultimately
  show "cross_ratio_cvec z u v w \<approx>\<^sub>v
           (z +\<^sub>v ~\<^sub>v u) *\<^sub>v (v +\<^sub>v ~\<^sub>v w) *\<^sub>v reciprocal_cvec ((z +\<^sub>v ~\<^sub>v w) *\<^sub>v (v +\<^sub>v ~\<^sub>v u))"
    using ****
    unfolding complex_cvec_eq_def
    by (rule_tac x="?k" in exI) simp
qed

end

(*
(* Although it seems useful, we did not use this. *)

text \<open>Transfer extended complex plane to complex plane\<close>

definition HC :: "complex_homo \<Rightarrow> complex \<Rightarrow> bool"
  where "HC = (\<lambda> h c. h = of_complex c)"

lemma Domainp_HC [transfer_domain_rule]: "Domainp HC = (\<lambda> x. x \<noteq> \<infinity>\<^sub>h)"
  unfolding HC_def Domainp_iff[abs_def]
  apply (rule ext)
  using inf_or_of_complex
  by auto

lemma bi_unique_HC [transfer_rule]: "bi_unique HC"
  using of_complex_inj
  unfolding HC_def bi_unique_def
  by auto

lemma right_total_HC [transfer_rule]: "right_total HC"
  unfolding HC_def right_total_def
  by auto

lemma HC_0 [transfer_rule]: "HC 0\<^sub>h 0"
  unfolding HC_def
  by simp

lemma HC_1 [transfer_rule]: "HC 1\<^sub>h 1"
  unfolding HC_def
  by simp

context includes lifting_syntax
begin
lemma HC_add [transfer_rule]: "(HC ===> HC ===> HC) (op +\<^sub>h) (op +)"
  unfolding rel_fun_def HC_def
  by auto

lemma HC_mult [transfer_rule]: "(HC ===> HC ===> HC) (op *\<^sub>h) ( op * )"
  unfolding rel_fun_def HC_def
  by auto

lemma HC_All [transfer_rule]:
  "((HC ===> op =) ===> op =) (Ball {z. z \<noteq> \<infinity>\<^sub>h}) All"
  using inf_or_of_complex
  unfolding rel_fun_def HC_def
  by auto

lemma HC_transfer_forall [transfer_rule]:
  "((HC ===> op =) ===> op =) (transfer_bforall (\<lambda>x. x \<noteq> \<infinity>\<^sub>h)) transfer_forall"
  using inf_or_of_complex
  unfolding transfer_forall_def transfer_bforall_def
  unfolding rel_fun_def HC_def
  by auto
end
*)


theory Seq2less
  imports Main
begin

(* Here we have basic definitions of 2-less relation and sequence *)

(* Base: Triple, lt, lt_all, is_less *)

type_synonym Tri = "nat \<times> nat \<times> nat"
(* PS: We could also use nat, but then complements get complicated. *)

fun lt :: "Tri \<Rightarrow> Tri \<Rightarrow> bool" (infixl "\<prec>" 70) where
  "lt (x1, x2, x3) (y1, y2, y3) =
    (x1 < y1 \<and> (x2 < y2 \<or> x3 < y3) \<or> (x2 < y2) \<and> (x3 < y3))"

primrec lt_all :: "Tri \<Rightarrow> Tri list \<Rightarrow> bool" where
  "lt_all x [] = True" |
  "lt_all x (h#t) = (x \<prec> h \<and> lt_all x t)"

primrec is_2less :: "Tri list \<Rightarrow> bool" where
  "is_2less [] = True" |
  "is_2less (h#t) = (lt_all h t \<and> is_2less t)"

(* Addon: gt_all, valid_candidate *)

primrec gt_all :: "Tri \<Rightarrow> Tri list \<Rightarrow> bool" where
  "gt_all x [] = True" |
  "gt_all x (h#t) = (h \<prec> x \<and> gt_all x t)"

lemma relate_gt_all_to_lt_all:
  "lt_all h t \<and> gt_all x (h#t) \<longrightarrow> lt_all h (t@[x])"
  apply (induction t arbitrary: x h)
  by auto

lemma valid_candidate:
  "is_2less s \<and> gt_all x s  \<longrightarrow> is_2less (s@[x])"
  apply (induction s arbitrary: x)
  apply simp
  using relate_gt_all_to_lt_all
  by auto

(* Some additional relations *)

fun lt3 :: "Tri \<Rightarrow> Tri \<Rightarrow> bool" where
  "lt3 (x1, x2, x3) (y1, y2, y3) =
    (x1 < y1 \<and> x2 < y2 \<and> x3 < y3)"

fun le3 :: "Tri \<Rightarrow> Tri \<Rightarrow> bool" where
  "le3 (a, b, c) (x, y, z) =
	  (a \<le> x \<and> b \<le> y \<and> c \<le> z)"

lemma lt3_implies_lt:
  "lt3 x y \<longrightarrow> lt x y"
  by (smt Pair_inject lt.elims(3) lt3.elims(2))

lemma lt3_implies_le3:
  "lt3 x y \<longrightarrow> le3 x y"
  by (smt Pair_inject le3.elims(3) less_le lt3.elims(2))

lemma transitive_le3_and_lt:
  "le3 x y \<and> y \<prec> z \<longrightarrow> x \<prec> z"
  by (smt Pair_inject le3.elims(2) le_less_trans lt.elims(2) lt.elims(3))

end


theory tp5bis
  imports Main
begin

(* les glob sont les chaînes unix qui utilisent les jokers ?, * et + pour décrire des ensembles de noms *)

(* Définition du type glob (ici nommé pattern) *)
datatype symbol = Char char | Star | Qmark | Plus

type_synonym word= "char list"
type_synonym pattern= "symbol list"

(* La fonction qui dit si un mot est accepté par un pattern/glob  *)
fun accept::"pattern \<Rightarrow> word \<Rightarrow> bool"
  where
"accept [] [] = True" |
"accept [Star] _ = True" |
"accept [] (_#_) = False" |
"accept ((Char x)#_) [] = False" |
"accept ((Char x)#r1) (y#r2) = (if x=y then (accept r1 r2) else False)"  |
"accept (Qmark#r1) [] = False" |
"accept (Qmark#r1) (_#r2) = (accept r1 r2)" |
"accept (Plus#r1) [] = False" |
"accept (Plus#r1) (a#r2) = (accept (Star#r1) r2)" |
"accept (Star#r1) [] = (accept r1 [])" |
"accept (Star#r1) (a#r2) = ((accept r1 (a#r2)) \<or> (accept r1 r2) \<or> (accept (Star#r1) r2))"

(* Les caractères en Isabelle/HOL *)
value "(CHR ''a'')"

(* Quelques exemples d'utilisation de la fonction accept *)
value "accept [Star,(Char (CHR ''a''))] [(CHR ''a'')]"
value "accept [Star,(Char (CHR ''a''))] [(CHR ''b''),(CHR ''a'')]"
value "accept [Star,(Char (CHR ''a''))] [(CHR ''a''),(CHR ''b'')]"
value "accept [Star,Star] []"
value "accept [Plus,Star,Star] []"
value "accept [Qmark] []"
value "accept [Qmark,Plus] [(CHR ''a''),(CHR ''a'')]"
value "accept [Plus,Plus] [(CHR ''a''),(CHR ''a'')]"
value "accept [Plus,Plus] [(CHR ''a'')]"

(* ----------------------------- Votre TP commence ici! ---------------------------------------- *)
fun simplify::"pattern \<Rightarrow> pattern"
  where
  "simplify [] = []"
| "simplify (Plus#(Char x) #t) = (Plus#(Char x)#(simplify t))"
| "simplify (Plus#Plus #t) = (Qmark#(simplify (Plus#t)))"
| "simplify (Plus#Star#t) = ((simplify (Plus#t)))"
| "simplify (Plus#Qmark#t) = (Plus#(simplify (Qmark#t)))"
| "simplify (Star#(Char x) #t) = (Star#(Char x)#(simplify t))"
| "simplify (Star#Star #t) = ((simplify (Star#t)))"
| "simplify (Star#Plus #t) = ((simplify (Plus#t)))"
| "simplify (Star#Qmark #t) = ((simplify (Plus#t)))"
| "simplify (Qmark#(Char x) #t) = (Qmark#(Char x)#(simplify t))"
| "simplify (Qmark#Plus #t) = (Qmark#(simplify (Plus#t)))"
| "simplify (Qmark#Star #t) = ((simplify (Plus#t)))"
| "simplify (Qmark#Qmark #t) = (Qmark#(simplify (Qmark#t)))"
| "simplify ((Char x)#t) = ((Char x)#(simplify (t)))"
| "simplify (h#t) = (h#(simplify t))"

value "simplify [Star,Star,Plus,Qmark,(Char (CHR ''a'')), Qmark, Qmark, Plus] "

(* Le lemme de correction de la fonction simplify... Pour le prouver voir les lemmes intermédiaires à définir, plus bas. *)
lemma " accept l m = accept (simplify l) m "
  nitpick [timeout = 60]
  quickcheck [tester=narrowing, size = 100, timeout = 10000]
  oops

(* Le lemme de minimalité dit que le pattern simplifié est le plus petit de tous les
   patterns équivalents. Reformulé ici sous la forme de sa contraposée: s'il existe un pattern
   plus petit que le pattern simplifié alors il n'est pas équivalent. Il n'est pas équivalent
   si il existe au moins pour lequel l'acceptation par "accept" sera différente. *)

lemma "((length p)< (length (simplify p2))) \<longrightarrow> (\<exists> w. (accept p w) \<noteq> (accept (simplify p2) w))"
 (* La preuve de ce lemme n'est pas demandée. *)
 (* Utiliser le lemme suivant pour trouver des contre-exemples *)
  oops

(* Pour trouver (efficacement) des contre-exemples sur ce lemme de minimalité, on va limiter
   la complexité des patterns considérés qu'on nommera "basicPattern" : Ici des patterns
    avec *, ?, + et uniquement le caractère A *)

fun basicPattern:: "pattern \<Rightarrow> bool"
  where
"basicPattern [] = True" |
"basicPattern ((Char CHR ''A'') # r) = basicPattern r" |
"basicPattern ((Char _) # r) = False" |
"basicPattern (_ # r) = basicPattern r"

(* Le lemme de minimalité pour les basicPatterns *)
lemma "(basicPattern p) \<longrightarrow> ((length p)< (length (simplify p2))) \<longrightarrow> (\<exists> w. (accept p w) \<noteq> (accept (simplify p2) w))"
  quickcheck [tester=narrowing,size = 100, timeout=100]
   (* nitpick ne trouve que des contre-exemples qui n'en sont pas *)
  oops

(* La directive d'export du code Scala *)
(* A ne pas modifier! *)
code_reserved Scala
  symbol
code_printing
   type_constructor symbol \<rightharpoonup> (Scala) "Symbol"
   | constant Char \<rightharpoonup> (Scala) "Char"
   | constant Star \<rightharpoonup> (Scala) "Star"
   | constant Plus \<rightharpoonup> (Scala) "Plus"
   | constant Qmark \<rightharpoonup> (Scala) "Qmark"

export_code simplify in Scala

(* Pour prouver le lemme de correction, il vous sera nécessaire de prouver tous ces lemmes intermédiaires! *)

(* Le pattern vide n'accepte que le mot vide *)
lemma acceptVide: "(accept [] w) \<longrightarrow> w=[]"
  apply (induct w)
  apply simp
  by simp

(* Le seul pattern n'acceptant que le mot vide est le pattern vide *)
lemma acceptVide2: "(\<forall> w. w\<noteq>[] \<longrightarrow> \<not>(accept p w)) \<longrightarrow> p=[]"
  apply (induct p)
   apply auto
  by (metis (full_types) accept.simps(1) accept.simps(2) accept.simps(5) accept.simps(7) accept.simps(9) list.simps(3) symbol.exhaust)

(* Le seul pattern n'acceptant que le langage ? est ? *)
lemma acceptQmark: "(\<forall> w. (accept [Qmark] w = (accept p w))) \<longrightarrow> p=[Qmark]"
  apply (induct p arbitrary: w rule: simplify.induct)
   apply simp
  using accept.simps(1) accept.simps(6) apply blast
  sorry

(* Si le pattern commence par un caractère ou un point d'interrogation alors le mot accepté
   commence forcément par un caractère (il ne peut être vide) *)
lemma charAndQmarkRemoval: "((x\<noteq>Star) \<and> (x\<noteq> Plus) \<and> (accept (x#r) m)) \<longrightarrow> (\<exists> x2 r2. m=x2#r2 \<and> (accept r r2))"
  apply (induct m)
   apply simp
   apply (metis accept.simps(4) accept.simps(6) symbol.exhaust)
  sorry

(* Si le pattern commence par une étoile, on peut soit l'oublier soit oublier le premier caractère du mot accepté *)
lemma patternStartsWithStar: "((accept (Star#r) m)) \<longrightarrow> ((accept r m) \<or> (\<exists> x2 r2. m=x2#r2 \<and> (accept (Star#r) r2)))"
  apply (induct m)
   apply simp
   apply (metis accept.simps(1) accept.simps(10) list.exhaust)

  oops

(* On peut compléter à gauche n'importe quel pattern par une étoile *)
lemma completePatternWithStar: "(accept r m) \<longrightarrow> (accept (Star#r) m)"
  apply (induct r)
   apply simp
  by (metis (full_types) accept.simps(10) accept.simps(11) list.exhaust)

lemma completePatternWithStar2: "(accept r m) \<longrightarrow> (accept (Star#r) (m1@m))"
  oops

(* On peut oublier une étoile dès qu'il y en a une juste après *)
lemma forgetOneStar:"(accept (Star#(Star#r)) w) = (accept (Star#r) w)"
  oops

(* Etoile suivie de point d'interrogation est équivalent à point d'interrogation étoile *)
lemma starQmark:"((accept (Star#(Qmark#r)) w) = (accept (Qmark#(Star#r)) w))"
  oops

(* Si deux patterns sont équivalents on peut les compléter à gauche... *)

(* ... par une étoile *)
lemma equivalentPatternStar:"((\<forall> w1. (accept p1 w1) = (accept p2 w1))) \<longrightarrow> ((accept (Star#p1) w) = (accept (Star#p2) w))"
  oops

(* ... par un caractère (identique) *)
lemma equivalentPatternChar:"((\<forall> w. (accept p1 w) = (accept p2 w))) \<longrightarrow> ((accept ((Char x)#p1) w) = (accept ((Char x)#p2) w))"
  oops

(* ... par un point d'interrogation *)
lemma equivalentPatternQmark:"((\<forall> w. (accept p1 w) = (accept p2 w))) \<longrightarrow> ((accept (Qmark#p1) w) = (accept (Qmark#p2) w))"
  oops

(* Par un plus *)
lemma equivalentPatternPlus:"((\<forall> w. (accept p1 w) = (accept p2 w))) \<longrightarrow> ((accept (Plus#p1) w) = (accept (Plus#p2) w))"
  oops

lemma plusStarQmark:"((accept (Star#(Qmark#r)) w) = (accept (Plus#r) w))"
  oops

lemma plusStarStar:"((accept (Plus#(Star#r)) w) = (accept (Plus#r) w))"
  oops

lemma plusPlus1:"((accept (Plus#(Plus#r)) w) = (accept (Qmark#(Plus#r)) w))"
  oops

(* Le lemme de correction final *)
lemma correction:"accept l m = accept (simplify l) m"
  oops

end


(* Author: Tobias Nipkow, Daniel Stüwe *)

section \<open>Three-Way Comparison\<close>

theory Cmp
imports MainRLT
begin

datatype cmp_val = LT | EQ | GT

definition cmp :: "'a:: linorder \<Rightarrow> 'a \<Rightarrow> cmp_val" where
"cmp x y = (if x < y then LT else if x=y then EQ else GT)"

lemma
    LT[simp]: "cmp x y = LT \<longleftrightarrow> x < y"
and EQ[simp]: "cmp x y = EQ \<longleftrightarrow> x = y"
and GT[simp]: "cmp x y = GT \<longleftrightarrow> x > y"
by (auto simp: cmp_def)

lemma case_cmp_if[simp]: "(case c of EQ \<Rightarrow> e | LT \<Rightarrow> l | GT \<Rightarrow> g) =
  (if c = LT then l else if c = GT then g else e)"
by(simp split: cmp_val.split)

end


(* Title:      Involutive Residuated Structures
   Author:     Victor Gomes
   Maintainer: Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
*)

section \<open>Involutive Residuated Structures\<close>

theory Involutive_Residuated
  imports Residuated_Lattices
begin

class uminus' =
  fixes uminus' :: "'a \<Rightarrow> 'a" ("-'' _" [81] 80)

text \<open>
  Involutive posets is a structure where the double negation property holds for the
  negation operations, and a Galois connection for negations exists.
\<close>
class involutive_order = order + uminus + uminus' +
  assumes gn: "x \<le> -'y \<longleftrightarrow> y \<le> -x"
  and dn1[simp]: "-'(-x) = x"
  and dn2[simp]: "-(-'x) = x"
(* The involutive pair (-', -) is compatible with multiplication *)
class involutive_pogroupoid = order + times + involutive_order +
  assumes ipg1: "x\<cdot>y \<le> z \<longleftrightarrow> (-z)\<cdot>x \<le> -y"
  and ipg2: "x\<cdot>y \<le> z \<longleftrightarrow> y\<cdot>(-'z) \<le> -'x"
begin

lemma neg_antitone: "x \<le> y \<Longrightarrow> -y \<le> -x"
  by (metis local.dn1 local.gn)

lemma neg'_antitone: "x \<le> y \<Longrightarrow> -'y \<le> -'x"
  by (metis local.dn2 local.gn)

subclass pogroupoid
proof
  fix x y z assume assm: "x \<le> y"
  show "x \<cdot> z \<le> y \<cdot> z"
    by (metis assm local.ipg2 local.order_refl local.order_trans neg'_antitone)
  show "z \<cdot> x \<le> z \<cdot> y"
    by (metis assm local.dual_order.trans local.ipg1 local.order_refl neg_antitone)
qed

abbreviation inv_resl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "inv_resl y x \<equiv> -(x\<cdot>(-'y))"

abbreviation inv_resr :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "inv_resr x y \<equiv> -'((-y)\<cdot>x)"

sublocale residuated_pogroupoid _ _ _ inv_resl inv_resr
proof
  fix x y z
  show "(x \<le> - (y \<cdot> -' z)) = (x \<cdot> y \<le> z)"
    by (metis local.gn local.ipg2)
  show "(x \<cdot> y \<le> z) = (y \<le> -' (- z \<cdot> x))"
    by (metis local.gn local.ipg1)
qed

end

class division_order = order + residual_l_op + residual_r_op +
  assumes div_galois: "x \<le> z \<leftarrow> y \<longleftrightarrow> y \<le> x \<rightarrow> z"

class involutive_division_order = division_order + involutive_order +
  assumes contraposition: "y \<rightarrow> -x = -'y \<leftarrow> x"

context involutive_pogroupoid begin

sublocale involutive_division_order _ _ inv_resl inv_resr
proof
  fix x y z
  show "(x \<le> - (y \<cdot> -' z)) = (y \<le> -' (- z \<cdot> x))"
    by (metis local.gn local.ipg1 local.ipg2)
  show "-' (- (- x) \<cdot> y) = - (x \<cdot> -' (-' y))"
    by (metis local.dn1 local.dn2 local.eq_iff local.gn local.jipsen1l local.jipsen1r local.resl_galois local.resr_galois)
qed

lemma inv_resr_neg [simp]: "inv_resr (-x) (-y) = inv_resl x y"
  by (metis local.contraposition local.dn1)

lemma inv_resl_neg' [simp]: "inv_resl (-'x) (-'y) = inv_resr x y"
  by (metis local.contraposition local.dn2)

lemma neg'_mult_resl: "-'((-y)\<cdot>(-x)) = inv_resl x (-'y)"
  by (metis inv_resr_neg local.dn2)

lemma neg_mult_resr: "-((-'y)\<cdot>(-'x)) = inv_resr (-x) y"
  by (metis neg'_mult_resl)

lemma resr_de_morgan1: "-'(inv_resr (-y) (-x)) = -'(inv_resl y x)"
  by (metis local.dn1 neg_mult_resr)

lemma resr_de_morgan2: "-(inv_resl (-'x) (-'y)) = -(inv_resr x y)"
  by (metis inv_resl_neg')

end

text \<open>
  We prove that an involutive division poset is equivalent to an involutive po-groupoid
  by a lemma to avoid cyclic definitions
\<close>
lemma (in involutive_division_order) inv_pogroupoid:
  "class.involutive_pogroupoid (\<lambda>x y. -(y \<rightarrow> -'x)) uminus uminus' (\<le>) (<)"
proof
  fix x y z
  have "(- (y \<rightarrow> -' x) \<le> z) = (-z \<le> -y \<leftarrow> x)"
    by (metis local.contraposition local.dn1 local.dn2 local.gn local.div_galois)
  thus "(- (y \<rightarrow> -' x) \<le> z) = (- (x \<rightarrow> -' (- z)) \<le> - y)"
    by (metis local.contraposition local.div_galois local.dn1 local.dn2 local.gn)
  moreover have "(- (x \<rightarrow> -' (- z)) \<le> - y) = (- (-' z \<rightarrow> -' y) \<le> -' x)"
    apply (auto, metis local.contraposition local.div_galois local.dn1 local.dn2 local.gn)
    by (metis local.contraposition local.div_galois local.dn1 local.dn2 local.gn)
  ultimately show "(- (y \<rightarrow> -' x) \<le> z) = (- (-' z \<rightarrow> -' y) \<le> -' x)"
    by metis
qed

context involutive_pogroupoid begin

definition negation_constant :: "'a \<Rightarrow> bool" where
  "negation_constant a \<equiv> \<forall>x. -'x = inv_resr x a \<and> -x = inv_resl a x"

definition division_unit :: "'a \<Rightarrow> bool" where
  "division_unit a \<equiv> \<forall>x. x = inv_resr a x \<and> x = inv_resl x a"

lemma neg_iff_div_unit: "(\<exists>a. negation_constant a) \<longleftrightarrow> (\<exists>b. division_unit b)"
  unfolding negation_constant_def division_unit_def
  apply safe
  apply (rule_tac x="-a" in exI, auto)
  apply (metis local.dn1 local.dn2)
  apply (metis local.dn2)
  apply (rule_tac x="-b" in exI, auto)
  apply (metis local.contraposition)
  apply (metis local.dn2)
done

end

end


theory Booleanos
imports Main
begin

section "Ejemplo de cálculo con booleanos"

value "True \<and> \<not>False"
  (* da "True" :: "bool"*)
value "\<not>(True \<or> \<not>False)"
  (* da "False" :: "bool"*)
value "(True \<and> \<not>False) = (True \<or> \<not>False)"
  (* da "True" :: "bool"*)
value "True \<and> \<not>False \<longleftrightarrow> True \<or> \<not>False"
  (* da "True" :: "bool"*)
value "True \<and> B"
  (* da B :: "bool"*)
value "True \<or> B"
 (* da "True" :: "bool"*)

section "Ejemplo de definición no recursiva con definition"

text {* (xor F G) se verifica si exactamente una de de las fórmulas F y
  G es verdadera. Por ejemplo,
     xor True True  = False
     xor True False = True
*}
definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool"
where
  "xor F G \<equiv> (F \<noteq> G)"

value "xor True True"  (* da False *)
value "xor True False" (* da True *)

section "Ejemplo de definición con patrones usando fun"

text {* (conjuncion F G) se verifica si F y G son verdaderas. Por
  ejemplo,
     conjuncion True  True = True
     conjuncion False True = False
*}
fun conjuncion :: "bool \<Rightarrow> bool \<Rightarrow> bool"
where
  "conjuncion True G  = G"
| "conjuncion False _ = False"

value "conjuncion True  True" (* da True *)
value "conjuncion False True" (* da False *)

section "Ejemplo de demostración por simplificación"

lemma "conjuncion True B = B" by simp

section "Ejemplo de exportación a Haskell"

export_code conjuncion in Haskell

(* da
  module Booleanos(conjuncion) where {

  import Prelude ...
  import qualified Prelude;

  conjuncion :: Bool -> Bool -> Bool;
  conjuncion True g = g;
  conjuncion False uu = False;

  }
*)

end


theory Ordinal
  imports "../GST_Features"
begin

context Ordinal begin
(*Recalling signature and axioms of feature:*)
(* - Types and axioms for \<open>zero\<close>, \<open>succ\<close> and \<open>\<omega>\<close>: *)
thm zero_typ succ_typ omega_typ zero_ax succ_ax omega_ax Limit_ax
(* - Axioms specifying that \<open><\<close> is a well-order on the ordinals:*)
thm lt_trans lt_notsym lt_linear lt_induct

lemmas zero_ord = zero_typ
lemmas succ_ord = funE[OF succ_typ]

subsection \<open>Initial Finite Ordinals\<close>

lemma zero_lt :
  assumes "b : Ord"
    shows "\<not> b < 0"
  using zero_ax assms
  by auto

(*Don't think we actually ever use this lemma,
  it's just analagous to the one in ZF/Ordinal.thy*)
lemmas zero_ltE = zero_lt [THEN notE]

(* definition one   :: "'d" (\<open>1\<close>) where "1 \<equiv> succ 0"
definition two   :: "'d" (\<open>2\<close>) where "2 \<equiv> succ 1"
definition three :: "'d" (\<open>3\<close>) where "3 \<equiv> succ 2"
lemma one_ord   : "1 : Ord" unfolding one_def   by (rule succ_ord[OF zero_typ])
lemma two_ord   : "2 : Ord" unfolding two_def   by (rule succ_ord[OF one_ord])
lemma three_ord : "3 : Ord" unfolding three_def by (rule succ_ord[OF two_ord])
 *)
subsection \<open>Well-Ordering properties of < \<close>

lemma trans :
  assumes "i : Ord" "j : Ord" "k : Ord"
      and "i < j" "j < k"
    shows "i < k"
  using lt_trans assms
  by auto

lemma asym :
  assumes "i : Ord" "j : Ord"
      and "i < j" "\<not> P \<Longrightarrow> j < i"
    shows "P"
  using lt_notsym assms
  by auto

lemma lt_reflE :
  assumes "i : Ord"
    shows "i < i \<Longrightarrow> P"
  using asym assms
  by auto

corollary not_refl :
  assumes "i : Ord"
    shows "\<not> i < i"
  using lt_reflE[OF assms]
  by auto

lemma lt_neq :
  assumes "i : Ord" "j : Ord"
  shows "i < j \<Longrightarrow> i \<noteq> j"
  using lt_reflE assms
  by auto

lemma linear :
  assumes "i : Ord" "j : Ord"
  obtains (lt) "i < j" | (eq)  "i = j" | "j < i"
  using assms lt_linear
  by auto

subsection \<open>succ - Successor operation\<close>

lemma succ_lt :
  assumes "i : Ord"
    shows "i < succ i"
  using succ_ax assms by auto

lemma succ_neq :
  assumes "i : Ord"
  shows "i \<noteq> succ i"
  by (rule lt_neq[OF assms succ_ord[OF assms] succ_lt[OF assms]])

lemma succ_nonzero :
  assumes "i : Ord"
  shows "succ i \<noteq> 0"
  using succ_lt zero_lt assms by auto

subsection \<open>leq - Less Than or Equal To\<close>

lemma leq_iff :
  assumes "i : Ord" "j : Ord"
    shows "i \<le> j \<longleftrightarrow> i < j \<or> i = j"
  using succ_ax assms unfolding tall_def
  by auto

lemma leqI1 :
  assumes "i : Ord" "j : Ord"
    shows "i < j \<Longrightarrow> i \<le> j"
  using leq_iff[OF assms]
  by auto

lemma leqI2 :
  assumes "i : Ord" "j : Ord"
    shows "i = j \<Longrightarrow> i \<le> j"
  using leq_iff[OF assms]
  by auto

lemma leqE :
  assumes "i : Ord" "j : Ord" "i \<le> j"
      and "i < j \<Longrightarrow> P" "i = j \<Longrightarrow> P"
    shows "P"
  using leq_iff assms
  by auto

lemma leq_refl :
  assumes "i : Ord"
    shows "i \<le> i"
  using leqI2 assms
  by auto

lemma linear_lt_leq :
  assumes "i : Ord" "j : Ord"
  obtains (lt) "i < j" | (ge) "j \<le> i"
  by (rule linear[OF assms], use leqI1 leqI2 assms in auto)

lemma linear_leq :
  assumes "i : Ord" "j : Ord"
  obtains (le) "i \<le> j" | (ge) "j \<le> i"
  by (rule linear_lt_leq[OF assms],
      blast intro: leqI1 leqI2 assms)

lemma not_lt_leq :
  assumes "i : Ord" "j : Ord"
  shows "\<not> i < j \<Longrightarrow> j \<le> i"
  by (rule linear_lt_leq[OF assms], auto)

lemma leq_not_lt :
  assumes "i : Ord" "j : Ord"
    shows "j \<le> i \<Longrightarrow> \<not> i < j"
  using leqE asym assms
  by blast

lemma not_leq_iff_lt :
  assumes "i : Ord" "j : Ord"
    shows "\<not> i < j \<longleftrightarrow> j \<le> i"
  using not_lt_leq leq_not_lt assms
  by auto

lemma neq_zero_lt :
  assumes "i : Ord"
    shows "i \<noteq> 0 \<Longrightarrow> 0 < i"
proof -
  have "0 \<le> i" using zero_lt[OF assms] not_leq_iff_lt[OF assms zero_typ] by auto
  assume "i \<noteq> 0"
  thus "0 < i" using leqE[OF zero_typ assms \<open>0 \<le> i\<close>] by auto
qed

lemma leqCI :
  assumes "i : Ord" "j : Ord"
      and "i \<noteq> j \<Longrightarrow> i < j"
    shows "i \<le> j"
  unfolding leq_iff[OF assms(1,2)] using assms(3)
  by auto

lemma leq_antisym :
  assumes "i : Ord" "j : Ord"
    shows "i \<le> j \<Longrightarrow> j \<le> i \<Longrightarrow> i = j"
  using leq_iff asym assms by auto

lemma leq_zero_iff :
  assumes "i : Ord"
    shows "i \<le> 0 \<longleftrightarrow> i = 0"
  unfolding leq_iff[OF \<open>i : Ord\<close> zero_typ] using zero_lt[OF \<open>i : Ord\<close>]
  by auto

lemma leq_zeroD :
  assumes "i : Ord"
    shows "i \<le> 0 \<Longrightarrow> i = 0"
  by (rule leq_zero_iff[OF \<open>i : Ord\<close>, THEN iffD1])

lemma zero_leq :
  assumes "i : Ord"
    shows "0 \<le> i"
  using not_lt_leq[OF _ zero_typ] zero_lt assms
  by auto

lemma zero_lt_iff :
  assumes "i : Ord"
    shows "i \<noteq> 0 \<longleftrightarrow> 0 < i"
  using zero_leq[OF assms] leq_iff[OF zero_typ assms] not_refl[OF zero_typ] by auto

lemma all_lt_leq :
  assumes "i : Ord" "j : Ord"
      and lt: "\<And>x. x : Ord \<Longrightarrow> x < j \<Longrightarrow> x < i"
    shows "j \<le> i"
  using not_lt_leq not_refl assms
  by auto

lemma leq_succ_iff :
  assumes "i : Ord" "j : Ord"
    shows "i \<le> succ j \<longleftrightarrow> i \<le> j \<or> i = succ j"
  unfolding leq_iff[OF \<open>i : Ord\<close> succ_ord[OF \<open>j : Ord\<close>]]
  by rule

lemma succ_leq :
  assumes "i : Ord"
  shows "i \<le> succ i"
  using succ_lt leqI1 assms succ_ord by auto

subsection \<open>Transitivity Rules\<close>

lemma lt_trans1 :
  assumes "i : Ord" "j : Ord" "k : Ord"
  shows "i \<le> j \<Longrightarrow> j < k \<Longrightarrow> i < k"
  by (blast elim!: leqE[OF \<open>i : Ord\<close> \<open>j : Ord\<close>]
            intro: trans[OF assms])

lemma lt_trans2 :
  assumes "i : Ord" "j : Ord" "k : Ord"
  shows "i < j \<Longrightarrow> j \<le> k \<Longrightarrow> i < k"
  by (blast elim!: leqE[OF \<open>j : Ord\<close> \<open>k : Ord\<close>]
            intro: trans[OF assms])

lemma leq_trans2 :
  assumes "i : Ord" "j : Ord" "k : Ord"
  shows "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k"
  by (blast intro: lt_trans1[OF \<open>i : Ord\<close> \<open>j : Ord\<close> succ_ord[OF \<open>k : Ord\<close>]])

lemma succ_leqI :
  assumes "i : Ord" "j : Ord"
  shows "i<j \<Longrightarrow> succ i \<le> j"
proof (rule not_leq_iff_lt[OF \<open>j : Ord\<close> succ_ord[OF \<open>i : Ord\<close>], THEN iffD1])
  assume "i < j" thus "\<not> j \<le> i"
    using not_leq_iff_lt[OF \<open>i : Ord\<close> \<open>j : Ord\<close>] by auto
qed

lemma succ_leqE :
  assumes "i : Ord" "j : Ord"
  shows "succ i \<le> j \<Longrightarrow> i < j"
proof -
  assume "succ i \<le> j"
  hence "\<not> j \<le> i" using not_leq_iff_lt[OF \<open>j : Ord\<close> succ_ord[OF \<open>i : Ord\<close>]] by auto
  thus "i < j" using not_leq_iff_lt[OF \<open>i : Ord\<close> \<open>j : Ord\<close>] by auto
qed

lemma succ_leq_iff :
  assumes "i : Ord" "j : Ord"
  shows "succ i \<le> j \<longleftrightarrow> i < j"
  using succ_leqI succ_leqE assms
  by auto

lemma succ_leq_imp_leq :
  assumes "i : Ord" "j : Ord"
  shows "succ i \<le> succ j \<longleftrightarrow> i \<le> j"
  using succ_leq_iff assms succ_ord
  by auto

lemma lt_zero_lt :
  assumes "i : Ord" "j : Ord"
  shows "j < i \<Longrightarrow> 0 < i"
  using lt_trans1[OF zero_typ \<open>j : Ord\<close> \<open>i : Ord\<close>]
        zero_leq[OF \<open>j : Ord\<close>]
  by auto

subsection \<open>Limit Ordinals\<close>

lemma Limit_def :
  "Limit = (Ord \<triangle> (\<lambda>\<mu>. 0 < \<mu> \<and> (\<forall>j : Ord. j < \<mu> \<longrightarrow> succ j < \<mu>)))"
  using Limit_ax by auto

lemma limit_ord :
  assumes "\<mu> : Limit"
    shows "\<mu> : Ord"
  using assms unfolding Limit_def
  by unfold_typs

lemma limit_lt_zero :
  assumes "\<mu> : Limit"
    shows "0 < \<mu>"
  using assms unfolding Limit_def
  by unfold_typs

lemma limit_nonzero :
  assumes "\<mu> : Limit"
  shows "\<mu> \<noteq> 0"
  using zero_lt_iff[OF limit_ord] limit_lt_zero assms
  by auto

lemma limit_lt_succ :
  assumes "\<mu> : Limit" "\<beta> : Ord" "\<beta> < \<mu>"
    shows "succ \<beta> < \<mu>"
  using assms unfolding Limit_def by unfold_typs

lemma limit_succE :
  assumes i:"i : Ord" and succ_i:"succ i : Limit"
  shows "P"
proof (rule ccontr)
  have succ_i_ord:"succ i : Ord" by (rule limit_ord[OF succ_i])
  hence "\<not> succ i < succ i" by (rule not_refl)
  thus "False" using limit_lt_succ[OF succ_i i leq_refl[OF i]] by auto
qed

definition nonLimit where [typdef] : "nonLimit \<equiv> Ord \<triangle> (\<lambda>i. \<not> i : Limit)"

lemma nonLimitI :
  assumes "i : Ord" "\<not> i : Limit"
  shows "i : nonLimit"
  using assms by unfold_typs

lemma nonLimitD :
  assumes "i : nonLimit"
  shows "i : Ord \<and> \<not> i : Limit"
  using assms by unfold_typs

lemmas nonLimitE = conjE[OF nonLimitD]
lemma nonlimit_ord :
  assumes i:"i : nonLimit"
  shows "i : Ord"
    using i by unfold_typs

thm Ordinal.limit_succE Ordinal_axioms
lemma not_succ_limit :
  assumes i:"i : Ord"
  shows "\<not> succ i : Limit"
  by (meson i limit_succE)

(* lemma limit_lt_one :
  assumes \<mu>:"\<mu> : Limit"
  shows "1 < \<mu>"
  unfolding one_def
  by (rule limit_lt_succ[OF \<mu> zero_typ limit_lt_zero[OF \<mu>]]) *)

lemma limit_succ_lt_iff :
  assumes \<mu>:"\<mu> : Limit" and i:"i : Ord"
  shows "succ i < \<mu> \<longleftrightarrow> i < \<mu>"
proof (rule)
  assume "succ i < \<mu>"
  moreover have "i < succ i" by (rule succ_lt[OF i])
  ultimately show "i < \<mu>" using trans[OF i succ_ord[OF i] limit_ord[OF \<mu>]] by auto
next
  assume "i < \<mu>"
  thus "succ i < \<mu>" by (rule limit_lt_succ[OF \<mu> i])
qed

lemma not_zero_limit : "\<not> 0 : Limit"
  using not_refl[OF zero_typ] unfolding Limit_def has_ty_def inter_ty_def
  by auto

lemmas zero_nonlimit = nonLimitI[OF zero_typ not_zero_limit]

lemma succ_nonlimit :
  assumes i:"i : Ord"
  shows "succ i : nonLimit"
  using nonLimitI not_succ_limit i succ_ord by auto

lemma limit_leq_succD :
  assumes \<mu>:"\<mu> : Limit" and i:"i : Ord"
  shows "\<mu> \<le> succ i \<Longrightarrow> \<mu> \<le> i"
  by (rule leqE[OF limit_ord[OF \<mu>] succ_ord[OF i]],
      use not_succ_limit[OF i] \<mu> in auto)

lemma limitI :
  assumes "i : Ord"
    and "0 < i" "\<forall>j : Ord. succ j \<noteq> i"
  shows "i : Limit" unfolding Limit_def
proof (rule intI[OF \<open>i : Ord\<close>], rule tyI, rule, rule \<open>0 < i\<close>, rule, rule)
  fix j assume "j : Ord" "j < i"
  hence "\<not> i \<le> j" "succ j \<noteq> i" using leq_not_lt[OF _ \<open>i : Ord\<close>] assms(3) by auto
  thus "succ j < i" using assms(3) linear[OF succ_ord[OF \<open>j : Ord\<close>] \<open>i : Ord\<close>] by auto
qed

lemma increasing_limitI :
  assumes \<mu>:"\<mu> : Ord" and zero: "0 < \<mu>"
  and lt:"\<forall>i : Ord. i < \<mu> \<longrightarrow> (\<exists>j : Ord. j < \<mu> \<and> i < j)"
  shows "\<mu> : Limit"
  unfolding Limit_def
proof (rule Soft_Types.intI[OF \<mu>], rule tyI, rule conjI[OF zero], auto)
  fix i assume i:"i : Ord" and "i < \<mu>"
  then obtain j where j:"j : Ord" and "j < \<mu>" "i < j" using lt by auto
  show "succ i < \<mu>" by (rule lt_trans1[OF succ_ord[OF i] j \<mu> succ_leqI[OF i j \<open>i < j\<close>] \<open>j < \<mu>\<close>])
qed

subsection \<open>Trichotomy of Ordinals, Transfinite Induction\<close>

lemma ord_cases_disj :
  assumes "i : Ord"
  shows "i = 0 \<or> (\<exists>j : Ord. i = succ j) \<or> i : Limit"
  using limitI neq_zero_lt assms
  by auto

lemma ord_cases :
  assumes "i : Ord"
  obtains (zero) "i = 0"
        | (succ) j where "j : Ord" "i = succ j"
        | (limit) "i : Limit"
  using ord_cases_disj[OF assms]
  by auto

lemma trans_induct [consumes 1, case_names step] :
  assumes "i : Ord" "\<And>j. j : Ord \<Longrightarrow> (\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> P k) \<Longrightarrow> P j"
  shows "P i"
  using lt_induct assms unfolding tall_def
  by auto

lemma trans_induct3 [case_names zero succ lim, consumes 1] :
  assumes "i : Ord"
     and zero: "P 0"
     and succ: "\<And>j. \<lbrakk> j : Ord; P j \<rbrakk> \<Longrightarrow> P (succ j)"
     and lim : "\<And>\<mu>. \<lbrakk> \<mu> : Limit; \<forall>j : Ord. j < \<mu> \<longrightarrow> P j \<rbrakk> \<Longrightarrow> P \<mu>"
   shows "P i"
proof (rule trans_induct[OF \<open>i : Ord\<close>])
  fix j assume j:"j : Ord"
  and IH: "\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> P k"
  show "P j" proof (rule ord_cases[OF j])
    assume "j = 0" thus "P j" using zero by auto
  next
    fix k assume "k : Ord" "j = succ k"
    hence "k < j" using succ_lt by auto
    thus "P j" using IH[OF \<open>k : Ord\<close>] succ[OF \<open>k : Ord\<close>] \<open>j = succ k\<close> by auto
  next
    assume "j : Limit"
    thus "P j" using lim IH by auto
  qed
qed

subsection \<open>\<omega> - The Smallest Limit Ordinal\<close>

thm omega_typ

lemma omega_ord : "\<omega> : Ord" by (rule limit_ord[OF omega_typ])
lemma omega_zero : "0 < \<omega>" by (rule limit_lt_zero[OF omega_typ])

lemma omega_succ :
  assumes i:"i : Ord"
  shows "i < \<omega> \<Longrightarrow> succ i < \<omega>"
  by (rule limit_lt_succ[OF omega_typ i])

(* lemma omega_one : "1 < \<omega>" unfolding one_def
  by (rule omega_succ[OF zero_typ omega_zero]) *)

lemma omega_lt_cases :
  assumes i:"i : Ord" and lt:"i < \<omega>"
  obtains (zero) "i = 0" | (succ) j where "j : Ord" "i = succ j"
proof (rule ord_cases[OF i], auto, rule ccontr)
  assume "i : Limit" hence "\<omega> < i"
    using lt_neq[OF i omega_ord lt] omega_ax by auto
  thus "False" using lt asym[OF i omega_ord] by auto
qed

lemma omega_lt_not_limit :
  assumes i:"i : Ord" and lt:"i < \<omega>"
  shows "\<not> i : Limit"
  by (rule omega_lt_cases[OF i lt],
      use not_zero_limit not_succ_limit in auto)

subsection \<open>Least Ordinal operator\<close>

definition least :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder \<open>least \<close> 10)
  where "least x. P x \<equiv> \<iota> i. i : Ord \<and> P i \<and> (\<forall>j : Ord. j < i \<longrightarrow> \<not> P j) else Ordinal_default"

lemma least_eq :
  assumes i:"i : Ord" and "P i"
    and lt:"\<And>j. j : Ord \<Longrightarrow> j < i \<Longrightarrow> \<not> P j"
  shows "(least i. P i) = i" unfolding least_def
proof (rule the_def_eq, use assms in auto)
  fix k assume k:"k : Ord" and "P k" and j:"\<forall>j. j : Ord \<longrightarrow> j < k \<longrightarrow> \<not> P j"
  show "k = i" by (rule linear[OF k i], use i k \<open>P i\<close> \<open>P k\<close> lt j in auto)
qed

lemma least_ord :
  assumes i:"i : Ord"
  shows "P i \<Longrightarrow> (least i. P i) : Ord"
proof (induct rule: trans_induct[OF i])
  fix j assume j:"j : Ord" and "P j"
  and k:"\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> P k \<Longrightarrow> (least i. P i) : Ord"
  show "(least i. P i) : Ord"
  proof (cases "(least i. P i) : Ord")
    case True
    then show ?thesis .
  next
    case False
    hence "\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> \<not> P k" using k by auto
    hence "(least i. P i) = j" using k least_eq[OF j, of P, OF \<open>P j\<close>] by auto
    then show ?thesis using \<open>j : Ord\<close> by auto
  qed
qed

lemma leastI :
  assumes i:"i : Ord"
  shows "P i \<Longrightarrow> P (least i. P i)"
proof (induct rule: trans_induct[OF i])
  fix j assume j:"j : Ord" and "P j"
  and k:"\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> P k \<Longrightarrow> P (least i. P i)"
  show "P (least i. P i)"
  proof (cases "P (least i. P i)")
    case True
    then show ?thesis .
  next
    case False
    hence "\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> \<not> P k" using k by auto
    hence "(least i. P i) = j" using k least_eq[OF j, of P, OF \<open>P j\<close>] by auto
    then show ?thesis using \<open>P j\<close> by auto
  qed
qed

(*MESSY PROOF: needs tidying*)
lemma least_leqI :
  assumes i:"i : Ord"
  shows "P i \<Longrightarrow> (least i. P i) \<le> i"
proof (induct rule: trans_induct[OF i])
  fix j assume j:"j : Ord" and "P j"
  and k : "\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> P k \<Longrightarrow> (least i. P i) \<le> k"
  show "(least i. P i) \<le> j"
  proof (cases "(least i. P i) \<le> j")
    case True
    then show ?thesis .
  next
    case False
    hence kj: "\<And>k. k : Ord \<Longrightarrow> k < j \<Longrightarrow> \<not> (least i. P i) \<le> j" using k by auto
    have "(least i. P i) = j"
    proof (rule least_eq[OF j, of P, OF \<open>P j\<close>])
      fix k assume "k : Ord" "k < j"
      hence lj:"\<not> (least i. P i) \<le> j" using kj by auto
      show "\<not> P k" proof
        assume "P k" hence l:"(least i. P i) : Ord" using least_ord[OF \<open>k : Ord\<close>] by auto
        have pk:"(least i. P i) \<le> k" using k[OF \<open>k : Ord\<close> \<open>k < j\<close> \<open>P k\<close>] by auto
        show "False" using leqI1[OF l j lt_trans1[OF l \<open>k : Ord\<close> j pk \<open>k < j\<close>]] lj by auto
      qed
    qed
    then show ?thesis using leq_refl[OF j] by auto
  qed
qed

lemma lt_leastE :
  assumes i:"i : Ord" and "P i"
    and lt : "i < (least i. P i)"
  shows "Q"
  using lt_trans2[OF i least_ord[OF i, of P, OF \<open>P i\<close>] i lt least_leqI[OF i, of P, OF \<open>P i\<close>]]
        not_refl[OF i]
  by auto

(*Easier to apply than leastI: conclusion has only one occurrence of P*)
lemma leastI2 :
  assumes i:"i : Ord" and "P i"
  and lt: "\<And>j. j : Ord \<Longrightarrow> P j \<Longrightarrow> Q j"
  shows "Q (least j. P j)"
  by (rule lt[OF least_ord[of i P, OF i \<open>P i\<close>]
                 leastI[of i P, OF i \<open>P i\<close>]])

lemma least_default :
  "\<not> (\<exists>i : Ord. P i) \<Longrightarrow> (least i. P i) = Ordinal_default"
  unfolding least_def tex_def
  by (rule the_def_default, auto)

subsection \<open>Ordinal case operator\<close>

definition caseof_ord :: \<open>['a, 'a, 'a, 'a] \<Rightarrow> 'a\<close>
  where "caseof_ord z s l i \<equiv>
    if i = 0 then z else
      if (\<exists>j : Ord. i = succ j) then s else
        if i : Limit then l else Ordinal_default"

lemma case_ord_zero :
  "caseof_ord b f g 0 = b"
  unfolding caseof_ord_def by auto

lemma case_ord_succ :
  assumes j:"j : Ord"
  shows "caseof_ord b s l (succ j) = s"
  unfolding caseof_ord_def
  using succ_nonzero[OF j] not_succ_limit[OF j] j by auto

lemma case_ord_lim :
  assumes u:"u : Limit"
  shows "caseof_ord b s l u = l"
  unfolding caseof_ord_def
  using limit_nonzero u not_succ_limit by auto

lemma case_ordE :
  assumes i: "i : Ord" and
    "P z" "P s" "P l"
  shows "P (caseof_ord z s l i)"
  using ord_cases[OF i] case_ord_zero case_ord_succ case_ord_lim assms
  by metis
end

ML \<open>fun mk_ord_thm z _ 0 = z
      | mk_ord_thm z s n = s OF [mk_ord_thm z s (n-1)]\<close>

ML \<open>fun n_ord_thm 0 = @{thm zero_ord}
      | n_ord_thm n = @{thm succ_ord} OF [n_ord_thm (n-1)]\<close>

ML \<open>fun omega_lt_thm 0 = @{thm omega_zero}
      | omega_lt_thm n = @{thm omega_succ} OF [n_ord_thm (n-1), omega_lt_thm (n-1)]\<close>

ML \<open>fun leq_thm (i,j) =
      if j < i then error "j<i" else
      if i = j
      then @{thm leq_refl} OF [n_ord_thm i]
      else if i+1 = j
        then @{thm succ_leq} OF [n_ord_thm i]
        else @{thm leq_trans2} OF [n_ord_thm i, n_ord_thm (i+1), n_ord_thm j,
                  leq_thm (i,i+1), leq_thm (i+1,j)]\<close>

lemmas if_P_trans = HOL.trans[OF if_not_P]

ML \<open>fun neq_thm (i,j) = not_sym OF [@{thm lt_neq} OF [n_ord_thm j, n_ord_thm i, leq_thm (j,i-1)]] \<close>
ML \<open>fun if_thm' _ 0 = @{thm if_P} OF [@{thm refl}]
      | if_thm' i k = @{thm if_P_trans} OF [neq_thm (i,i-k), if_thm' i (k-1)]\<close>
ML \<open>fun if_thm i = if_thm' i i\<close>

end