(*  Title:      CCL/Lfp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>The Knaster-Tarski Theorem\<close>

theory Lfp
imports Set
begin

definition
  lfp :: "['a set\<Rightarrow>'a set] \<Rightarrow> 'a set" where \<comment> \<open>least fixed point\<close>
  "lfp(f) == Inter({u. f(u) <= u})"

(* lfp(f) is the greatest lower bound of {u. f(u) <= u} *)

lemma lfp_lowerbound: "f(A) <= A \<Longrightarrow> lfp(f) <= A"
  unfolding lfp_def by blast

lemma lfp_greatest: "(\<And>u. f(u) <= u \<Longrightarrow> A<=u) \<Longrightarrow> A <= lfp(f)"
  unfolding lfp_def by blast

lemma lfp_lemma2: "mono(f) \<Longrightarrow> f(lfp(f)) <= lfp(f)"
  by (rule lfp_greatest, rule subset_trans, drule monoD, rule lfp_lowerbound, assumption+)

lemma lfp_lemma3: "mono(f) \<Longrightarrow> lfp(f) <= f(lfp(f))"
  by (rule lfp_lowerbound, frule monoD, drule lfp_lemma2, assumption+)

lemma lfp_Tarski: "mono(f) \<Longrightarrow> lfp(f) = f(lfp(f))"
  by (rule equalityI lfp_lemma2 lfp_lemma3 | assumption)+

(*** General induction rule for least fixed points ***)

lemma induct:
  assumes lfp: "a: lfp(f)"
    and mono: "mono(f)"
    and indhyp: "\<And>x. \<lbrakk>x: f(lfp(f) Int {x. P(x)})\<rbrakk> \<Longrightarrow> P(x)"
  shows "P(a)"
  apply (rule_tac a = a in Int_lower2 [THEN subsetD, THEN CollectD])
  apply (rule lfp [THEN [2] lfp_lowerbound [THEN subsetD]])
  apply (rule Int_greatest, rule subset_trans, rule Int_lower1 [THEN mono [THEN monoD]],
    rule mono [THEN lfp_lemma2], rule CollectI [THEN subsetI], rule indhyp, assumption)
  done

(** Definition forms of lfp_Tarski and induct, to control unfolding **)

lemma def_lfp_Tarski: "\<lbrakk>h == lfp(f); mono(f)\<rbrakk> \<Longrightarrow> h = f(h)"
  apply unfold
  apply (drule lfp_Tarski)
  apply assumption
  done

lemma def_induct: "\<lbrakk>A == lfp(f);  a:A;  mono(f); \<And>x. x: f(A Int {x. P(x)}) \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> P(a)"
  apply (rule induct [of concl: P a])
    apply simp
   apply assumption
  apply blast
  done

(*Monotonicity of lfp!*)
lemma lfp_mono: "\<lbrakk>mono(g); \<And>Z. f(Z) <= g(Z)\<rbrakk> \<Longrightarrow> lfp(f) <= lfp(g)"
  apply (rule lfp_lowerbound)
  apply (rule subset_trans)
   apply (erule meta_spec)
  apply (erule lfp_lemma2)
  done

end


(*
  File:      HOL/Computational_Algebra/Nth_Powers.thy
  Author:    Manuel Eberl <eberlm@in.tum.de>

  n-th powers in general and n-th roots of natural numbers
*)
section \<open>$n$-th powers and roots of naturals\<close>
theory Nth_Powers
  imports Primes
begin

subsection \<open>The set of $n$-th powers\<close>

definition is_nth_power :: "nat \<Rightarrow> 'a :: monoid_mult \<Rightarrow> bool" where
  "is_nth_power n x \<longleftrightarrow> (\<exists>y. x = y ^ n)"

lemma is_nth_power_nth_power [simp, intro]: "is_nth_power n (x ^ n)"
  by (auto simp add: is_nth_power_def)

lemma is_nth_powerI [intro?]: "x = y ^ n \<Longrightarrow> is_nth_power n x"
  by (auto simp: is_nth_power_def)

lemma is_nth_powerE: "is_nth_power n x \<Longrightarrow> (\<And>y. x = y ^ n \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp: is_nth_power_def)

abbreviation is_square where "is_square \<equiv> is_nth_power 2"

lemma is_zeroth_power [simp]: "is_nth_power 0 x \<longleftrightarrow> x = 1"
  by (simp add: is_nth_power_def)

lemma is_first_power [simp]: "is_nth_power 1 x"
  by (simp add: is_nth_power_def)

lemma is_first_power' [simp]: "is_nth_power (Suc 0) x"
  by (simp add: is_nth_power_def)

lemma is_nth_power_0 [simp]: "n > 0 \<Longrightarrow> is_nth_power n (0 :: 'a :: semiring_1)"
  by (auto simp: is_nth_power_def power_0_left intro!: exI[of _ 0])

lemma is_nth_power_0_iff [simp]: "is_nth_power n (0 :: 'a :: semiring_1) \<longleftrightarrow> n > 0"
  by (cases n) auto

lemma is_nth_power_1 [simp]: "is_nth_power n 1"
  by (auto simp: is_nth_power_def intro!: exI[of _ 1])

lemma is_nth_power_Suc_0 [simp]: "is_nth_power n (Suc 0)"
  by (simp add: One_nat_def [symmetric] del: One_nat_def)

lemma is_nth_power_conv_multiplicity:
  fixes x :: "'a :: {factorial_semiring, normalization_semidom_multiplicative}"
  assumes "n > 0"
  shows   "is_nth_power n (normalize x) \<longleftrightarrow> (\<forall>p. prime p \<longrightarrow> n dvd multiplicity p x)"
proof (cases "x = 0")
  case False
  show ?thesis
  proof (safe intro!: is_nth_powerI elim!: is_nth_powerE)
    fix y p :: 'a assume *: "normalize x = y ^ n" "prime p"
    with assms and False have [simp]: "y \<noteq> 0" by (auto simp: power_0_left)
    have "multiplicity p x = multiplicity p (y ^ n)"
      by (subst *(1) [symmetric]) simp
    with False and * and assms show "n dvd multiplicity p x"
      by (auto simp: prime_elem_multiplicity_power_distrib)
  next
    assume *: "\<forall>p. prime p \<longrightarrow> n dvd multiplicity p x"
    have "multiplicity p ((\<Prod>p\<in>prime_factors x. p ^ (multiplicity p x div n)) ^ n) =
            multiplicity p x" if "prime p" for p
    proof -
      from that and * have "n dvd multiplicity p x" by blast
      have "multiplicity p x = 0" if "p \<notin> prime_factors x"
        using that and \<open>prime p\<close> by (simp add: prime_factors_multiplicity)
      with that and * and assms show ?thesis unfolding prod_power_distrib power_mult [symmetric]
        by (subst multiplicity_prod_prime_powers) (auto simp: in_prime_factors_imp_prime elim: dvdE)
    qed
    with assms False
      have "normalize x = normalize ((\<Prod>p\<in>prime_factors x. p ^ (multiplicity p x div n)) ^ n)"
      by (intro multiplicity_eq_imp_eq) (auto simp: multiplicity_prod_prime_powers)
    thus "normalize x = normalize (\<Prod>p\<in>prime_factors x. p ^ (multiplicity p x div n)) ^ n"
      by (simp add: normalize_power)
  qed
qed (insert assms, auto)

lemma is_nth_power_conv_multiplicity_nat:
  assumes "n > 0"
  shows   "is_nth_power n (x :: nat) \<longleftrightarrow> (\<forall>p. prime p \<longrightarrow> n dvd multiplicity p x)"
  using is_nth_power_conv_multiplicity[OF assms, of x] by simp

lemma is_nth_power_mult:
  assumes "is_nth_power n a" "is_nth_power n b"
  shows   "is_nth_power n (a * b :: 'a :: comm_monoid_mult)"
proof -
  from assms obtain a' b' where "a = a' ^ n" "b = b' ^ n" by (auto elim!: is_nth_powerE)
  hence "a * b = (a' * b') ^ n" by (simp add: power_mult_distrib)
  thus ?thesis by (rule is_nth_powerI)
qed

lemma is_nth_power_mult_coprime_natD:
  fixes a b :: nat
  assumes "coprime a b" "is_nth_power n (a * b)" "a > 0" "b > 0"
  shows   "is_nth_power n a" "is_nth_power n b"
proof -
  have A: "is_nth_power n a" if "coprime a b" "is_nth_power n (a * b)" "a \<noteq> 0" "b \<noteq> 0" "n > 0"
    for a b :: nat unfolding is_nth_power_conv_multiplicity_nat[OF \<open>n > 0\<close>]
  proof safe
    fix p :: nat assume p: "prime p"
    from \<open>coprime a b\<close> have "\<not>(p dvd a \<and> p dvd b)"
      using coprime_common_divisor_nat[of a b p] p by auto
    moreover from that and p
      have "n dvd multiplicity p a + multiplicity p b"
      by (auto simp: is_nth_power_conv_multiplicity_nat prime_elem_multiplicity_mult_distrib)
    ultimately show "n dvd multiplicity p a"
      by (auto simp: not_dvd_imp_multiplicity_0)
  qed
  from A [of a b] assms show "is_nth_power n a"
    by (cases "n = 0") simp_all
  from A [of b a] assms show "is_nth_power n b"
    by (cases "n = 0") (simp_all add: ac_simps)
qed

lemma is_nth_power_mult_coprime_nat_iff:
  fixes a b :: nat
  assumes "coprime a b"
  shows   "is_nth_power n (a * b) \<longleftrightarrow> is_nth_power n a \<and>is_nth_power n b"
  using assms
  by (cases "a = 0"; cases "b = 0")
     (auto intro: is_nth_power_mult dest: is_nth_power_mult_coprime_natD[of a b n]
           simp del: One_nat_def)

lemma is_nth_power_prime_power_nat_iff:
  fixes p :: nat assumes "prime p"
  shows "is_nth_power n (p ^ k) \<longleftrightarrow> n dvd k"
  using assms
  by (cases "n > 0")
     (auto simp: is_nth_power_conv_multiplicity_nat prime_elem_multiplicity_power_distrib)

lemma is_nth_power_nth_power':
  assumes "n dvd n'"
  shows   "is_nth_power n (m ^ n')"
proof -
  from assms have "n' = n' div n * n" by simp
  also have "m ^ \<dots> = (m ^ (n' div n)) ^ n" by (simp add: power_mult)
  also have "is_nth_power n \<dots>" by simp
  finally show ?thesis .
qed

definition is_nth_power_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  where [code_abbrev]: "is_nth_power_nat = is_nth_power"

lemma is_nth_power_nat_code [code]:
  "is_nth_power_nat n m =
     (if n = 0 then m = 1
      else if m = 0 then n > 0
      else if n = 1 then True
      else (\<exists>k\<in>{1..m}. k ^ n = m))"
  by (auto simp: is_nth_power_nat_def is_nth_power_def power_eq_iff_eq_base self_le_power)

(* TODO: Harmonise with Discrete.sqrt *)

subsection \<open>The $n$-root of a natural number\<close>

definition nth_root_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_root_nat k n = (if k = 0 then 0 else Max {m. m ^ k \<le> n})"

lemma zeroth_root_nat [simp]: "nth_root_nat 0 n = 0"
  by (simp add: nth_root_nat_def)

lemma nth_root_nat_aux1:
  assumes "k > 0"
  shows   "{m::nat. m ^ k \<le> n} \<subseteq> {..n}"
proof safe
  fix m assume "m ^ k \<le> n"
  show "m \<le> n"
  proof (cases "m = 0")
    case False
    with assms have "m ^ 1 \<le> m ^ k" by (intro power_increasing) simp_all
    also note \<open>m ^ k \<le> n\<close>
    finally show ?thesis by simp
  qed simp_all
qed

lemma nth_root_nat_aux2:
  assumes "k > 0"
  shows   "finite {m::nat. m ^ k \<le> n}" "{m::nat. m ^ k \<le> n} \<noteq> {}"
proof -
  from assms have "{m. m ^ k \<le> n} \<subseteq> {..n}" by (rule nth_root_nat_aux1)
  moreover have "finite {..n}" by simp
  ultimately show "finite {m::nat. m ^ k \<le> n}" by (rule finite_subset)
next
  from assms show "{m::nat. m ^ k \<le> n} \<noteq> {}" by (auto intro!: exI[of _ 0] simp: power_0_left)
qed

lemma
  assumes "k > 0"
  shows   nth_root_nat_power_le: "nth_root_nat k n ^ k \<le> n"
    and   nth_root_nat_ge: "x ^ k \<le> n \<Longrightarrow> x \<le> nth_root_nat k n"
  using Max_in[OF nth_root_nat_aux2[OF assms], of n]
        Max_ge[OF nth_root_nat_aux2(1)[OF assms], of x n] assms
  by (auto simp: nth_root_nat_def)

lemma nth_root_nat_less:
  assumes "k > 0" "x ^ k > n"
  shows   "nth_root_nat k n < x"
proof -
  from \<open>k > 0\<close> have "nth_root_nat k n ^ k \<le> n" by (rule nth_root_nat_power_le)
  also have "n < x ^ k" by fact
  finally show ?thesis by (rule power_less_imp_less_base) simp_all
qed

lemma nth_root_nat_unique:
  assumes "m ^ k \<le> n" "(m + 1) ^ k > n"
  shows   "nth_root_nat k n = m"
proof (cases "k > 0")
  case True
  from nth_root_nat_less[OF \<open>k > 0\<close> assms(2)]
    have "nth_root_nat k n \<le> m" by simp
  moreover from \<open>k > 0\<close> and assms(1) have "nth_root_nat k n \<ge> m"
    by (intro nth_root_nat_ge)
  ultimately show ?thesis by (rule antisym)
qed (insert assms, auto)

lemma nth_root_nat_0 [simp]: "nth_root_nat k 0 = 0" by (simp add: nth_root_nat_def)
lemma nth_root_nat_1 [simp]: "k > 0 \<Longrightarrow> nth_root_nat k 1 = 1"
  by (rule nth_root_nat_unique) (auto simp del: One_nat_def)
lemma nth_root_nat_Suc_0 [simp]: "k > 0 \<Longrightarrow> nth_root_nat k (Suc 0) = Suc 0"
  using nth_root_nat_1 by (simp del: nth_root_nat_1)

lemma first_root_nat [simp]: "nth_root_nat 1 n = n"
  by (intro nth_root_nat_unique) auto

lemma first_root_nat' [simp]: "nth_root_nat (Suc 0) n = n"
  by (intro nth_root_nat_unique) auto

lemma nth_root_nat_code_naive':
  "nth_root_nat k n = (if k = 0 then 0 else Max (Set.filter (\<lambda>m. m ^ k \<le> n) {..n}))"
proof (cases "k > 0")
  case True
  hence "{m. m ^ k \<le> n} \<subseteq> {..n}" by (rule nth_root_nat_aux1)
  hence "Set.filter (\<lambda>m. m ^ k \<le> n) {..n} = {m. m ^ k \<le> n}"
    by (auto simp: Set.filter_def)
  with True show ?thesis by (simp add: nth_root_nat_def Set.filter_def)
qed simp

function nth_root_nat_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_root_nat_aux m k acc n =
     (let acc' = (k + 1) ^ m
      in  if k \<ge> n \<or> acc' > n then k else nth_root_nat_aux m (k+1) acc' n)"
  by auto
termination by (relation "measure (\<lambda>(_,k,_,n). n - k)", goal_cases) auto

lemma nth_root_nat_aux_le:
  assumes "k ^ m \<le> n" "m > 0"
  shows   "nth_root_nat_aux m k (k ^ m) n ^ m \<le> n"
  using assms
  by (induction m k "k ^ m" n rule:  nth_root_nat_aux.induct) (auto simp: Let_def)

lemma nth_root_nat_aux_gt:
  assumes "m > 0"
  shows   "(nth_root_nat_aux m k (k ^ m) n + 1) ^ m > n"
  using assms
proof (induction m k "k ^ m" n rule:  nth_root_nat_aux.induct)
  case (1 m k n)
  have "n < Suc k ^ m" if "n \<le> k"
  proof -
    note that
    also have "k < Suc k ^ 1" by simp
    also from \<open>m > 0\<close> have "\<dots> \<le> Suc k ^ m" by (intro power_increasing) simp_all
    finally show ?thesis .
  qed
  with 1 show ?case by (auto simp: Let_def)
qed

lemma nth_root_nat_aux_correct:
  assumes "k ^ m \<le> n" "m > 0"
  shows   "nth_root_nat_aux m k (k ^ m) n = nth_root_nat m n"
  by (rule sym, intro nth_root_nat_unique nth_root_nat_aux_le nth_root_nat_aux_gt assms)

lemma nth_root_nat_naive_code [code]:
  "nth_root_nat m n = (if m = 0 \<or> n = 0 then 0 else if m = 1 \<or> n = 1 then n else
                        nth_root_nat_aux m 1 1 n)"
  using nth_root_nat_aux_correct[of 1 m n] by (auto simp: )

lemma nth_root_nat_nth_power [simp]: "k > 0 \<Longrightarrow> nth_root_nat k (n ^ k) = n"
  by (intro nth_root_nat_unique order.refl power_strict_mono) simp_all

lemma nth_root_nat_nth_power':
  assumes "k > 0" "k dvd m"
  shows   "nth_root_nat k (n ^ m) = n ^ (m div k)"
proof -
  from assms have "m = (m div k) * k" by simp
  also have "n ^ \<dots> = (n ^ (m div k)) ^ k" by (simp add: power_mult)
  also from assms have "nth_root_nat k \<dots> = n ^ (m div k)" by simp
  finally show ?thesis .
qed

lemma nth_root_nat_mono:
  assumes "m \<le> n"
  shows   "nth_root_nat k m \<le> nth_root_nat k n"
proof (cases "k = 0")
  case False
  with assms show ?thesis unfolding nth_root_nat_def
    using nth_root_nat_aux2[of k m] nth_root_nat_aux2[of k n]
    by (auto intro!: Max_mono)
qed auto

end


(* ---------------------------------------------------------------------------- *)
section \<open>Unit circle preserving Möbius transformations\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>In this section we shall examine Möbius transformations that map the unit circle onto itself.
We shall say that they fix or preserve the unit circle (although, they do not need to fix each of
its points).\<close>

theory Unit_Circle_Preserving_Moebius
imports Unitary11_Matrices Moebius Oriented_Circlines
begin

(* ---------------------------------------------------------------------------- *)
subsection \<open>Möbius transformations that fix the unit circle\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>We define Möbius transformations that preserve unit circle as transformations represented by
generalized unitary matrices with the $1-1$ signature (elements of the gruop $GU_{1,1}(2,
\mathbb{C})$, defined earlier in the theory Unitary11Matrices).\<close>

lift_definition unit_circle_fix_mmat :: "moebius_mat \<Rightarrow> bool" is unitary11_gen
  done

lift_definition unit_circle_fix :: "moebius \<Rightarrow> bool" is unit_circle_fix_mmat
  apply transfer
  apply (auto simp del: mult_sm.simps)
  apply (simp del: mult_sm.simps add: unitary11_gen_mult_sm)
  apply (simp del: mult_sm.simps add: unitary11_gen_div_sm)
  done

text \<open>Our algebraic characterisation (by matrices) is geometrically correct.\<close>

lemma unit_circle_fix_iff:
  shows "unit_circle_fix M \<longleftrightarrow>
         moebius_circline M unit_circle = unit_circle" (is "?rhs = ?lhs")
proof
  assume ?lhs
  thus ?rhs
  proof (transfer, transfer)
    fix M :: complex_mat
    assume "mat_det M \<noteq> 0"
    assume "circline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
    then obtain k where "k \<noteq> 0" "(1, 0, 0, -1) = cor k *\<^sub>s\<^sub>m congruence (mat_inv M) (1, 0, 0, -1)"
      by auto
    hence "(1/cor k, 0, 0, -1/cor k) = congruence (mat_inv M) (1, 0, 0, -1)"
      using mult_sm_inv_l[of "cor k" "congruence (mat_inv M) (1, 0, 0, -1)" ]
      by simp
    hence "congruence M (1/cor k, 0, 0, -1/cor k) = (1, 0, 0, -1)"
      using \<open>mat_det M \<noteq> 0\<close> mat_det_inv[of M]
      using congruence_inv[of "mat_inv M" "(1, 0, 0, -1)" "(1/cor k, 0, 0, -1/cor k)"]
      by simp
    hence "congruence M (1, 0, 0, -1) = cor k *\<^sub>s\<^sub>m (1, 0, 0, -1)"
      using congruence_scale_m[of "M" "1/cor k" "(1, 0, 0, -1)"]
      using mult_sm_inv_l[of "1/ cor k" "congruence M (1, 0, 0, -1)"  "(1, 0, 0, -1)"] \<open>k \<noteq> 0\<close>
      by simp
    thus "unitary11_gen M"
      using \<open>k \<noteq> 0\<close>
      unfolding unitary11_gen_def
      by simp
  qed
next
  assume ?rhs
  thus ?lhs
  proof (transfer, transfer)
    fix M :: complex_mat
    assume "mat_det M \<noteq> 0"
    assume "unitary11_gen M"
    hence "unitary11_gen (mat_inv M)"
      using \<open>mat_det M \<noteq> 0\<close>
      using unitary11_gen_mat_inv
      by simp
    thus " circline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
      unfolding unitary11_gen_real
      by auto (rule_tac x="1/k" in exI, simp)
  qed
qed

lemma circline_set_fix_iff_circline_fix:
  assumes "circline_set H' \<noteq> {}"
  shows "circline_set (moebius_circline M H) = circline_set H' \<longleftrightarrow>
         moebius_circline M H = H'"
  using assms
  by auto (rule inj_circline_set, auto)

lemma unit_circle_fix_iff_unit_circle_set:
  shows "unit_circle_fix M \<longleftrightarrow> moebius_pt M ` unit_circle_set = unit_circle_set"
proof-
  have "circline_set unit_circle \<noteq> {}"
    using one_in_unit_circle_set
    by auto
  thus ?thesis
    using unit_circle_fix_iff[of M] circline_set_fix_iff_circline_fix[of unit_circle M unit_circle]
    by (simp add: unit_circle_set_def)
qed

text \<open>Unit circle preserving Möbius transformations form a group. \<close>

lemma unit_circle_fix_id_moebius [simp]:
  shows "unit_circle_fix id_moebius"
  by (transfer, transfer, simp add: unitary11_gen_def mat_adj_def mat_cnj_def)

lemma unit_circle_fix_moebius_add [simp]:
  assumes "unit_circle_fix M1" and "unit_circle_fix M2"
  shows "unit_circle_fix (M1 + M2)"
  using assms
  unfolding unit_circle_fix_iff
  by auto

lemma unit_circle_fix_moebius_comp [simp]:
  assumes "unit_circle_fix M1" and "unit_circle_fix M2"
  shows "unit_circle_fix (moebius_comp M1 M2)"
  using unit_circle_fix_moebius_add[OF assms]
  by simp

lemma unit_circle_fix_moebius_uminus [simp]:
  assumes "unit_circle_fix M"
  shows "unit_circle_fix (-M)"
  using assms
  unfolding unit_circle_fix_iff
  by (metis moebius_circline_comp_inv_left uminus_moebius_def)

lemma unit_circle_fix_moebius_inv [simp]:
  assumes "unit_circle_fix M"
  shows "unit_circle_fix (moebius_inv M)"
  using unit_circle_fix_moebius_uminus[OF assms]
  by simp

text \<open>Unit circle fixing transforms preserve inverse points.\<close>

lemma unit_circle_fix_moebius_pt_inversion [simp]:
  assumes "unit_circle_fix M"
  shows "moebius_pt M (inversion z) = inversion (moebius_pt M z)"
  using assms
  using symmetry_principle[of z "inversion z" unit_circle M]
  using unit_circle_fix_iff[of M, symmetric]
  using circline_symmetric_inv_homo_disc[of z]
  using circline_symmetric_inv_homo_disc'[of "moebius_pt M z" "moebius_pt M (inversion z)"]
  by metis

(* -------------------------------------------------------------------------- *)
subsection \<open>Möbius transformations that fix the imaginary unit circle\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Only for completeness we show that Möbius transformations that preserve the imaginary unit
circle are exactly those characterised by generalized unitary matrices (with the (2, 0) signature).\<close>
lemma imag_unit_circle_fixed_iff_unitary_gen:
  assumes "mat_det (A, B, C, D) \<noteq> 0"
  shows "moebius_circline (mk_moebius A B C D) imag_unit_circle = imag_unit_circle \<longleftrightarrow>
         unitary_gen (A, B, C, D)" (is "?lhs = ?rhs")
proof
  assume ?lhs
  thus ?rhs
    using assms
  proof (transfer, transfer)
    fix A B C D :: complex
    let ?M = "(A, B, C, D)" and ?E = "(1, 0, 0, 1)"
    assume "circline_eq_cmat (moebius_circline_cmat_cmat (mk_moebius_cmat A B C D) imag_unit_circle_cmat) imag_unit_circle_cmat"
           "mat_det ?M \<noteq> 0"
    then obtain k where "k \<noteq> 0" "?E = cor k *\<^sub>s\<^sub>m congruence (mat_inv ?M) ?E"
      by auto
    hence "unitary_gen (mat_inv ?M)"
      using mult_sm_inv_l[of "cor k" "congruence (mat_inv ?M) ?E" "?E"]
      unfolding unitary_gen_def
      by (metis congruence_def divide_eq_0_iff eye_def mat_eye_r of_real_eq_0_iff one_neq_zero)
    thus "unitary_gen ?M"
      using unitary_gen_inv[of "mat_inv ?M"] \<open>mat_det ?M \<noteq> 0\<close>
      by (simp del: mat_inv.simps)
  qed
next
  assume ?rhs
  thus ?lhs
    using assms
  proof (transfer, transfer)
    fix A B C D :: complex
    let ?M = "(A, B, C, D)" and ?E = "(1, 0, 0, 1)"
    assume "unitary_gen ?M" "mat_det ?M \<noteq> 0"
    hence "unitary_gen (mat_inv ?M)"
      using unitary_gen_inv[of ?M]
      by simp
    then obtain k where "k \<noteq> 0" "mat_adj (mat_inv ?M) *\<^sub>m\<^sub>m (mat_inv ?M) = cor k *\<^sub>s\<^sub>m eye"
      using unitary_gen_real[of "mat_inv ?M"] mat_det_inv[of ?M]
      by auto
    hence *: "?E = (1 / cor k) *\<^sub>s\<^sub>m (mat_adj (mat_inv ?M) *\<^sub>m\<^sub>m (mat_inv ?M))"
      using mult_sm_inv_l[of "cor k" eye "mat_adj (mat_inv ?M) *\<^sub>m\<^sub>m (mat_inv ?M)"]
      by simp
    have "\<exists>k. k \<noteq> 0 \<and>
            (1, 0, 0, 1) = cor k *\<^sub>s\<^sub>m (mat_adj (mat_inv (A, B, C, D)) *\<^sub>m\<^sub>m (1, 0, 0, 1) *\<^sub>m\<^sub>m mat_inv (A, B, C, D))"
      using \<open>mat_det ?M \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
      by (metis "*" Im_complex_of_real Re_complex_of_real \<open>mat_adj (mat_inv ?M) *\<^sub>m\<^sub>m mat_inv ?M = cor k *\<^sub>s\<^sub>m eye\<close> complex_of_real_Re eye_def mat_eye_l mult_mm_assoc mult_mm_sm mult_sm_eye_mm of_real_1 of_real_divide of_real_eq_1_iff zero_eq_1_divide_iff)
    thus "circline_eq_cmat (moebius_circline_cmat_cmat (mk_moebius_cmat A B C D) imag_unit_circle_cmat) imag_unit_circle_cmat"
      using \<open>mat_det ?M \<noteq> 0\<close> \<open>k \<noteq> 0\<close>
      by (simp del: mat_inv.simps)
  qed
qed

(* -------------------------------------------------------------------------- *)
subsection \<open>Möbius transformations that fix the oriented unit circle and the unit disc\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Möbius transformations that fix the unit circle either map the unit disc onto itself or
exchange it with its exterior. The transformations that fix the unit disc can be recognized from
their matrices -- they have the form as before, but additionally it must hold that $|a|^2 > |b|^2$.\<close>

definition unit_disc_fix_cmat :: "complex_mat \<Rightarrow> bool" where
 [simp]: "unit_disc_fix_cmat M \<longleftrightarrow>
          (let (A, B, C, D) = M
            in unitary11_gen (A, B, C, D) \<and> (B = 0 \<or> Re ((A*D)/(B*C)) > 1))"

lift_definition unit_disc_fix_mmat :: "moebius_mat \<Rightarrow> bool" is unit_disc_fix_cmat
  done

lift_definition unit_disc_fix :: "moebius \<Rightarrow> bool" is unit_disc_fix_mmat
proof transfer
  fix M M' :: complex_mat
  assume det: "mat_det M \<noteq> 0" "mat_det M' \<noteq> 0"
  assume "moebius_cmat_eq M M'"
  then obtain k where *: "k \<noteq> 0" "M' = k *\<^sub>s\<^sub>m M"
    by auto
  hence **: "unitary11_gen M \<longleftrightarrow> unitary11_gen M'"
    using unitary11_gen_mult_sm[of k M] unitary11_gen_div_sm[of k M]
    by auto
  obtain A B C D where MM: "(A, B, C, D) = M"
    by (cases M) auto
  obtain A' B' C' D' where MM': "(A', B', C', D') = M'"
    by (cases M') auto

  show "unit_disc_fix_cmat M = unit_disc_fix_cmat M'"
    using * ** MM MM'
    by auto
qed

text \<open>Transformations that fix the unit disc also fix the unit circle.\<close>
lemma unit_disc_fix_unit_circle_fix [simp]:
  assumes "unit_disc_fix M"
  shows "unit_circle_fix M"
  using assms
  by (transfer, transfer, auto)

text \<open>Transformations that preserve the unit disc preserve the orientation of the unit circle.\<close>
lemma unit_disc_fix_iff_ounit_circle:
  shows "unit_disc_fix M \<longleftrightarrow>
         moebius_ocircline M ounit_circle = ounit_circle" (is "?rhs \<longleftrightarrow> ?lhs")
proof
  assume *: ?lhs
  have "moebius_circline M unit_circle = unit_circle"
    apply (subst moebius_circline_ocircline[of M unit_circle])
    apply (subst of_circline_unit_circle)
    apply (subst *)
    by simp

  hence "unit_circle_fix M"
    by (simp add: unit_circle_fix_iff)
  thus ?rhs
    using *
  proof (transfer, transfer)
    fix M :: complex_mat
    assume "mat_det M \<noteq> 0"
    let ?H = "(1, 0, 0, -1)"
    obtain A B C D where MM: "(A, B, C, D) = M"
      by (cases M) auto
    assume "unitary11_gen M" "ocircline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
    then obtain k where "0 < k" "?H = cor k *\<^sub>s\<^sub>m congruence (mat_inv M) ?H"
      by auto
    hence "congruence M ?H = cor k *\<^sub>s\<^sub>m ?H"
      using congruence_inv[of "mat_inv M" "?H" "(1/cor k) *\<^sub>s\<^sub>m ?H"] \<open>mat_det M \<noteq> 0\<close>
      using mult_sm_inv_l[of "cor k" "congruence (mat_inv M) ?H" "?H"]
      using mult_sm_inv_l[of "1/cor k" "congruence M ?H"]
      using congruence_scale_m[of M "1/cor k" "?H"]
      by (auto simp add: mat_det_inv)
    then obtain a b k' where "k' \<noteq> 0" "M = k' *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)" "sgn (Re (mat_det (a, b, cnj b, cnj a))) = 1"
      using unitary11_sgn_det_orientation'[of M k] \<open>k > 0\<close>
      by auto
    moreover
    have "mat_det (a, b, cnj b, cnj a) \<noteq> 0"
      using \<open>sgn (Re (mat_det (a, b, cnj b, cnj a))) = 1\<close>
      by (smt sgn_0 zero_complex.simps(1))
    ultimately
    show "unit_disc_fix_cmat M"
      using unitary11_sgn_det[of k' a b M A B C D]
      using MM[symmetric] \<open>k > 0\<close> \<open>unitary11_gen M\<close>
      by (simp add: sgn_1_pos split: if_split_asm)
  qed
next
  assume ?rhs
  thus ?lhs
  proof (transfer, transfer)
    fix M :: complex_mat
    assume "mat_det M \<noteq> 0"

    obtain A B C D where MM: "(A, B, C, D) = M"
      by (cases M) auto
    assume "unit_disc_fix_cmat M"
    hence "unitary11_gen M" "B = 0 \<or> 1 < Re (A * D / (B * C))"
      using MM[symmetric]
      by auto
    have "sgn (if B = 0 then 1 else sgn (Re (A * D / (B * C)) - 1)) = 1"
      using \<open>B = 0 \<or> 1 < Re (A * D / (B * C))\<close>
      by auto
    then obtain k' where "k' > 0" "congruence M (1, 0, 0, -1) = cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"
      using unitary11_orientation[OF \<open>unitary11_gen M\<close> MM[symmetric]]
      by (auto simp add: sgn_1_pos)
    thus "ocircline_eq_cmat (moebius_circline_cmat_cmat M unit_circle_cmat) unit_circle_cmat"
      using congruence_inv[of M "(1, 0, 0, -1)" "cor k' *\<^sub>s\<^sub>m (1, 0, 0, -1)"] \<open>mat_det M \<noteq> 0\<close>
      using congruence_scale_m[of "mat_inv M" "cor k'" "(1, 0, 0, -1)"]
      by auto
  qed
qed

text \<open>Our algebraic characterisation (by matrices) is geometrically correct.\<close>

lemma unit_disc_fix_iff [simp]:
  assumes "unit_disc_fix M"
  shows "moebius_pt M ` unit_disc = unit_disc"
  using assms
  using unit_disc_fix_iff_ounit_circle[of M]
  unfolding unit_disc_def
  by (subst disc_moebius_ocircline[symmetric], simp)

lemma unit_disc_fix_discI [simp]:
  assumes "unit_disc_fix M" and "u \<in> unit_disc"
  shows "moebius_pt M u \<in> unit_disc"
  using unit_disc_fix_iff assms
  by blast

text \<open>Unit disc preserving transformations form a group.\<close>

lemma unit_disc_fix_id_moebius [simp]:
  shows "unit_disc_fix id_moebius"
  by (transfer, transfer, simp add: unitary11_gen_def mat_adj_def mat_cnj_def)

lemma unit_disc_fix_moebius_add [simp]:
  assumes "unit_disc_fix M1" and "unit_disc_fix M2"
  shows "unit_disc_fix (M1 + M2)"
  using assms
  unfolding unit_disc_fix_iff_ounit_circle
  by auto

lemma unit_disc_fix_moebius_comp [simp]:
  assumes "unit_disc_fix M1" and "unit_disc_fix M2"
  shows "unit_disc_fix (moebius_comp M1 M2)"
  using unit_disc_fix_moebius_add[OF assms]
  by simp

lemma unit_disc_fix_moebius_inv [simp]:
  assumes "unit_disc_fix M"
  shows "unit_disc_fix (moebius_inv M)"
  using unit_disc_fix_moebius_uminus[OF assms]
  by simp

(* -------------------------------------------------------------------------- *)
subsection \<open>Rotations are unit disc preserving transformations\<close>
(* -------------------------------------------------------------------------- *)

lemma unit_disc_fix_rotation [simp]:
  shows "unit_disc_fix (moebius_rotation \<phi>)"
  unfolding moebius_rotation_def moebius_similarity_def
  by (transfer, transfer, simp add: unitary11_gen_def mat_adj_def mat_cnj_def cis_mult)

lemma moebius_rotation_unit_circle_fix [simp]:
  shows "moebius_pt (moebius_rotation \<phi>) u \<in> unit_circle_set \<longleftrightarrow> u \<in> unit_circle_set"
  using moebius_pt_moebius_inv_in_set unit_circle_fix_iff_unit_circle_set
  by fastforce

lemma ex_rotation_mapping_u_to_positive_x_axis:
  assumes "u \<noteq> 0\<^sub>h" and "u \<noteq> \<infinity>\<^sub>h"
  shows "\<exists> \<phi>. moebius_pt (moebius_rotation \<phi>) u \<in> positive_x_axis"
proof-
  from assms obtain c where *: "u = of_complex c"
    using inf_or_of_complex
    by blast
  have "is_real (cis (- arg c) * c)" "Re (cis (-arg c) * c) > 0"
    using "*" assms is_real_rot_to_x_axis positive_rot_to_x_axis of_complex_zero_iff
    by blast+
  thus ?thesis
    using *
    by (rule_tac x="-arg c" in exI) (simp add: positive_x_axis_def circline_set_x_axis)
qed

lemma ex_rotation_mapping_u_to_positive_y_axis:
  assumes "u \<noteq> 0\<^sub>h" and "u \<noteq> \<infinity>\<^sub>h"
  shows "\<exists> \<phi>. moebius_pt (moebius_rotation \<phi>) u \<in> positive_y_axis"
proof-
  from assms obtain c where *: "u = of_complex c"
    using inf_or_of_complex
    by blast
  have "is_imag (cis (pi/2 - arg c) * c)" "Im (cis (pi/2 - arg c) * c) > 0"
    using "*" assms is_real_rot_to_x_axis positive_rot_to_x_axis of_complex_zero_iff
    by - (simp, simp, simp add: field_simps)
  thus ?thesis
    using *
    by (rule_tac x="pi/2-arg c" in exI) (simp add: positive_y_axis_def circline_set_y_axis)
qed

lemma wlog_rotation_to_positive_x_axis:
  assumes in_disc: "u \<in> unit_disc" and not_zero: "u \<noteq> 0\<^sub>h"
  assumes preserving: "\<And>\<phi> u. \<lbrakk>u \<in> unit_disc; u \<noteq> 0\<^sub>h; P (moebius_pt (moebius_rotation \<phi>) u)\<rbrakk> \<Longrightarrow> P u"
  assumes x_axis: "\<And>x. \<lbrakk>is_real x; 0 < Re x; Re x < 1\<rbrakk> \<Longrightarrow> P (of_complex x)"
  shows "P u"
proof-
  from in_disc obtain \<phi> where *:
    "moebius_pt (moebius_rotation \<phi>) u \<in> positive_x_axis"
    using ex_rotation_mapping_u_to_positive_x_axis[of u]
    using inf_notin_unit_disc not_zero
    by blast
  let ?Mu = "moebius_pt (moebius_rotation \<phi>) u"
  have "P ?Mu"
  proof-
    let ?x = "to_complex ?Mu"
    have "?Mu \<in> unit_disc" "?Mu \<noteq> 0\<^sub>h" "?Mu \<noteq> \<infinity>\<^sub>h"
      using \<open>u \<in> unit_disc\<close> \<open>u \<noteq> 0\<^sub>h\<close>
      by auto
    hence "is_real (to_complex ?Mu)"  "0 < Re ?x" "Re ?x < 1"
      using *
      unfolding positive_x_axis_def circline_set_x_axis
      by (auto simp add: cmod_eq_Re)
    thus ?thesis
      using x_axis[of ?x] \<open>?Mu \<noteq> \<infinity>\<^sub>h\<close>
      by simp
  qed
  thus ?thesis
    using preserving[OF in_disc] not_zero
    by simp
qed

lemma wlog_rotation_to_positive_x_axis':
  assumes not_zero: "u \<noteq> 0\<^sub>h" and not_inf: "u \<noteq> \<infinity>\<^sub>h"
  assumes preserving: "\<And>\<phi> u. \<lbrakk>u \<noteq> 0\<^sub>h; u \<noteq> \<infinity>\<^sub>h; P (moebius_pt (moebius_rotation \<phi>) u)\<rbrakk> \<Longrightarrow> P u"
  assumes x_axis: "\<And>x. \<lbrakk>is_real x; 0 < Re x\<rbrakk> \<Longrightarrow> P (of_complex x)"
  shows "P u"
proof-
  from not_zero and not_inf obtain \<phi> where *:
    "moebius_pt (moebius_rotation \<phi>) u \<in> positive_x_axis"
    using ex_rotation_mapping_u_to_positive_x_axis[of u]
    using inf_notin_unit_disc
    by blast
  let ?Mu = "moebius_pt (moebius_rotation \<phi>) u"
  have "P ?Mu"
  proof-
    let ?x = "to_complex ?Mu"
    have "?Mu \<noteq> 0\<^sub>h" "?Mu \<noteq> \<infinity>\<^sub>h"
      using \<open>u \<noteq> \<infinity>\<^sub>h\<close> \<open>u \<noteq> 0\<^sub>h\<close>
      by auto
    hence "is_real (to_complex ?Mu)"  "0 < Re ?x"
      using *
      unfolding positive_x_axis_def circline_set_x_axis
      by (auto simp add: cmod_eq_Re)
    thus ?thesis
      using x_axis[of ?x] \<open>?Mu \<noteq> \<infinity>\<^sub>h\<close>
      by simp
  qed
  thus ?thesis
    using preserving[OF not_zero not_inf]
    by simp
qed

lemma wlog_rotation_to_positive_y_axis:
  assumes in_disc: "u \<in> unit_disc" and not_zero: "u \<noteq> 0\<^sub>h"
  assumes preserving: "\<And>\<phi> u. \<lbrakk>u \<in> unit_disc; u \<noteq> 0\<^sub>h; P (moebius_pt (moebius_rotation \<phi>) u)\<rbrakk> \<Longrightarrow> P u"
  assumes y_axis: "\<And>x. \<lbrakk>is_imag x; 0 < Im x; Im x < 1\<rbrakk> \<Longrightarrow> P (of_complex x)"
  shows "P u"
proof-
  from in_disc and not_zero obtain \<phi> where *:
    "moebius_pt (moebius_rotation \<phi>) u \<in> positive_y_axis"
    using ex_rotation_mapping_u_to_positive_y_axis[of u]
    using inf_notin_unit_disc
    by blast
  let ?Mu = "moebius_pt (moebius_rotation \<phi>) u"
  have "P ?Mu"
  proof-
    let ?y = "to_complex ?Mu"
    have "?Mu \<in> unit_disc" "?Mu \<noteq> 0\<^sub>h" "?Mu \<noteq> \<infinity>\<^sub>h"
      using \<open>u \<in> unit_disc\<close> \<open>u \<noteq> 0\<^sub>h\<close>
      by auto
    hence "is_imag (to_complex ?Mu)"  "0 < Im ?y" "Im ?y < 1"
      using *
      unfolding positive_y_axis_def circline_set_y_axis
      by (auto simp add: cmod_eq_Im)
    thus ?thesis
      using y_axis[of ?y] \<open>?Mu \<noteq> \<infinity>\<^sub>h\<close>
      by simp
  qed
  thus ?thesis
    using preserving[OF in_disc not_zero]
    by simp
qed

(* ---------------------------------------------------------------------------- *)
subsection \<open>Blaschke factors are unit disc preserving transformations\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>For a given point $a$, Blaschke factor transformations are of the form $k \cdot
\left(\begin{array}{cc}1 & -a\\ -\overline{a} & 1\end{array}\right)$. It is a disc preserving
Möbius transformation that maps the point $a$ to zero (by the symmetry principle, it must map the
inverse point of $a$ to infinity).\<close>

definition blaschke_cmat :: "complex \<Rightarrow> complex_mat" where
 [simp]: "blaschke_cmat a = (if cmod a \<noteq> 1 then (1, -a, -cnj a, 1) else eye)"
lift_definition blaschke_mmat :: "complex \<Rightarrow> moebius_mat" is blaschke_cmat
  by simp
lift_definition blaschke :: "complex \<Rightarrow> moebius" is blaschke_mmat
  done

lemma blaschke_0_id [simp]: "blaschke 0 = id_moebius"
  by (transfer, transfer, simp)

lemma blaschke_a_to_zero [simp]:
  assumes "cmod a \<noteq> 1"
  shows "moebius_pt (blaschke a) (of_complex a) = 0\<^sub>h"
  using assms
  by (transfer, transfer, simp)

lemma blaschke_inv_a_inf [simp]:
  assumes "cmod a \<noteq> 1"
  shows "moebius_pt (blaschke a) (inversion (of_complex a)) = \<infinity>\<^sub>h"
  using assms
  unfolding inversion_def
  by (transfer, transfer) (simp add: vec_cnj_def, rule_tac x="1/(1 - a*cnj a)" in exI, simp)

lemma blaschke_inf [simp]:
  assumes "cmod a < 1" and "a \<noteq> 0"
  shows "moebius_pt (blaschke a) \<infinity>\<^sub>h = of_complex (- 1 / cnj a)"
  using assms
  by (transfer, transfer, simp add: complex_mod_sqrt_Re_mult_cnj)

lemma blaschke_0_minus_a [simp]:
  assumes "cmod a \<noteq> 1"
  shows "moebius_pt (blaschke a) 0\<^sub>h = ~\<^sub>h (of_complex a)"
  using assms
  by (transfer, transfer, simp)

lemma blaschke_unit_circle_fix [simp]:
  assumes "cmod a \<noteq> 1"
  shows "unit_circle_fix (blaschke a)"
  using assms
  by (transfer, transfer) (simp add: unitary11_gen_def mat_adj_def mat_cnj_def)

lemma blaschke_unit_disc_fix [simp]:
  assumes "cmod a < 1"
  shows "unit_disc_fix (blaschke a)"
  using assms
proof (transfer, transfer)
  fix a
  assume *: "cmod a < 1"
  show "unit_disc_fix_cmat (blaschke_cmat a)"
  proof (cases "a = 0")
    case True
    thus ?thesis
      by (simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
  next
    case False
    hence "Re (a * cnj a) < 1"
      using *
      by (metis complex_mod_sqrt_Re_mult_cnj real_sqrt_lt_1_iff)
    hence "1 / Re (a * cnj a) > 1"
      using False
      by (smt complex_div_gt_0 less_divide_eq_1_pos one_complex.simps(1) right_inverse_eq)
    hence "Re (1 / (a * cnj a)) > 1"
      by (simp add: complex_is_Real_iff)
    thus ?thesis
      by (simp add: unitary11_gen_def mat_adj_def mat_cnj_def)
  qed
qed

lemma blaschke_unit_circle_fix':
  assumes "cmod a \<noteq> 1"
  shows "moebius_circline (blaschke a) unit_circle = unit_circle"
  using assms
  using blaschke_unit_circle_fix unit_circle_fix_iff
  by simp

lemma blaschke_ounit_circle_fix':
  assumes "cmod a < 1"
  shows "moebius_ocircline (blaschke a) ounit_circle = ounit_circle"
proof-
  have "Re (a * cnj a) < 1"
    using assms
    by (metis complex_mod_sqrt_Re_mult_cnj real_sqrt_lt_1_iff)
  thus ?thesis
    using assms
    using blaschke_unit_disc_fix unit_disc_fix_iff_ounit_circle
    by simp
qed

lemma moebius_pt_blaschke [simp]:
  assumes "cmod a \<noteq> 1" and "z \<noteq> 1 / cnj a"
  shows "moebius_pt (blaschke a) (of_complex z) = of_complex ((z - a) / (1 - cnj a * z))"
  using assms
proof (cases "a = 0")
  case True
  thus ?thesis
    by auto
next
  case False
  thus ?thesis
    using assms
    apply (transfer, transfer)
    apply (simp add: complex_mod_sqrt_Re_mult_cnj)
    apply (rule_tac x="1 / (1 - cnj a * z)" in exI)
    apply (simp add: field_simps)
    done
qed

(* -------------------------------------------------------------------------- *)
subsubsection \<open>Blaschke factors for a real point $a$\<close>
(* -------------------------------------------------------------------------- *)

text \<open>If the point $a$ is real, the Blaschke factor preserve x-axis and the upper and the lower
halfplane.\<close>

lemma blaschke_real_preserve_sgn_Im [simp]:
  assumes "is_real a" and "cmod a < 1" and "z \<noteq> \<infinity>\<^sub>h" and "z \<noteq> inversion (of_complex a)"
  shows "sgn (Im (to_complex (moebius_pt (blaschke a) z))) = sgn (Im (to_complex z))"
proof (cases "a = 0")
  case True
  thus ?thesis
    by simp
next
  case False
  obtain z' where z': "z = of_complex z'"
    using inf_or_of_complex[of z] \<open>z \<noteq> \<infinity>\<^sub>h\<close>
    by auto
  have "z' \<noteq> 1 / cnj a"
    using assms z' \<open>a \<noteq> 0\<close>
    by (auto simp add: of_complex_inj)
  moreover
  have "a * cnj a \<noteq> 1"
    using \<open>cmod a < 1\<close>
    by auto (simp add: complex_mod_sqrt_Re_mult_cnj)
  moreover
  have "sgn (Im ((z' - a) / (1 - a * z'))) = sgn (Im z')"
  proof-
    have "a * z' \<noteq> 1"
      using \<open>is_real a\<close> \<open>z' \<noteq> 1 / cnj a\<close> \<open>a \<noteq> 0\<close> eq_cnj_iff_real[of a]
      by (simp add: field_simps)
    moreover
    have "Re (1 - a\<^sup>2) > 0"
      using \<open>is_real a\<close> \<open>cmod a < 1\<close>
      by (smt Re_power2 minus_complex.simps(1) norm_complex_def one_complex.simps(1) power2_less_0 real_sqrt_lt_1_iff)
    moreover
    have "Im ((z' - a) / (1 - a * z')) = Re (((1 - a\<^sup>2) * Im z') / (cmod (1 - a*z'))\<^sup>2)"
    proof-
      have "1 - a * cnj z' \<noteq> 0"
        using \<open>z' \<noteq> 1 / cnj a\<close>
        by (metis Im_complex_div_eq_0  complex_cnj_zero_iff diff_eq_diff_eq diff_numeral_special(9) eq_divide_imp is_real_div mult_not_zero one_complex.simps(2) zero_neq_one)
      hence "Im ((z' - a) / (1 - a * z')) = Im (((z' - a) * (1 - a * cnj z')) / ((1 - a * z') * cnj (1 - a * z')))"
        using \<open>is_real a\<close> eq_cnj_iff_real[of a]
        by simp
      also have "... = Im ((z' - a - a * z' * cnj z' + a\<^sup>2 * cnj z') / (cmod (1 - a*z'))\<^sup>2)"
        unfolding complex_mult_cnj_cmod
        by (simp add: power2_eq_square field_simps)
      finally show ?thesis
        using \<open>is_real a\<close>
        by (simp add: field_simps)
    qed
    moreover
    have "0 < (1 - (Re a)\<^sup>2) * Im z' / (cmod (1 - a * z'))\<^sup>2 \<Longrightarrow> Im z' > 0"
      using `is_real a` `0 < Re (1 - a\<^sup>2)`
      by (smt Re_power_real divide_le_0_iff minus_complex.simps(1) not_sum_power2_lt_zero one_complex.simps(1) zero_less_mult_pos)
    ultimately
    show ?thesis
      unfolding sgn_real_def
      using \<open>cmod a < 1\<close> \<open>a * z' \<noteq> 1\<close> \<open>is_real a\<close>
      by (auto simp add: cmod_eq_Re)
  qed
  ultimately
  show ?thesis
    using assms z' moebius_pt_blaschke[of a z'] \<open>is_real a\<close> eq_cnj_iff_real[of a]
    by simp
qed

lemma blaschke_real_preserve_sgn_arg [simp]:
  assumes "is_real a" and "cmod a < 1" and "z \<notin> circline_set x_axis"
  shows "sgn (arg (to_complex (moebius_pt (blaschke a) z))) = sgn (arg (to_complex z))"
proof-
  have "z \<noteq> \<infinity>\<^sub>h"
    using assms
    using special_points_on_x_axis''(3) by blast
  moreover
  have "z \<noteq> inversion (of_complex a)"
    using assms
    by (metis calculation circline_equation_x_axis circline_set_x_axis_I conjugate_of_complex inversion_of_complex inversion_sym is_real_inversion o_apply of_complex_zero reciprocal_zero to_complex_of_complex)
  ultimately
  show ?thesis
    using blaschke_real_preserve_sgn_Im[OF assms(1) assms(2), of z]
    by (smt arg_Im_sgn assms(3) circline_set_x_axis_I norm_sgn of_complex_to_complex)
qed

(* -------------------------------------------------------------------------- *)
subsubsection \<open>Inverse Blaschke transform\<close>
(* -------------------------------------------------------------------------- *)

definition inv_blaschke_cmat :: "complex \<Rightarrow> complex_mat" where
 [simp]: "inv_blaschke_cmat a = (if cmod a \<noteq> 1 then (1, a, cnj a, 1) else eye)"
lift_definition inv_blaschke_mmat :: "complex \<Rightarrow> moebius_mat" is inv_blaschke_cmat
  by simp
lift_definition inv_blaschke :: "complex \<Rightarrow> moebius" is inv_blaschke_mmat
  done

lemma inv_blaschke_neg [simp]: "inv_blaschke a = blaschke (-a)"
  by (transfer, transfer) simp

lemma inv_blaschke:
  assumes "cmod a \<noteq> 1"
  shows "blaschke a + inv_blaschke a = 0"
  apply simp
  apply (transfer, transfer)
  by auto (rule_tac x="1/(1 - a*cnj a)" in exI, simp)

lemma ex_unit_disc_fix_mapping_u_to_zero:
  assumes "u \<in> unit_disc"
  shows "\<exists> M. unit_disc_fix M \<and> moebius_pt M u = 0\<^sub>h"
proof-
  from assms obtain c where *: "u = of_complex c"
    by (metis inf_notin_unit_disc inf_or_of_complex)
  hence "cmod c < 1"
    using assms unit_disc_iff_cmod_lt_1
    by simp
  thus ?thesis
    using *
    by (rule_tac x="blaschke c" in exI)
       (smt blaschke_a_to_zero blaschke_ounit_circle_fix' unit_disc_fix_iff_ounit_circle)
qed

lemma wlog_zero:
  assumes in_disc: "u \<in> unit_disc"
  assumes preserving: "\<And> a u. \<lbrakk>u \<in> unit_disc; cmod a < 1; P (moebius_pt (blaschke a) u)\<rbrakk> \<Longrightarrow> P u"
  assumes zero: "P 0\<^sub>h"
  shows "P u"
proof-
  have *: "moebius_pt (blaschke (to_complex u)) u = 0\<^sub>h"
    by (smt blaschke_a_to_zero in_disc inf_notin_unit_disc of_complex_to_complex unit_disc_iff_cmod_lt_1)
  thus ?thesis
    using preserving[of u "to_complex u"] in_disc zero
    using inf_or_of_complex[of u]
    by auto
qed

lemma wlog_real_zero:
  assumes in_disc: "u \<in> unit_disc" and real: "is_real (to_complex u)"
  assumes preserving: "\<And> a u. \<lbrakk>u \<in> unit_disc; is_real a; cmod a < 1; P (moebius_pt (blaschke a) u)\<rbrakk> \<Longrightarrow> P u"
  assumes zero: "P 0\<^sub>h"
  shows "P u"
proof-
  have *: "moebius_pt (blaschke (to_complex u)) u = 0\<^sub>h"
    by (smt blaschke_a_to_zero in_disc inf_notin_unit_disc of_complex_to_complex unit_disc_iff_cmod_lt_1)
  thus ?thesis
    using preserving[of u "to_complex u"] in_disc zero real
    using inf_or_of_complex[of u]
    by auto
qed

lemma unit_disc_fix_transitive:
  assumes in_disc: "u \<in> unit_disc" and "u' \<in> unit_disc"
  shows "\<exists> M. unit_disc_fix M \<and> moebius_pt M u = u'"
proof-
  have "\<forall> u \<in> unit_disc. \<exists> M. unit_disc_fix M \<and> moebius_pt M u = u'" (is "?P u'")
  proof (rule wlog_zero)
    show "u' \<in> unit_disc" by fact
  next
    show "?P 0\<^sub>h"
      by (simp add: ex_unit_disc_fix_mapping_u_to_zero)
  next
    fix a u
    assume "cmod a < 1" and *: "?P (moebius_pt (blaschke a) u)"
    show "?P u"
    proof
      fix u'
      assume "u' \<in> unit_disc"
      then obtain M' where "unit_disc_fix M'" "moebius_pt M' u' = moebius_pt (blaschke a) u"
        using *
        by auto
      thus "\<exists>M. unit_disc_fix M \<and> moebius_pt M u' = u"
        using \<open>cmod a < 1\<close> blaschke_unit_disc_fix[of a]
        using unit_disc_fix_moebius_comp[of "- blaschke a" "M'"]
        using unit_disc_fix_moebius_inv[of "blaschke a"]
        by (rule_tac x="(- (blaschke a)) + M'" in exI, simp)
    qed
  qed
  thus ?thesis
    using assms
    by auto
qed

(* -------------------------------------------------------------------------- *)
subsection \<open>Decomposition of unit disc preserving Möbius transforms\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Each transformation preserving unit disc can be decomposed to a rotation around the origin and
a Blaschke factors that maps a point within the unit disc to zero.\<close>

lemma unit_disc_fix_decompose_blaschke_rotation:
  assumes "unit_disc_fix M"
  shows "\<exists> k \<phi>. cmod k < 1 \<and> M = moebius_rotation \<phi> + blaschke k"
  using assms
  unfolding moebius_rotation_def moebius_similarity_def
proof (simp, transfer, transfer)
  fix M
  assume *: "mat_det M \<noteq> 0" "unit_disc_fix_cmat M"
  then obtain k a b :: complex where
    **: "k \<noteq> 0" "mat_det (a, b, cnj b, cnj a) \<noteq> 0" "M = k *\<^sub>s\<^sub>m (a, b, cnj b, cnj a)"
    using unitary11_gen_iff[of M]
    by auto
  have "a \<noteq> 0"
    using * **
    by auto
  then obtain a' k' \<phi>
    where ***: "k' \<noteq> 0 \<and> a' * cnj a' \<noteq> 1 \<and> M = k' *\<^sub>s\<^sub>m (cis \<phi>, 0, 0, 1) *\<^sub>m\<^sub>m (1, - a', - cnj a', 1)"
    using ** unitary11_gen_cis_blaschke[of k M a b]
    by auto
  have "a' = 0 \<or> 1 < 1 / (cmod a')\<^sup>2"
    using * *** complex_mult_cnj_cmod[of a']
    by simp
  hence "cmod a' < 1"
    by (smt less_divide_eq_1_pos norm_zero one_less_power one_power2 pos2)
  thus "\<exists>k. cmod k < 1 \<and>
            (\<exists>\<phi>. moebius_cmat_eq M (moebius_comp_cmat (mk_moebius_cmat (cis \<phi>) 0 0 1) (blaschke_cmat k)))"
    using ***
    apply (rule_tac x=a' in exI)
    apply simp
    apply (rule_tac x=\<phi> in exI)
    apply simp
    apply (rule_tac x="1/k'" in exI)
    by auto
qed

lemma wlog_unit_disc_fix:
  assumes "unit_disc_fix M"
  assumes b: "\<And> k. cmod k < 1 \<Longrightarrow> P (blaschke k)"
  assumes r: "\<And> \<phi>. P (moebius_rotation \<phi>)"
  assumes comp: "\<And>M1 M2. \<lbrakk>unit_disc_fix M1; P M1; unit_disc_fix M2; P M2\<rbrakk> \<Longrightarrow> P (M1 + M2)"
  shows "P M"
  using assms
  using unit_disc_fix_decompose_blaschke_rotation[OF assms(1)]
  using blaschke_unit_disc_fix
  by auto

lemma ex_unit_disc_fix_to_zero_positive_x_axis:
  assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "u \<noteq> v"
  shows "\<exists> M. unit_disc_fix M \<and>
              moebius_pt M u = 0\<^sub>h \<and> moebius_pt M v \<in> positive_x_axis"
proof-
  from assms obtain B where
    *: "unit_disc_fix B" "moebius_pt B u = 0\<^sub>h"
    using ex_unit_disc_fix_mapping_u_to_zero
    by blast

  let ?v = "moebius_pt B v"
  have "?v \<in> unit_disc"
    using \<open>v \<in> unit_disc\<close> *
    by auto
  hence "?v \<noteq> \<infinity>\<^sub>h"
    using inf_notin_unit_disc by auto
  have "?v \<noteq> 0\<^sub>h"
    using \<open>u \<noteq> v\<close> *
    by (metis moebius_pt_invert)

  obtain R where
    "unit_disc_fix R"
    "moebius_pt R 0\<^sub>h = 0\<^sub>h" "moebius_pt R ?v \<in> positive_x_axis"
    using ex_rotation_mapping_u_to_positive_x_axis[of ?v] \<open>?v \<noteq> 0\<^sub>h\<close> \<open>?v \<noteq> \<infinity>\<^sub>h\<close>
    using moebius_pt_rotation_inf_iff moebius_pt_moebius_rotation_zero unit_disc_fix_rotation
    by blast
  thus ?thesis
    using * moebius_comp[of R B, symmetric]
    using unit_disc_fix_moebius_comp
    by (rule_tac x="R + B" in exI) (simp add: comp_def)
qed

lemma wlog_x_axis:
  assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc"
  assumes preserved: "\<And> M u v. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; P (moebius_pt M u) (moebius_pt M v)\<rbrakk> \<Longrightarrow> P u v"
  assumes axis: "\<And> x. \<lbrakk>is_real x; 0 \<le> Re x;  Re x < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex x)"
  shows "P u v"
proof (cases "u = v")
  case True
  have "P u u" (is "?Q u")
  proof (rule wlog_zero[where P="?Q"])
    show "u \<in> unit_disc"
      by fact
  next
    show "?Q 0\<^sub>h"
      using axis[of 0]
      by simp
  next
    fix a u
    assume "u \<in> unit_disc" "cmod a < 1" "?Q (moebius_pt (blaschke a) u)"
    thus "?Q u"
      using preserved[of "blaschke a" u u]
      using blaschke_unit_disc_fix[of a]
      by simp
  qed
  thus ?thesis
    using True
    by simp
next
  case False
  from in_disc obtain M where
    *: "unit_disc_fix M" "moebius_pt M u = 0\<^sub>h" "moebius_pt M v \<in> positive_x_axis"
    using ex_unit_disc_fix_to_zero_positive_x_axis False
    by auto
  then obtain x where **: "moebius_pt M v = of_complex x" "is_real x"
    unfolding positive_x_axis_def circline_set_x_axis
    by auto
  moreover
  have "of_complex x \<in> unit_disc"
    using \<open>unit_disc_fix M\<close> \<open>v \<in> unit_disc\<close> **
    using unit_disc_fix_discI
    by fastforce
  hence "0 < Re x" "Re x < 1"
    using \<open>moebius_pt M v \<in> positive_x_axis\<close> **
    by (auto simp add: positive_x_axis_def cmod_eq_Re)
  ultimately
  have "P 0\<^sub>h (of_complex x)"
    using \<open>is_real x\<close> axis
    by auto
  thus ?thesis
    using preserved[OF *(1) assms(1-2)] *(2) **(1)
    by simp
qed

lemma wlog_positive_x_axis:
  assumes in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
  assumes preserved: "\<And> M u v. \<lbrakk>unit_disc_fix M; u \<in> unit_disc; v \<in> unit_disc; u \<noteq> v; P (moebius_pt M u) (moebius_pt M v)\<rbrakk> \<Longrightarrow> P u v"
  assumes axis: "\<And> x. \<lbrakk>is_real x; 0 < Re x;  Re x < 1\<rbrakk> \<Longrightarrow> P 0\<^sub>h (of_complex x)"
  shows "P u v"
proof-
  have "u \<noteq> v \<longrightarrow> P u v" (is "?Q u v")
  proof (rule wlog_x_axis)
    show "u \<in> unit_disc" "v \<in> unit_disc"
      by fact+
  next
    fix M u v
    assume "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
           "?Q (moebius_pt M u) (moebius_pt M v)"
    thus "?Q u v"
      using preserved[of M u v]
      using moebius_pt_invert
      by blast
  next
    fix x
    assume "is_real x" "0 \<le> Re x" "Re x < 1"
    thus "?Q 0\<^sub>h (of_complex x)"
      using axis[of x] of_complex_zero_iff[of x] complex.expand[of x 0]
      by fastforce
  qed
  thus ?thesis
    using \<open>u \<noteq> v\<close>
    by simp
qed

(* -------------------------------------------------------------------------- *)
subsection \<open>All functions that fix the unit disc\<close>
(* -------------------------------------------------------------------------- *)

text \<open>It can be proved that continuous functions that fix the unit disc are either actions of
Möbius transformations that fix the unit disc (homographies), or are compositions of actions of
Möbius transformations that fix the unit disc and the conjugation (antihomographies). We postulate
this as a definition, but it this characterisation could also be formally shown (we do not need this
for our further applications).\<close>

definition unit_disc_fix_f where
  "unit_disc_fix_f f \<longleftrightarrow>
   (\<exists> M. unit_disc_fix M \<and> (f = moebius_pt M \<or> f = moebius_pt M \<circ> conjugate))"

text \<open>Unit disc fixing functions really fix unit disc.\<close>

text \<open>Actions of unit disc fixing Möbius transformations (unit disc fixing homographies) are unit
disc fixing functions.\<close>
lemma unit_disc_fix_f_moebius_pt [simp]:
  assumes "unit_disc_fix M"
  shows "unit_disc_fix_f (moebius_pt M)"
  using assms
  unfolding unit_disc_fix_f_def
  by auto

text \<open>Compositions of unit disc fixing Möbius transformations and conjugation (unit disc fixing
antihomographies) are unit disc fixing functions.\<close>
lemma unit_disc_fix_conjugate_moebius [simp]:
  assumes "unit_disc_fix M"
  shows "unit_disc_fix (conjugate_moebius M)"
proof-
  have "\<And>a aa ab b. \<lbrakk>1 < Re (a * b / (aa * ab)); \<not> 1 < Re (cnj a * cnj b / (cnj aa * cnj ab))\<rbrakk> \<Longrightarrow> aa = 0"
    by (metis cnj.simps(1) complex_cnj_divide complex_cnj_mult)
  thus ?thesis
    using assms
    by (transfer, transfer)
       (auto simp add: mat_cnj_def unitary11_gen_def mat_adj_def field_simps)
qed

lemma unit_disc_fix_conjugate_comp_moebius [simp]:
  assumes "unit_disc_fix M"
  shows "unit_disc_fix_f (conjugate \<circ> moebius_pt M)"
  using assms
  apply (subst conjugate_moebius)
  apply (simp add: unit_disc_fix_f_def)
  apply (rule_tac x="conjugate_moebius M" in exI, simp)
  done

text \<open>Uniti disc fixing functions form a group under function composition.\<close>

lemma unit_disc_fix_f_comp [simp]:
  assumes "unit_disc_fix_f f1" and "unit_disc_fix_f f2"
  shows "unit_disc_fix_f (f1 \<circ> f2)"
  using assms
  apply (subst (asm) unit_disc_fix_f_def)
  apply (subst (asm) unit_disc_fix_f_def)
proof safe
  fix M M'
  assume "unit_disc_fix M" "unit_disc_fix M'"
  thus "unit_disc_fix_f (moebius_pt M \<circ> moebius_pt M')"
    unfolding unit_disc_fix_f_def
    by (rule_tac x="M + M'" in exI) auto
next
  fix M M'
  assume "unit_disc_fix M" "unit_disc_fix M'"
  thus "unit_disc_fix_f (moebius_pt M \<circ> (moebius_pt M' \<circ> conjugate))"
    unfolding unit_disc_fix_f_def
    by (subst comp_assoc[symmetric])+
       (rule_tac x="M + M'" in exI, auto)
next
  fix M M'
  assume "unit_disc_fix M" "unit_disc_fix M'"
  thus "unit_disc_fix_f ((moebius_pt M \<circ> conjugate) \<circ> moebius_pt M')"
    unfolding unit_disc_fix_f_def
    by (subst comp_assoc, subst conjugate_moebius, subst comp_assoc[symmetric])+
       (rule_tac x="M + conjugate_moebius M'" in exI, auto)
next
  fix M M'
  assume "unit_disc_fix M" "unit_disc_fix M'"
  thus "unit_disc_fix_f ((moebius_pt M \<circ> conjugate) \<circ> (moebius_pt M' \<circ> conjugate))"
    apply (subst comp_assoc[symmetric], subst comp_assoc)
    apply (subst conjugate_moebius, subst comp_assoc, subst comp_assoc)
    apply (simp add: unit_disc_fix_f_def)
    apply (rule_tac x="M + conjugate_moebius M'" in exI, auto)
    done
qed

(* -------------------------------------------------------------------------- *)
subsubsection \<open>Action of unit disc fixing functions on circlines\<close>
(* -------------------------------------------------------------------------- *)

definition unit_disc_fix_f_circline where
  "unit_disc_fix_f_circline f H =
      (if \<exists> M. unit_disc_fix M \<and> f = moebius_pt M then
          moebius_circline (THE M. unit_disc_fix M \<and> f = moebius_pt M) H
       else if \<exists> M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate then
          (moebius_circline (THE M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate) \<circ> conjugate_circline) H
       else
          H)"

lemma unique_moebius_pt_conjugate:
  assumes "moebius_pt M1 \<circ> conjugate = moebius_pt M2 \<circ> conjugate"
  shows "M1 = M2"
proof-
  from assms have "moebius_pt M1 = moebius_pt M2"
    using conjugate_conjugate_comp rewriteL_comp_comp2 by fastforce
  thus ?thesis
    using unique_moebius_pt
    by auto
qed

lemma unit_disc_fix_f_circline_direct:
  assumes "unit_disc_fix M" and "f = moebius_pt M"
  shows "unit_disc_fix_f_circline f H = moebius_circline M H"
proof-
  have "M = (THE M. unit_disc_fix M \<and> f = moebius_pt M)"
    using assms
    using theI_unique[of "\<lambda> M. unit_disc_fix M \<and> f = moebius_pt M" M]
    using unique_moebius_pt[of M]
    by auto
  thus ?thesis
    using assms
    unfolding unit_disc_fix_f_circline_def
    by auto
qed

lemma unit_disc_fix_f_circline_indirect:
  assumes "unit_disc_fix M" and "f = moebius_pt M \<circ> conjugate"
  shows "unit_disc_fix_f_circline f H = ((moebius_circline M) \<circ> conjugate_circline) H"
proof-
  have "\<not> (\<exists> M. unit_disc_fix M \<and> f = moebius_pt M)"
    using assms homography_antihomography_exclusive[of f]
    unfolding is_homography_def is_antihomography_def is_moebius_def
    by auto
  moreover
  have "M = (THE M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate)"
    using assms
    using theI_unique[of "\<lambda> M. unit_disc_fix M \<and> f = moebius_pt M \<circ> conjugate" M]
    using unique_moebius_pt_conjugate[of M]
    by auto
  ultimately
  show ?thesis
    using assms
    unfolding unit_disc_fix_f_circline_def
    by metis
qed

text \<open>Disc automorphisms - it would be nice to show that there are no disc automorphisms other than
unit disc fixing homographies and antihomographies, but this part of the theory is not yet
developed.\<close>

definition is_disc_aut where "is_disc_aut f \<longleftrightarrow> bij_betw f unit_disc unit_disc"

end


theory Tutorial1
imports Main
begin

section \<open>Exists in list\<close>
  (*
    Specify a function "listex P xs" that returns true if xs contains an element
    that satisfies "P". (I.e., if the list xs contains an element x such
    that "P x" is True)
  *)
  fun listex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
    "listex P [] = False"
  | "listex P (x#xs) \<longleftrightarrow> P x \<or> listex P xs"

  (* Show: The list xs@ys contains an element that satisfies P, if and only if xs or ys contain such an element *)
  lemma "listex P (xs@ys) \<longleftrightarrow> listex P xs \<or> listex P ys"
    apply (induction xs)
     apply auto
    done

section \<open>Minimum element in list\<close>

  (* Define a function that returns true if a list contains a specified element.
    Hint: Use listex! *)
  definition contains :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
    "contains x xs = listex (\<lambda>y. y=x) xs"
    (* Replace by your definition *)

  (* Specify a function that returns the minimum element of a list of integers.
    Explicitly define your function to be "undefined" for the empty list
    *)

  fun minlist :: "int list \<Rightarrow> int" where
    "minlist [] = undefined"
  | "minlist [x] = x"
  | "minlist (x#xs) = (min x (minlist xs))"
    (* Add other equations here *)

  (* Hint: If you used "let" in your specification, you want to inline
    it in your proofs by "simp add: Let_def".

    Similar, if you used the standard library function "min", you probably want
    to inline it by "simp add: min_def"
  *)

  (* Show: the minimum element is smaller than any element contained in the list *)
lemma "\<lbrakk> contains x l \<rbrakk> \<Longrightarrow> minlist l \<le> x"
  apply (induction l rule: minlist.induct)
    apply (auto simp: contains_def)
    done

  (* Specify and show: The minimum element
    of a non-empty list is contained in the list.
    Note: You are required to come up with the formula yourself, and then prove it
  *)
lemma "l\<noteq>[] \<Longrightarrow> contains (minlist l) l"
  apply (induction l rule: minlist.induct)
    apply (auto simp: contains_def min_def)
  done

  (* Specify and show: If there exists a negative element in the list,
    the minimum element of the list is negative
    *)
  lemma "listex (\<lambda>x. x<0) l \<Longrightarrow> minlist l < 0"
  apply (induction l rule: minlist.induct)
    apply (auto)
    done

section \<open>Run-Length encoding\<close>
  (* Only if some time remains *)

  (* The idea of run-length encoding is to replace a "run" of the same symbol
    by its length and one copy of the symbol. For example, the string
    "aaaabbcddddeffff" may be encoded as 4a2b1c4d1e4f.

    Background: This is a lossless compression algorithm which is most
      effective on artificially generated images, eg, screenshots.
      Look at your screen and estimate how many (long) runs of same-coloured
      pixels you have! For example, the only compression scheme supported
      by the (now historic) PCX image file format was run-length encoding.
  *)

  (* We describe coded words as pairs of a natural number and a symbol
      value of any type. ('a) *)

  type_synonym 'a rle = "nat\<times>'a"

  (* Model a function rlenc_aux, which takes as first arguments the
    current multiplicity and the current symbol, and then the remaining
    symbols to be encoded.

    ASSUME that the current multiplicity is always
    positive, i.e., make no special cases for current multiplicity to be
    zero. This means, we can only encode non-empty lists, but will make the
    proofs simpler. We will add the special case for empty lists later.
  *)

  fun rlenc_aux :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a rle list" where
    "rlenc_aux n a [] = [(n, a)]"
  | "rlenc_aux n a (x#xs) = (if a=x then rlenc_aux (Suc n) a xs else (n,a) # rlenc_aux 1 x xs)"

  (* Test cases *)
  value "rlenc_aux 3 CHR ''a'' [] = [(3,CHR ''a'')]"
    (* Already read a run of 3 'a's, nothing more to encode *)

  value "rlenc_aux 3 CHR ''a'' ''aabbbeff''
    = [(5,CHR ''a''), (3,CHR ''b''), (1,CHR ''e''), (2,CHR ''f'')]"
    (* Already read 3 'a's, yet have to encode the string 'aabbbeff' *)

  (* Recall: A string is just a char list *)
  term "''aaabbbccc''"

  (* Extending your function to also cover the empty list is then easy: *)
  definition rlenc :: "'a list \<Rightarrow> 'a rle list" where
    "rlenc l = (case l of [] \<Rightarrow> [] | x#xs \<Rightarrow> rlenc_aux 1 x xs)"

  (* Write a decoder function.
    Hint: You do not need any assumptions on counts being non-zero.
    Use the standard-library function "replicate".
  *)
  term replicate

  fun rldec :: "'a rle list \<Rightarrow> 'a list" where
    "rldec [] = []"
  | "rldec ((n,a) # xs) = replicate n a @ rldec xs"

  value "rldec [] = []"
  value "rldec [(7,CHR ''a''), (1,CHR ''b'')] = ''aaaaaaab''"

  (* Prove that encoding and then decoding yields the same list.
    HINT: You will need to generalize the lemma to the form:
      "rldec (rlenc_aux n a xs) = \<dots>"

  *)

  lemma rl_dec_enc_aux[simp]: "rldec (rlenc_aux n a xs) = replicate n a @ xs"
    apply (induction n a xs rule: rlenc_aux.induct)
    apply (auto simp: replicate_append_same)
    done

  lemma "rldec (rlenc xs) = xs"
    by (auto simp: rlenc_def split: list.split)

end


theory CS_Ch2
imports Main
begin

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

lemma add_zero_does_nothing[simp]: "add a 0 = a"
apply(induction a)
apply(auto)
done

lemma add_succ[simp]: "add a (Suc b) = Suc(add a b)"
  apply(induction a)
  apply auto
done

lemma add_comm: "add a b = add b a"
apply(induction a)
apply(auto)
done

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

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

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count _ [] = 0" |
"count e (x # xs) = (if e = x then Suc (count e xs) else count e xs)"

lemma count_less_than_length: "count x xs \<le> length xs"
apply(induction xs)
apply(auto)
done

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] a = [a]" |
"snoc (x # xs) a = x # (snoc xs a)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x # xs) = (reverse xs) @ [x]"

lemma rev_distributes_over_app: "reverse (xs @ ys) = (reverse ys) @ (reverse xs)"
apply(induction xs)
apply(auto)
done

lemma rev_undos_self: "reverse (reverse xs) = xs"
apply(induction xs)
apply(auto)
apply(simp add: rev_distributes_over_app)
done

fun sum :: "nat \<Rightarrow> nat" where
"sum 0 = 0" |
"sum (Suc n) = add (Suc n) (sum n)"

lemma add_doubles_under_div: "add n (m div 2) = (n + n + m) div 2"
apply(induction n)
apply(auto)
done

lemma euler_is_cheeky: "sum n = n * (n + 1) div 2"
apply(induction n)
apply(auto)
apply(simp add: add_doubles_under_div)
done

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node a b c) = b # (contents a) @ (contents c)"

fun treesum :: "nat tree \<Rightarrow> nat" where
"treesum Tip = 0" |
"treesum (Node a b c) = b + (treesum a) + (treesum c)"

lemma sum_preserved: "treesum t = listsum (contents t)"
apply(induction t)
apply(auto)
done

datatype 'a tree2  = Node "'a tree2" 'a "'a tree2" | Leaf "'a option"

fun mirror2 :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror2 (Leaf a) = Leaf a"  |
"mirror2 (Node a b c) = Node (mirror2 c) b (mirror2 a)"

lemma "mirror2(mirror2(t)) = t"
apply(induction t)
apply(auto)
done

fun pre_order :: "'a tree2 \<Rightarrow> 'a option list" where
"pre_order (Leaf a) = [a]" |
"pre_order (Node a b c) = (Some b) # (pre_order a) @ (pre_order c)"

fun post_order :: "'a tree2 \<Rightarrow> 'a option list" where
"post_order (Leaf a) = [a]" |
"post_order (Node a b c) = (post_order a) @ (post_order c) @ [Some b]"

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

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

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
apply(induction xs rule: intersperse.induct)
apply(auto)
done

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

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

datatype tree0 = Leaf | Node tree0 tree0

(* note: using "+" and "1" here is important for algebra_simps to kick in! *)

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

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

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

datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x" |
"eval (Const a) _ = a" |
"eval (Add a b) x = (eval a x) + (eval b x)" |
"eval (Mult a b) x = (eval a x) * (eval b x)"

fun evalp' :: "int list \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
"evalp' [] _ _ = 0" |
"evalp' (x # xs) val exp = (val^exp)*x + (evalp' xs val (Suc exp))"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp xs val = evalp' xs val 0"

fun coeff_add :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"coeff_add (x # xs) (y # ys) = (x + y) # (coeff_add xs ys)" |
"coeff_add [] ys = ys" |
"coeff_add xs [] = xs"

fun shift_list_by :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"shift_list_by 0 val xs = xs" |
"shift_list_by (Suc n) val xs = val # (shift_list_by n val xs)"

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

lemma "list_sum xs xs = map (\<lambda>x. x+x) xs"
apply(induction xs)
apply(auto)
done

fun fill_with :: "int list \<Rightarrow> int \<Rightarrow> int list" where
"fill_with (x # xs) val = val # fill_with xs val" |
"fill_with [] _ = []"
(*
fun coeff_mult' :: "int list \<Rightarrow> nat \<Rightarrow> int list \<Rightarrow> int list" where
"coeff_mult' [] n ys = []" |
"coeff_mult' (x # xs) n ys = list_sum (coeff_mult' xs (Suc n) ys) (shift_list_by n 0 (map (\<lambda>v. x*v) ys))"

fun coeff_mult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"coeff_mult xs ys = coeff_mult' xs 0 ys"
*)

fun coeff_mult_constant :: "int \<Rightarrow> int list \<Rightarrow> int list" where
"coeff_mult_constant a [] = []" |
"coeff_mult_constant a (x # xs) = (a * x) # coeff_mult_constant a xs"

fun coeff_mult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"coeff_mult [] ys = []" |
"coeff_mult (x # xs) ys = coeff_add (coeff_mult_constant x ys) (coeff_mult xs (0 # ys))"

(* I originally used a map instead of coeff_mult_constant, but I had a
   hard time trying to prove anything involving map. *)
lemma "coeff_mult_constant a xs = coeff_mult [a] xs"
apply(induction xs arbitrary: a)
apply(auto simp add: algebra_simps map_add_def)
done

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs Var = [0, 1]" |
"coeffs (Const a) = [a]" |
"coeffs (Add a b) = coeff_add (coeffs a) (coeffs b)" |
"coeffs (Mult a b) = coeff_mult (coeffs a) (coeffs b)"

lemma add_is_plus: "evalp' (coeff_add a b) x d = evalp' a x d + evalp' b x d"
apply(induction a b arbitrary: d rule: coeff_add.induct)
apply(auto simp add: algebra_simps)
done

lemma multiplying_by_a_constant_distributes: "evalp' (coeff_mult_constant a xs) x d = a * (evalp' xs x d)"
apply(induction xs arbitrary: d)
apply(auto simp add: algebra_simps add_is_plus)
done

lemma multiplying_by_x_extends_coeff_list: "x * evalp' a x d = evalp' (0 # a) x d"
apply(induction a arbitrary: d)
apply(auto simp add: algebra_simps)
done
lemma succ_of_exponent_mults_by_x: "evalp' a x (Suc d) = x * evalp' a x d"
apply(induction d)
apply(auto simp add: algebra_simps multiplying_by_x_extends_coeff_list)
done

lemma evalp_mult_can_swap: "evalp' a x 0 * evalp' b x n = evalp' b x 0 * evalp' a x n"
apply(induction n)
apply(auto simp add: algebra_simps succ_of_exponent_mults_by_x)
done

lemma mult_is_star: "evalp' (coeff_mult a b) x 0 = (evalp' a x 0) * (evalp' b x 0)"
apply(induction a arbitrary: b)
apply(auto simp add: algebra_simps add_is_plus multiplying_by_a_constant_distributes
  evalp_mult_can_swap)
done

lemma "evalp (coeffs poly) x = eval poly x"
apply(induction poly rule: coeffs.induct)
apply(auto simp add: algebra_simps mult_is_star add_is_plus)
done

end


theory Partial_Equivalence_Relation
imports Main
begin

subsection \<open>Partial Equivalence Relations\<close>
text \<open>
  The abstract datatype for a union-find structure is a partial equivalence
  relation.
\<close>

definition "part_equiv R \<equiv> sym R \<and> trans R"

lemma part_equivI[intro?]: "\<lbrakk>sym R; trans R\<rbrakk> \<Longrightarrow> part_equiv R"
  by (simp add: part_equiv_def)

lemma part_equiv_refl:
  "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (x,x)\<in>R"
  "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,y)\<in>R"
  by (metis part_equiv_def symD transD)+

lemma part_equiv_sym: "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,x)\<in>R"
  by (metis part_equiv_def symD)

lemma part_equiv_trans: "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,z)\<in>R \<Longrightarrow> (x,z)\<in>R"
  by (metis part_equiv_def transD)

lemma part_equiv_trans_sym:
  "\<lbrakk> part_equiv R; (a,b)\<in>R; (c,b)\<in>R \<rbrakk> \<Longrightarrow> (a,c)\<in>R"
  "\<lbrakk> part_equiv R; (a,b)\<in>R; (a,c)\<in>R \<rbrakk> \<Longrightarrow> (b,c)\<in>R"
  apply (metis part_equiv_sym part_equiv_trans)+
  done

text \<open>We define a shortcut for symmetric closure.\<close>
definition "symcl R \<equiv> R \<union> R\<inverse>"

text \<open>We also define a shortcut for melding the equivalence classes of
  two given elements\<close>
definition per_union where "per_union R a b \<equiv> R \<union>
  { (x,y). (x,a)\<in>R \<and> (y,b)\<in>R } \<union> { (y,x). (x,a)\<in>R \<and> (y,b)\<in>R }"

lemma union_part_equivp:
  "part_equiv R \<Longrightarrow> part_equiv (per_union R a b)"
  apply rule
  unfolding per_union_def
  apply (rule symI)
  apply (auto dest: part_equiv_sym) []

  apply (rule transI)
  apply (auto dest: part_equiv_trans part_equiv_trans_sym)
  done

lemma per_union_cmp:
  "\<lbrakk> part_equiv R; (l,j)\<in>R \<rbrakk> \<Longrightarrow> per_union R l j = R"
  unfolding per_union_def by (auto dest: part_equiv_trans_sym)

lemma per_union_same[simp]: "part_equiv R \<Longrightarrow> per_union R l l = R"
  unfolding per_union_def by (auto dest: part_equiv_trans_sym)

lemma per_union_commute[simp]: "per_union R i j = per_union R j i"
  unfolding per_union_def by auto

lemma per_union_dom[simp]: "Domain (per_union R i j) = Domain R"
  unfolding per_union_def by auto

lemma per_classes_dj:
  "\<lbrakk>part_equiv R; (i,j)\<notin>R\<rbrakk> \<Longrightarrow> R``{i} \<inter> R``{j} = {}"
  by (auto dest: part_equiv_trans_sym)

lemma per_class_in_dom: "\<lbrakk>part_equiv R\<rbrakk> \<Longrightarrow> R``{i} \<subseteq> Domain R"
  by (auto dest: part_equiv_trans_sym)

end


theory Chapter3
imports "HOL-IMP.BExp"
        "HOL-IMP.ASM"
        "Short_Theory"
begin

text\<open>
\section*{Chapter 3}

\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
\<close>

fun optimal :: "aexp \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
\<close>

lemma "optimal (asimp_const a)"
(* your definition/proof here *)

text\<open>
This proof needs the same \<open>split:\<close> directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without \<open>case\<close> expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function \<open>sumN\<close> that returns the sum of all
constants in an expression and a function \<open>zeroN\<close> that replaces all
constants in an expression by zeroes (they will be optimized away later):
\<close>

fun sumN :: "aexp \<Rightarrow> int" where
(* your definition/proof here *)

fun zeroN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

text\<open>
Next, define a function \<open>sepN\<close> that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
\<open>sepN\<close> preserves the value of an expression.
\<close>

definition sepN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

lemma aval_sepN: "aval (sepN t) s = aval t s"
(* your definition/proof here *)

text\<open>
Finally, define a function \<open>full_asimp\<close> that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
\<close>

definition full_asimp :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:subst}
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
\<close>

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

text\<open>
such that @{term "subst x a e"} is the result of replacing
every occurrence of variable \<open>x\<close> by \<open>a\<close> in \<open>e\<close>.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
\<close>

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
(* your definition/proof here *)

text\<open>
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
\<close>
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Take a copy of theory @{short_theory "AExp"} and modify it as follows.
Extend type @{typ aexp} with a binary constructor \<open>Times\<close> that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
\<close>

text\<open>
\endexercise

\exercise
Define a datatype \<open>aexp2\<close> of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function \<open>aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state\<close>
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend \<open>aexp2\<close> and \<open>aval2\<close> with a division operation. Model partiality of
division by changing the return type of \<open>aval2\<close> to
@{typ "(val \<times> state) option"}. In case of division by 0 let \<open>aval2\<close>
return @{const None}. Division on @{typ int} is the infix \<open>div\<close>.
\<close>

text\<open>
\endexercise

\exercise
The following type adds a \<open>LET\<close> construct to arithmetic expressions:
\<close>

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

text\<open>The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of \<open>e\<^sub>2\<close>
in the state where \<open>x\<close> is bound to the value of \<open>e\<^sub>1\<close> in the original state.
Define a function @{const lval} \<open>::\<close> @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{const inline} \<open>::\<close> @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of \<open>e\<^sub>1\<close> for \<open>x\<close> in the converted form of \<open>e\<^sub>2\<close>.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise

\exercise
Show that equality and less-or-equal tests on \<open>aexp\<close> are definable
\<close>

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open>
and prove that they do what they are supposed to:
\<close>

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
(* your definition/proof here *)

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional:\<close>

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

text\<open>First define an evaluation function analogously to @{const bval}:\<close>

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>Then define two translation functions\<close>

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
(* your definition/proof here *)

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open>and prove their correctness:\<close>

lemma "bval (if2bexp exp) s = ifval exp s"
(* your definition/proof here *)

lemma "ifval (b2ifexp exp) s = bval exp s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
\<close>

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text\<open>
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
\<close>

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"  |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text\<open>Define a function that checks whether a boolean exression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s:\<close>

fun is_nnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
Now define a function that converts a \<open>bexp\<close> into NNF by pushing
@{const NOT} inwards as much as possible:
\<close>

fun nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>
Prove that @{const nnf} does what it is supposed to do:
\<close>

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
(* your definition/proof here *)

lemma is_nnf_nnf: "is_nnf (nnf b)"
(* your definition/proof here *)

text\<open>
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
\<close>

fun is_dnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted \<open>b\<^sub>1\<close> and \<open>b\<^sub>2\<close>, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
\<open>dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)\<close>
= \<open>OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)\<close>. Define
\<close>

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>and prove that it behaves as follows:\<close>

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
(* your definition/proof here *)

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
(* your definition/proof here *)

text\<open>Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
\<close>

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>Prove the correctness of your function:\<close>

lemma "pbval (dnf_of_nnf b) s = pbval b s"
(* your definition/proof here *)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an \<open>ADD\<close>
instruction on a stack of size less than 2. In our semantics
a term @{term "exec1 ADD s stk"} where @{prop "length stk < 2"}
is simply some unspecified value, not an error or exception --- HOL does not have those concepts.
Modify theory @{short_theory "ASM"}
such that stack underflow is modelled by @{const None}
and normal execution by \<open>Some\<close>, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find \<open>split: option.split\<close> useful in your proofs.
\<close>

text\<open>
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
\<close>
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

text\<open>
where type \<open>reg\<close> is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads \<open>i\<close> into register \<open>r\<close>,
@{term "LD x r"} loads the value of \<open>x\<close> into register \<open>r\<close>,
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register \<open>r\<^sub>2\<close> to register \<open>r\<^sub>1\<close>.

Define the execution of an instruction given a state and a register state;
the result is the new register state:\<close>

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text\<open>
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.

The compiler takes an arithmetic expression \<open>a\<close> and a register \<open>r\<close>
and produces a list of instructions whose execution places the value of \<open>a\<close>
into \<open>r\<close>. The registers \<open>> r\<close> should be used in a stack-like fashion
for intermediate results, the ones \<open>< r\<close> should be left alone.
Define the compiler and prove it correct:
\<close>

theorem "exec (comp a r) s rs r = aval a s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:accumulator}
This exercise is a variation of the previous one
with a different instruction set:
\<close>

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

text\<open>
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register \<open>r\<close>, and @{term "ADD0 r"}
adds the value in register \<open>r\<close> to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
\<close>

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text\<open>
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression \<open>a\<close> and a register \<open>r\<close>
and produces a list of instructions whose execution places the value of \<open>a\<close>
into register 0. The registers \<open>> r\<close> should be used in a stack-like fashion
for intermediate results, the ones \<open>\<le> r\<close> should be left alone
(with the exception of 0). Define the compiler and prove it correct:
\<close>

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
(* your definition/proof here *)

text\<open>
\endexercise
\<close>

end